summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPhilFreeman <>2014-08-03 23:32:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2014-08-03 23:32:00 (GMT)
commit809181909fa5b629752975240cb6f3315d340519 (patch)
tree37efe613cf3e8f0a5587e9624fd7eb9189cd3928
parent6399ed506130f3f5df01289cda17f7b3b90bc9f3 (diff)
version 0.5.40.5.4
-rw-r--r--docgen/Main.hs13
-rw-r--r--hierarchy/Main.hs3
-rw-r--r--prelude/prelude.purs216
-rw-r--r--psci/Commands.hs5
-rw-r--r--psci/Main.hs37
-rw-r--r--psci/Parser.hs9
-rw-r--r--purescript.cabal3
-rw-r--r--src/Language/PureScript.hs39
-rw-r--r--src/Language/PureScript/CodeGen/Common.hs64
-rw-r--r--src/Language/PureScript/CodeGen/Externs.hs8
-rw-r--r--src/Language/PureScript/CodeGen/JS.hs132
-rw-r--r--src/Language/PureScript/CodeGen/JS/AST.hs13
-rw-r--r--src/Language/PureScript/Constants.hs25
-rw-r--r--src/Language/PureScript/DeadCodeElimination.hs24
-rw-r--r--src/Language/PureScript/Declarations.hs17
-rw-r--r--src/Language/PureScript/Environment.hs36
-rw-r--r--src/Language/PureScript/Optimizer.hs1
-rw-r--r--src/Language/PureScript/Optimizer/Blocks.hs15
-rw-r--r--src/Language/PureScript/Optimizer/Inliner.hs45
-rw-r--r--src/Language/PureScript/Optimizer/MagicDo.hs9
-rw-r--r--src/Language/PureScript/Parser/Common.hs1
-rw-r--r--src/Language/PureScript/Parser/Declarations.hs4
-rw-r--r--src/Language/PureScript/Parser/Types.hs14
-rw-r--r--src/Language/PureScript/Pretty/JS.hs14
-rw-r--r--src/Language/PureScript/Pretty/Values.hs9
-rw-r--r--src/Language/PureScript/Renamer.hs206
-rw-r--r--src/Language/PureScript/Sugar/BindingGroups.hs2
-rw-r--r--src/Language/PureScript/Sugar/Names.hs10
-rw-r--r--src/Language/PureScript/Sugar/TypeClasses.hs144
-rw-r--r--src/Language/PureScript/TypeChecker.hs34
-rw-r--r--src/Language/PureScript/TypeChecker/Monad.hs39
-rw-r--r--src/Language/PureScript/TypeChecker/Types.hs90
32 files changed, 1021 insertions, 260 deletions
diff --git a/docgen/Main.hs b/docgen/Main.hs
index a2708be..793a13d 100644
--- a/docgen/Main.hs
+++ b/docgen/Main.hs
@@ -25,6 +25,7 @@ import qualified Paths_purescript as Paths
import qualified System.IO.UTF8 as U
import System.Console.CmdTheLine
import System.Exit (exitSuccess, exitFailure)
+import System.IO (stderr)
docgen :: Bool -> [FilePath] -> IO ()
docgen showHierarchy input = do
@@ -37,7 +38,7 @@ parseFile input = do
text <- U.readFile input
case P.runIndentParser input P.parseModules text of
Left err -> do
- U.print err
+ U.hPutStr stderr $ show err
exitFailure
Right ms -> do
return ms
@@ -106,7 +107,7 @@ isExported (Just exps) decl = any (matches decl) exps
where
matches (P.TypeDeclaration ident _) (P.ValueRef ident') = ident == ident'
matches (P.ExternDeclaration _ ident _ _) (P.ValueRef ident') = ident == ident'
- matches (P.DataDeclaration ident _ _) (P.TypeRef ident' _) = ident == ident'
+ matches (P.DataDeclaration _ ident _ _) (P.TypeRef ident' _) = ident == ident'
matches (P.ExternDataDeclaration ident _) (P.TypeRef ident' _) = ident == ident'
matches (P.TypeSynonymDeclaration ident _ _) (P.TypeRef ident' _) = ident == ident'
matches (P.TypeClassDeclaration ident _ _ _) (P.TypeClassRef ident') = ident == ident'
@@ -138,10 +139,10 @@ renderDeclaration n _ (P.TypeDeclaration ident ty) =
atIndent n $ show ident ++ " :: " ++ prettyPrintType' ty
renderDeclaration n _ (P.ExternDeclaration _ ident _ ty) =
atIndent n $ show ident ++ " :: " ++ prettyPrintType' ty
-renderDeclaration n exps (P.DataDeclaration name args ctors) = do
+renderDeclaration n exps (P.DataDeclaration dtype name args ctors) = do
let typeName = P.runProperName name ++ (if null args then "" else " " ++ unwords args)
let exported = filter (isDctorExported name exps . fst) ctors
- atIndent n $ "data " ++ typeName ++ (if null exported then "" else " where")
+ atIndent n $ show dtype ++ " " ++ typeName ++ (if null exported then "" else " where")
forM_ exported $ \(ctor, tys) ->
atIndent (n + 2) $ P.runProperName ctor ++ " :: " ++ concatMap (\ty -> prettyPrintType' ty ++ " -> ") tys ++ typeName
renderDeclaration n _ (P.ExternDataDeclaration name kind) =
@@ -168,14 +169,14 @@ prettyPrintType' :: P.Type -> String
prettyPrintType' = P.prettyPrintType . P.everywhereOnTypes dePrim
where
dePrim ty@(P.TypeConstructor (P.Qualified _ name))
- | ty == P.tyBoolean || ty == P.tyNumber || ty == P.tyString =
+ | ty == P.tyBoolean || ty == P.tyNumber || ty == P.tyString =
P.TypeConstructor $ P.Qualified Nothing name
dePrim other = other
getName :: P.Declaration -> String
getName (P.TypeDeclaration ident _) = show ident
getName (P.ExternDeclaration _ ident _ _) = show ident
-getName (P.DataDeclaration name _ _) = P.runProperName name
+getName (P.DataDeclaration _ name _ _) = P.runProperName name
getName (P.ExternDataDeclaration name _) = P.runProperName name
getName (P.TypeSynonymDeclaration name _ _) = P.runProperName name
getName (P.TypeClassDeclaration name _ _ _) = P.runProperName name
diff --git a/hierarchy/Main.hs b/hierarchy/Main.hs
index 977f3f6..e015607 100644
--- a/hierarchy/Main.hs
+++ b/hierarchy/Main.hs
@@ -26,6 +26,7 @@ import System.Console.CmdTheLine
import System.Directory (createDirectoryIfMissing)
import System.FilePath ((</>))
import System.Exit (exitFailure, exitSuccess)
+import System.IO (stderr)
import Text.Parsec (ParseError)
@@ -57,7 +58,7 @@ compile :: FilePath -> Maybe FilePath -> IO ()
compile input mOutput = do
modules <- readInput input
case modules of
- Left err -> U.print err >> exitFailure
+ Left err -> U.hPutStr stderr (show err) >> exitFailure
Right ms -> do
for_ ms $ \(P.Module moduleName decls _) ->
let name = runModuleName moduleName
diff --git a/prelude/prelude.purs b/prelude/prelude.purs
index 2284412..23c1576 100644
--- a/prelude/prelude.purs
+++ b/prelude/prelude.purs
@@ -228,7 +228,7 @@ module Prelude
(%) = numMod
negate = numNegate
- data Unit = Unit {}
+ newtype Unit = Unit {}
unit :: Unit
unit = Unit {}
@@ -332,12 +332,21 @@ module Prelude
LT -> false
_ -> true
- foreign import unsafeCompare
- "function unsafeCompare(n1) {\
- \ return function(n2) {\
- \ return n1 < n2 ? LT : n1 > n2 ? GT : EQ;\
+ foreign import unsafeCompareImpl
+ "function unsafeCompareImpl(lt) {\
+ \ return function (eq) {\
+ \ return function (gt) {\
+ \ return function (x) {\
+ \ return function (y) {\
+ \ return x < y ? lt : x > y ? gt : eq;\
+ \ };\
+ \ };\
+ \ };\
\ };\
- \}" :: forall a. a -> a -> Ordering
+ \}" :: forall a. Ordering -> Ordering -> Ordering -> a -> a -> Ordering
+
+ unsafeCompare :: forall a. a -> a -> Ordering
+ unsafeCompare = unsafeCompareImpl LT EQ GT
instance ordUnit :: Ord Unit where
compare (Unit {}) (Unit {}) = EQ
@@ -490,88 +499,128 @@ module Data.Function where
foreign import data Fn3 :: * -> * -> * -> * -> *
foreign import data Fn4 :: * -> * -> * -> * -> * -> *
foreign import data Fn5 :: * -> * -> * -> * -> * -> * -> *
+ foreign import data Fn6 :: * -> * -> * -> * -> * -> * -> * -> *
+ foreign import data Fn7 :: * -> * -> * -> * -> * -> * -> * -> * -> *
+ foreign import data Fn8 :: * -> * -> * -> * -> * -> * -> * -> * -> * -> *
+ foreign import data Fn9 :: * -> * -> * -> * -> * -> * -> * -> * -> * -> * -> *
+ foreign import data Fn10 :: * -> * -> * -> * -> * -> * -> * -> * -> * -> * -> * -> *
foreign import mkFn0
- "function mkFn0(f) {\
+ "function mkFn0(fn) {\
\ return function() {\
- \ return f({});\
+ \ return fn({});\
\ };\
\}" :: forall a. (Unit -> a) -> Fn0 a
foreign import mkFn1
- "function mkFn1(f) {\
+ "function mkFn1(fn) {\
\ return function(a) {\
- \ return f(a);\
+ \ return fn(a);\
\ };\
\}" :: forall a b. (a -> b) -> Fn1 a b
foreign import mkFn2
- "function mkFn2(f) {\
+ "function mkFn2(fn) {\
\ return function(a, b) {\
- \ return f(a)(b);\
+ \ return fn(a)(b);\
\ };\
\}" :: forall a b c. (a -> b -> c) -> Fn2 a b c
foreign import mkFn3
- "function mkFn3(f) {\
+ "function mkFn3(fn) {\
\ return function(a, b, c) {\
- \ return f(a)(b)(c);\
+ \ return fn(a)(b)(c);\
\ };\
\}" :: forall a b c d. (a -> b -> c -> d) -> Fn3 a b c d
foreign import mkFn4
- "function mkFn4(f) {\
+ "function mkFn4(fn) {\
\ return function(a, b, c, d) {\
- \ return f(a)(b)(c)(d);\
+ \ return fn(a)(b)(c)(d);\
\ };\
\}" :: forall a b c d e. (a -> b -> c -> d -> e) -> Fn4 a b c d e
foreign import mkFn5
- "function mkFn5(f) {\
+ "function mkFn5(fn) {\
\ return function(a, b, c, d, e) {\
- \ return f(a)(b)(c)(d)(e);\
+ \ return fn(a)(b)(c)(d)(e);\
\ };\
\}" :: forall a b c d e f. (a -> b -> c -> d -> e -> f) -> Fn5 a b c d e f
+ foreign import mkFn6
+ "function mkFn6(fn) {\
+ \ return function(a, b, c, d, e, f) {\
+ \ return fn(a)(b)(c)(d)(e)(f);\
+ \ };\
+ \}" :: forall a b c d e f g. (a -> b -> c -> d -> e -> f -> g) -> Fn6 a b c d e f g
+
+ foreign import mkFn7
+ "function mkFn7(fn) {\
+ \ return function(a, b, c, d, e, f, g) {\
+ \ return fn(a)(b)(c)(d)(e)(f)(g);\
+ \ };\
+ \}" :: forall a b c d e f g h. (a -> b -> c -> d -> e -> f -> g -> h) -> Fn7 a b c d e f g h
+
+ foreign import mkFn8
+ "function mkFn8(fn) {\
+ \ return function(a, b, c, d, e, f, g, h) {\
+ \ return fn(a)(b)(c)(d)(e)(f)(g)(h);\
+ \ };\
+ \}" :: forall a b c d e f g h i. (a -> b -> c -> d -> e -> f -> g -> h -> i) -> Fn8 a b c d e f g h i
+
+ foreign import mkFn9
+ "function mkFn9(fn) {\
+ \ return function(a, b, c, d, e, f, g, h, i) {\
+ \ return fn(a)(b)(c)(d)(e)(f)(g)(h)(i);\
+ \ };\
+ \}" :: forall a b c d e f g h i j. (a -> b -> c -> d -> e -> f -> g -> h -> i -> j) -> Fn9 a b c d e f g h i j
+
+ foreign import mkFn10
+ "function mkFn10(fn) {\
+ \ return function(a, b, c, d, e, f, g, h, i, j) {\
+ \ return fn(a)(b)(c)(d)(e)(f)(g)(h)(i)(j);\
+ \ };\
+ \}" :: forall a b c d e f g h i j k. (a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k) -> Fn10 a b c d e f g h i j k
+
foreign import runFn0
- "function runFn0(f) {\
- \ return f();\
+ "function runFn0(fn) {\
+ \ return fn();\
\}" :: forall a. Fn0 a -> a
foreign import runFn1
- "function runFn1(f) {\
+ "function runFn1(fn) {\
\ return function(a) {\
- \ return f(a);\
+ \ return fn(a);\
\ };\
\}" :: forall a b. Fn1 a b -> a -> b
foreign import runFn2
- "function runFn2(f) {\
+ "function runFn2(fn) {\
\ return function(a) {\
\ return function(b) {\
- \ return f(a, b);\
+ \ return fn(a, b);\
\ };\
\ };\
\}" :: forall a b c. Fn2 a b c -> a -> b -> c
foreign import runFn3
- "function runFn3(f) {\
+ "function runFn3(fn) {\
\ return function(a) {\
\ return function(b) {\
\ return function(c) {\
- \ return f(a, b, c);\
+ \ return fn(a, b, c);\
\ };\
\ };\
\ };\
\}" :: forall a b c d. Fn3 a b c d -> a -> b -> c -> d
foreign import runFn4
- "function runFn4(f) {\
+ "function runFn4(fn) {\
\ return function(a) {\
\ return function(b) {\
\ return function(c) {\
\ return function(d) {\
- \ return f(a, b, c, d);\
+ \ return fn(a, b, c, d);\
\ };\
\ };\
\ };\
@@ -579,13 +628,13 @@ module Data.Function where
\}" :: forall a b c d e. Fn4 a b c d e -> a -> b -> c -> d -> e
foreign import runFn5
- "function runFn5(f) {\
+ "function runFn5(fn) {\
\ return function(a) {\
\ return function(b) {\
\ return function(c) {\
\ return function(d) {\
\ return function(e) {\
- \ return f(a, b, c, d, e);\
+ \ return fn(a, b, c, d, e);\
\ };\
\ };\
\ };\
@@ -593,9 +642,114 @@ module Data.Function where
\ };\
\}" :: forall a b c d e f. Fn5 a b c d e f -> a -> b -> c -> d -> e -> f
+ foreign import runFn6
+ "function runFn6(fn) {\
+ \ return function(a) {\
+ \ return function(b) {\
+ \ return function(c) {\
+ \ return function(d) {\
+ \ return function(e) {\
+ \ return function(f) {\
+ \ return fn(a, b, c, d, e, f);\
+ \ };\
+ \ };\
+ \ };\
+ \ };\
+ \ };\
+ \ };\
+ \}" :: forall a b c d e f g. Fn6 a b c d e f g -> a -> b -> c -> d -> e -> f -> g
+
+ foreign import runFn7
+ "function runFn7(fn) {\
+ \ return function(a) {\
+ \ return function(b) {\
+ \ return function(c) {\
+ \ return function(d) {\
+ \ return function(e) {\
+ \ return function(f) {\
+ \ return function(g) {\
+ \ return fn(a, b, c, d, e, f, g);\
+ \ };\
+ \ };\
+ \ };\
+ \ };\
+ \ };\
+ \ };\
+ \ };\
+ \}" :: forall a b c d e f g h. Fn7 a b c d e f g h -> a -> b -> c -> d -> e -> f -> g -> h
+
+ foreign import runFn8
+ "function runFn8(fn) {\
+ \ return function(a) {\
+ \ return function(b) {\
+ \ return function(c) {\
+ \ return function(d) {\
+ \ return function(e) {\
+ \ return function(f) {\
+ \ return function(g) {\
+ \ return function(h) {\
+ \ return fn(a, b, c, d, e, f, g, h);\
+ \ };\
+ \ };\
+ \ };\
+ \ };\
+ \ };\
+ \ };\
+ \ };\
+ \ };\
+ \}" :: forall a b c d e f g h i. Fn8 a b c d e f g h i -> a -> b -> c -> d -> e -> f -> g -> h -> i
+
+ foreign import runFn9
+ "function runFn9(fn) {\
+ \ return function(a) {\
+ \ return function(b) {\
+ \ return function(c) {\
+ \ return function(d) {\
+ \ return function(e) {\
+ \ return function(f) {\
+ \ return function(g) {\
+ \ return function(h) {\
+ \ return function(i) {\
+ \ return fn(a, b, c, d, e, f, g, h, i);\
+ \ };\
+ \ };\
+ \ };\
+ \ };\
+ \ };\
+ \ };\
+ \ };\
+ \ };\
+ \ };\
+ \}" :: forall a b c d e f g h i j. Fn9 a b c d e f g h i j -> a -> b -> c -> d -> e -> f -> g -> h -> i -> j
+
+ foreign import runFn10
+ "function runFn10(fn) {\
+ \ return function(a) {\
+ \ return function(b) {\
+ \ return function(c) {\
+ \ return function(d) {\
+ \ return function(e) {\
+ \ return function(f) {\
+ \ return function(g) {\
+ \ return function(h) {\
+ \ return function(i) {\
+ \ return function(j) {\
+ \ return fn(a, b, c, d, e, f, g, h, i, j);\
+ \ };\
+ \ };\
+ \ };\
+ \ };\
+ \ };\
+ \ };\
+ \ };\
+ \ };\
+ \ };\
+ \ };\
+ \}" :: forall a b c d e f g h i j k. Fn10 a b c d e f g h i j k -> a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k
+
module Data.Eq where
- data Ref a = Ref a
+ newtype Ref a = Ref a
liftRef :: forall a b. (a -> a -> b) -> Ref a -> Ref a -> b
liftRef f (Ref x) (Ref y) = f x y
diff --git a/psci/Commands.hs b/psci/Commands.hs
index 28fc2b8..001f3f5 100644
--- a/psci/Commands.hs
+++ b/psci/Commands.hs
@@ -53,6 +53,10 @@ data Command
-- Find the type of an expression
--
| TypeOf Value
+ -- |
+ -- Find the kind of an expression
+ --
+ | KindOf Type
-- |
-- The help menu.
@@ -65,4 +69,5 @@ help =
, [":q ", "Quit PSCi"]
, [":r ", "Reset"]
, [":t <expr> ", "Show the type of <expr>"]
+ , [":k <type> ", "Show the kind of <type>"]
]
diff --git a/psci/Main.hs b/psci/Main.hs
index 577679c..6aed0d2 100644
--- a/psci/Main.hs
+++ b/psci/Main.hs
@@ -24,6 +24,7 @@ import Control.Monad
import Control.Monad.Trans.Class
import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
import Control.Monad.Trans.State.Strict
+import qualified Control.Monad.Trans.State.Lazy as L
import Control.Monad.Error (ErrorT(..), MonadError)
import Control.Monad.Error.Class (MonadError(..))
@@ -256,6 +257,18 @@ createTemporaryModule exec PSCiState{psciImportedModuleNames = imports, psciLetB
in
P.Module moduleName ((importDecl `map` imports) ++ decls) Nothing
+-- |
+-- Makes a volatile module to hold a non-qualified type synonym for a fully-qualified data type declaration.
+--
+createTemporaryModuleForKind :: PSCiState -> P.Type -> P.Module
+createTemporaryModuleForKind PSCiState{psciImportedModuleNames = imports} typ =
+ let
+ moduleName = P.ModuleName [P.ProperName "Main"]
+ importDecl m = P.ImportDeclaration m Nothing Nothing
+ itDecl = P.TypeSynonymDeclaration (P.ProperName "IT") [] typ
+ in
+ P.Module moduleName ((importDecl `map` imports) ++ [itDecl]) Nothing
+
modulesDir :: FilePath
modulesDir = ".psci_modules" ++ pathSeparator : "node_modules"
@@ -293,9 +306,30 @@ handleTypeOf value = do
Left err -> PSCI $ outputStrLn err
Right env' ->
case M.lookup (P.ModuleName [P.ProperName "Main"], P.Ident "it") (P.names env') of
- Just (ty, _) -> PSCI . outputStrLn . P.prettyPrintType $ ty
+ Just (ty, _, _) -> PSCI . outputStrLn . P.prettyPrintType $ ty
Nothing -> PSCI $ outputStrLn "Could not find type"
+-- |
+-- Takes a value and prints its kind
+--
+handleKindOf :: P.Type -> PSCI ()
+handleKindOf typ = do
+ st <- PSCI $ lift get
+ let m = createTemporaryModuleForKind st typ
+ mName = P.ModuleName [P.ProperName "Main"]
+ e <- psciIO . runMake $ P.make modulesDir options (psciLoadedModules st ++ [("Main.purs", m)])
+ case e of
+ Left err -> PSCI $ outputStrLn err
+ Right env' ->
+ case M.lookup (P.Qualified (Just mName) $ P.ProperName "IT") (P.typeSynonyms env') of
+ Just (_, typ') -> do
+ let chk = P.CheckState env' 0 0 (Just mName)
+ k = L.runStateT (P.unCheck (P.kindOf mName typ')) chk
+ case k of
+ Left errStack -> PSCI . outputStrLn . P.prettyPrintErrorStack False $ errStack
+ Right (kind, _) -> PSCI . outputStrLn . P.prettyPrintKind $ kind
+ Nothing -> PSCI $ outputStrLn "Could not find kind"
+
-- Commands
-- |
@@ -339,6 +373,7 @@ handleCommand Reset = do
Left err -> psciIO $ putStrLn err >> exitFailure
Right modules -> PSCI . lift $ put (PSCiState files defaultImports modules [])
handleCommand (TypeOf val) = handleTypeOf val
+handleCommand (KindOf typ) = handleKindOf typ
handleCommand _ = PSCI $ outputStrLn "Unknown command"
inputFiles :: Cmd.Term [FilePath]
diff --git a/psci/Parser.hs b/psci/Parser.hs
index 6d12b00..b507f1e 100644
--- a/psci/Parser.hs
+++ b/psci/Parser.hs
@@ -42,7 +42,7 @@ psciLet = Let <$> (P.Let <$> (P.reserved "let" *> P.indented *> C.mark (many1 (C
--
parseCommand :: String -> Either ParseError Command
parseCommand = P.runIndentParser "" $ choice
- [ P.whiteSpace *> char ':' *> (psciHelp <|> psciImport <|> psciLoadFile <|> psciQuit <|> psciReload <|> psciTypeOf)
+ [ P.whiteSpace *> char ':' *> (psciHelp <|> psciImport <|> psciLoadFile <|> psciQuit <|> psciReload <|> psciTypeOf <|> psciKindOf)
, try psciLet
, psciExpression
] <* eof
@@ -90,3 +90,10 @@ psciReload = Reset <$ char 'r'
--
psciTypeOf :: Parsec String P.ParseState Command
psciTypeOf = TypeOf <$> (char 't' *> P.whiteSpace *> P.parseValue)
+
+
+-- |
+-- Parses 'Commands.KindOf' command.
+--
+psciKindOf :: Parsec String P.ParseState Command
+psciKindOf = KindOf <$> (char 'k' *> P.whiteSpace *> P.parseType)
diff --git a/purescript.cabal b/purescript.cabal
index 9a31906..4cb138f 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -1,5 +1,5 @@
name: purescript
-version: 0.5.3
+version: 0.5.4
cabal-version: >=1.8
build-type: Custom
license: MIT
@@ -76,6 +76,7 @@ library
Language.PureScript.Pretty.Kinds
Language.PureScript.Pretty.Types
Language.PureScript.Pretty.Values
+ Language.PureScript.Renamer
Language.PureScript.TypeChecker
Language.PureScript.TypeChecker.Kinds
Language.PureScript.TypeChecker.Monad
diff --git a/src/Language/PureScript.hs b/src/Language/PureScript.hs
index eadd44d..54bd11f 100644
--- a/src/Language/PureScript.hs
+++ b/src/Language/PureScript.hs
@@ -31,6 +31,7 @@ import Language.PureScript.Environment as P
import Language.PureScript.Errors as P
import Language.PureScript.DeadCodeElimination as P
import Language.PureScript.Supply as P
+import Language.PureScript.Renamer as P
import qualified Language.PureScript.Constants as C
@@ -70,14 +71,15 @@ compile = compile' initEnvironment
compile' :: Environment -> Options -> [Module] -> Either String (String, String, Environment)
compile' env opts ms = do
- (sorted, _) <- sortModules $ if optionsNoPrelude opts then ms else (map importPrelude ms)
+ (sorted, _) <- sortModules $ map importPrim $ if optionsNoPrelude opts then ms else (map importPrelude ms)
(desugared, nextVar) <- stringifyErrorStack True $ runSupplyT 0 $ desugar sorted
(elaborated, env') <- runCheck' opts env $ forM desugared $ typeCheckModule mainModuleIdent
regrouped <- stringifyErrorStack True $ createBindingGroupsModule . collapseBindingGroupsModule $ elaborated
let entryPoints = moduleNameFromString `map` optionsModules opts
let elim = if null entryPoints then regrouped else eliminateDeadCode entryPoints regrouped
+ let renamed = renameInModules elim
let codeGenModules = moduleNameFromString `map` optionsCodeGenModules opts
- let modulesToCodeGen = if null codeGenModules then elim else filter (\(Module mn _ _) -> mn `elem` codeGenModules) elim
+ let modulesToCodeGen = if null codeGenModules then renamed else filter (\(Module mn _ _) -> mn `elem` codeGenModules) renamed
let js = evalSupply nextVar $ concat <$> mapM (\m -> moduleToJs Globals opts m env') modulesToCodeGen
let exts = intercalate "\n" . map (`moduleToPs` env') $ modulesToCodeGen
js' <- generateMain env' opts js
@@ -170,7 +172,7 @@ make :: (Functor m, Applicative m, Monad m, MonadMake m) => FilePath -> Options
make outputDir opts ms = do
let filePathMap = M.fromList (map (\(fp, Module mn _ _) -> (mn, fp)) ms)
- (sorted, graph) <- liftError $ sortModules $ if optionsNoPrelude opts then map snd ms else (map (importPrelude . snd) ms)
+ (sorted, graph) <- liftError $ sortModules $ map importPrim $ if optionsNoPrelude opts then map snd ms else (map (importPrelude . snd) ms)
toRebuild <- foldM (\s (Module moduleName' _ _) -> do
let filePath = runModuleName moduleName'
@@ -212,8 +214,10 @@ make outputDir opts ms = do
regrouped <- lift . liftError . stringifyErrorStack True . createBindingGroups moduleName' . collapseBindingGroups $ elaborated
let mod' = Module moduleName' regrouped exps
- js <- prettyPrintJS <$> moduleToJs CommonJS opts mod' env'
- let exts = moduleToPs mod' env'
+ let [renamed] = renameInModules [mod']
+
+ js <- prettyPrintJS <$> moduleToJs CommonJS opts renamed env'
+ let exts = moduleToPs renamed env'
lift $ writeTextFile jsFile js
lift $ writeTextFile externsFile exts
@@ -241,16 +245,19 @@ reverseDependencies g = combine [ (dep, mn) | (mn, deps) <- g, dep <- deps ]
combine = M.fromList . map ((fst . head) &&& map snd) . groupBy ((==) `on` fst) . sortBy (compare `on` fst)
-- |
--- Add an import declaration for the Prelude to a module if it does not already explicitly import
--- it.
+-- Add an import declaration for a module if it does not already explicitly import it.
--
-importPrelude :: Module -> Module
-importPrelude m@(Module mn decls exps) =
- if isPreludeImport `any` decls || mn == prelude then m
- else Module mn (preludeImport : decls) exps
+addDefaultImport :: ModuleName -> Module -> Module
+addDefaultImport toImport m@(Module mn decls exps) =
+ if isExistingImport `any` decls || mn == toImport then m
+ else Module mn (ImportDeclaration toImport Nothing Nothing : decls) exps
where
- prelude = ModuleName [ProperName C.prelude]
- isPreludeImport (ImportDeclaration (ModuleName [ProperName mn']) _ _) | mn' == C.prelude = True
- isPreludeImport (PositionedDeclaration _ d) = isPreludeImport d
- isPreludeImport _ = False
- preludeImport = ImportDeclaration prelude Nothing Nothing
+ isExistingImport (ImportDeclaration mn' _ _) | mn' == toImport = True
+ isExistingImport (PositionedDeclaration _ d) = isExistingImport d
+ isExistingImport _ = False
+
+importPrim :: Module -> Module
+importPrim = addDefaultImport (ModuleName [ProperName C.prim])
+
+importPrelude :: Module -> Module
+importPrelude = addDefaultImport (ModuleName [ProperName C.prelude])
diff --git a/src/Language/PureScript/CodeGen/Common.hs b/src/Language/PureScript/CodeGen/Common.hs
index 297bdc4..f8af6d8 100644
--- a/src/Language/PureScript/CodeGen/Common.hs
+++ b/src/Language/PureScript/CodeGen/Common.hs
@@ -17,7 +17,14 @@ module Language.PureScript.CodeGen.Common where
import Data.Char
import Data.List (intercalate)
+import Data.Maybe (fromMaybe)
+import Data.Function (on)
+
+import qualified Data.Map as M
+
import Language.PureScript.Names
+import Language.PureScript.Environment
+import Language.PureScript.Types
-- |
-- Convert an Ident into a valid Javascript identifier:
@@ -34,6 +41,12 @@ identToJs (Ident name) = concatMap identCharToString name
identToJs (Op op) = concatMap identCharToString op
-- |
+-- Test if a string is a valid JS identifier without escaping.
+--
+identNeedsEscaping :: String -> Bool
+identNeedsEscaping s = s /= identToJs (Ident s)
+
+-- |
-- Attempts to find a human-readable name for a symbol, if none has been specified returns the
-- ordinal value.
--
@@ -130,12 +143,51 @@ nameIsJsReserved name =
, "with"
, "yield" ]
+moduleNameToJs :: ModuleName -> String
+moduleNameToJs (ModuleName pns) = intercalate "_" (runProperName `map` pns)
+
-- |
--- Test if a string is a valid JS identifier (may return false negatives)
+-- Finds the value stored for a data constructor in the current environment.
+-- This is a partial function, but if an invalid type has reached this far then
+-- something has gone wrong in typechecking.
--
-isIdent :: String -> Bool
-isIdent s@(first : rest) | not (nameIsJsReserved s) && isAlpha first && all isAlphaNum rest = True
-isIdent _ = False
+lookupConstructor :: Environment -> Qualified ProperName -> (DataDeclType, ProperName, Type)
+lookupConstructor e ctor = fromMaybe (error "Data constructor not found") $ ctor `M.lookup` dataConstructors e
-moduleNameToJs :: ModuleName -> String
-moduleNameToJs (ModuleName pns) = intercalate "_" (runProperName `map` pns)
+-- |
+-- Checks whether a data constructor is the only constructor for that type, used
+-- to simplify the check when generating code for binders.
+--
+isOnlyConstructor :: Environment -> Qualified ProperName -> Bool
+isOnlyConstructor e ctor = numConstructors (ctor, lookupConstructor e ctor) == 1
+ where
+ numConstructors :: (Qualified ProperName, (DataDeclType, ProperName, Type)) -> Int
+ numConstructors ty = length $ filter (((==) `on` typeConstructor) ty) $ M.toList $ dataConstructors e
+ typeConstructor :: (Qualified ProperName, (DataDeclType, ProperName, Type)) -> (ModuleName, ProperName)
+ typeConstructor (Qualified (Just moduleName) _, (_, tyCtor, _)) = (moduleName, tyCtor)
+ typeConstructor _ = error "Invalid argument to isOnlyConstructor"
+
+-- |
+-- Checks whether a data constructor is for a newtype.
+--
+isNewtypeConstructor :: Environment -> Qualified ProperName -> Bool
+isNewtypeConstructor e ctor = case lookupConstructor e ctor of
+ (Newtype, _, _) -> True
+ (Data, _, _) -> False
+
+-- |
+-- Checks the number of arguments a data constructor accepts.
+--
+getConstructorArity :: Environment -> Qualified ProperName -> Int
+getConstructorArity e = go . (\(_, _, ctors) -> ctors) . lookupConstructor e
+ where
+ go :: Type -> Int
+ go (TypeApp (TypeApp f _) t) | f == tyFunction = go t + 1
+ go (ForAll _ ty _) = go ty
+ go _ = 0
+
+-- |
+-- Checks whether a data constructor has no arguments, for example, `Nothing`.
+--
+isNullaryConstructor :: Environment -> Qualified ProperName -> Bool
+isNullaryConstructor e = (== 0) . getConstructorArity e
diff --git a/src/Language/PureScript/CodeGen/Externs.hs b/src/Language/PureScript/CodeGen/Externs.hs
index 6757465..c8ede82 100644
--- a/src/Language/PureScript/CodeGen/Externs.hs
+++ b/src/Language/PureScript/CodeGen/Externs.hs
@@ -24,6 +24,7 @@ import qualified Data.Map as M
import Control.Monad.Writer
+import Language.PureScript.CodeGen.Common
import Language.PureScript.TypeClassDictionaries
import Language.PureScript.Declarations
import Language.PureScript.Pretty
@@ -60,7 +61,10 @@ moduleToPs (Module moduleName ds (Just exts)) env = intercalate "\n" . execWrite
printDctor dctor = case dctor `lookup` tys of
Nothing -> Nothing
Just tyArgs -> Just $ show dctor ++ " " ++ unwords (map prettyPrintTypeAtom tyArgs)
- tell ["data " ++ show pn ++ " " ++ unwords args ++ (if null dctors' then "" else " = " ++ intercalate " | " (mapMaybe printDctor dctors'))]
+ let dtype = if length dctors' == 1 && isNewtypeConstructor env (Qualified (Just moduleName) $ head dctors')
+ then "newtype"
+ else "data"
+ tell [dtype ++ " " ++ show pn ++ " " ++ unwords args ++ (if null dctors' then "" else " = " ++ intercalate " | " (mapMaybe printDctor dctors'))]
Just (_, TypeSynonym) ->
case Qualified (Just moduleName) pn `M.lookup` typeSynonyms env of
Nothing -> error $ show pn ++ " has no type synonym info in exportToPs"
@@ -71,7 +75,7 @@ moduleToPs (Module moduleName ds (Just exts)) env = intercalate "\n" . execWrite
exportToPs (ValueRef ident) =
case (moduleName, ident) `M.lookup` names env of
Nothing -> error $ show ident ++ " has no type in exportToPs"
- Just (ty, nameKind) | nameKind == Value || nameKind == Extern ForeignImport || nameKind == Extern InlineJavascript ->
+ Just (ty, nameKind, _) | nameKind == Value || nameKind == Extern ForeignImport || nameKind == Extern InlineJavascript ->
tell ["foreign import " ++ show ident ++ " :: " ++ prettyPrintType ty]
_ -> return ()
exportToPs (TypeClassRef className) =
diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs
index 6184461..dfe965f 100644
--- a/src/Language/PureScript/CodeGen/JS.hs
+++ b/src/Language/PureScript/CodeGen/JS.hs
@@ -20,18 +20,16 @@ module Language.PureScript.CodeGen.JS (
ModuleType(..),
declToJs,
moduleToJs,
- isIdent
+ identNeedsEscaping
) where
-import Data.Maybe (catMaybes, fromJust, fromMaybe)
+import Data.Maybe (catMaybes, fromJust)
import Data.Function (on)
-import Data.List (nub, (\\))
+import Data.List (nub, (\\), delete, sortBy)
import Control.Monad (replicateM, forM)
import Control.Applicative
-import qualified Data.Map as M
-
import Language.PureScript.Names
import Language.PureScript.Declarations
import Language.PureScript.Options
@@ -42,6 +40,7 @@ import Language.PureScript.CodeGen.Common
import Language.PureScript.Environment
import Language.PureScript.Supply
import Language.PureScript.Traversals (sndM)
+import qualified Language.PureScript.Constants as C
-- |
-- Different types of modules which are supported
@@ -54,7 +53,7 @@ data ModuleType = CommonJS | Globals
--
moduleToJs :: (Functor m, Applicative m, Monad m) => ModuleType -> Options -> Module -> Environment -> SupplyT m [JS]
moduleToJs mt opts (Module name decls (Just exps)) env = do
- let jsImports = map (importToJs mt opts) . (\\ [name]) . nub $ concatMap imports decls
+ let jsImports = map (importToJs mt opts) . delete (ModuleName [ProperName C.prim]) . (\\ [name]) . nub $ concatMap imports decls
jsDecls <- mapM (\decl -> declToJs opts name decl env) decls
let optimized = concat $ map (map $ optimize opts) $ catMaybes jsDecls
let isModuleEmpty = null optimized
@@ -79,14 +78,19 @@ importToJs mt opts mn = JSVariableIntroduction (moduleNameToJs mn) (Just moduleB
Globals -> JSAccessor (moduleNameToJs mn) (JSVar (fromJust (optionsBrowserNamespace opts)))
imports :: Declaration -> [ModuleName]
-imports =
- let (f, _, _, _, _) = everythingOnValues (++) (const []) collect (const []) (const []) (const [])
- in f
+imports (ImportDeclaration mn _ _) = [mn]
+imports other =
+ let (f, _, _, _, _) = everythingOnValues (++) (const []) collectV collectB (const []) (const [])
+ in f other
where
- collect :: Value -> [ModuleName]
- collect (Var (Qualified (Just mn) _)) = [mn]
- collect (Constructor (Qualified (Just mn) _)) = [mn]
- collect _ = []
+ collectV :: Value -> [ModuleName]
+ collectV (Var (Qualified (Just mn) _)) = [mn]
+ collectV (Constructor (Qualified (Just mn) _)) = [mn]
+ collectV (TypeClassDictionaryConstructorApp (Qualified (Just mn) _) _) = [mn]
+ collectV _ = []
+ collectB :: Binder -> [ModuleName]
+ collectB (ConstructorBinder (Qualified (Just mn) _) _) = [mn]
+ collectB _ = []
-- |
-- Generate code in the simplified Javascript intermediate representation for a declaration
@@ -100,19 +104,55 @@ declToJs opts mp (BindingGroupDeclaration vals) e = do
js <- valueToJs opts mp e val
return $ JSVariableIntroduction (identToJs ident) (Just js)
return $ Just jss
-declToJs _ mp (DataDeclaration _ _ ctors) _ = do
+declToJs _ _ (DataDeclaration Newtype _ _ [((ProperName ctor), _)]) _ =
+ return $ Just $ [JSVariableIntroduction ctor (Just $
+ JSObjectLiteral [("create",
+ JSFunction Nothing ["value"]
+ (JSBlock [JSReturn $ JSVar "value"]))])]
+declToJs _ _ (DataDeclaration Newtype _ _ _) _ =
+ error "newtype has multiple constructors"
+declToJs _ mp (DataDeclaration Data _ _ ctors) e = do
return $ Just $ flip concatMap ctors $ \(pn@(ProperName ctor), tys) ->
- [JSVariableIntroduction ctor (Just (go pn 0 tys []))]
+ let propName = if isNullaryConstructor e (Qualified (Just mp) pn) then "value" else "create"
+ in [ makeConstructor ctor (length tys)
+ , JSAssignment (JSAccessor propName (JSVar ctor)) (go pn 0 (length tys) [])
+ ]
where
- go :: ProperName -> Integer -> [Type] -> [JS] -> JS
- go pn _ [] values =
- JSObjectLiteral [ ("ctor", JSStringLiteral (show (Qualified (Just mp) pn))), ("values", JSArrayLiteral $ reverse values) ]
- go pn index (_ : tys') values =
+ makeConstructor :: String -> Int -> JS
+ makeConstructor ctorName n =
+ let
+ args = [ "value" ++ show index | index <- [0..n-1] ]
+ body = [ JSAssignment (JSAccessor arg (JSVar "this")) (JSVar arg) | arg <- args ]
+ in JSFunction (Just ctorName) args (JSBlock body)
+ go :: ProperName -> Int -> Int -> [JS] -> JS
+ go pn _ 0 values = JSUnary JSNew $ JSApp (JSVar $ runProperName pn) (reverse values)
+ go pn index n values =
JSFunction Nothing ["value" ++ show index]
- (JSBlock [JSReturn (go pn (index + 1) tys' (JSVar ("value" ++ show index) : values))])
+ (JSBlock [JSReturn (go pn (index + 1) (n - 1) (JSVar ("value" ++ show index) : values))])
declToJs opts mp (DataBindingGroupDeclaration ds) e = do
jss <- mapM (\decl -> declToJs opts mp decl e) ds
return $ Just $ concat $ catMaybes jss
+declToJs _ _ (TypeClassDeclaration name _ supers members) _ =
+ return $ Just $ [
+ JSFunction (Just $ runProperName name) (identToJs `map` args)
+ (JSBlock $ assn `map` args)]
+ where
+ assn :: Ident -> JS
+ assn arg = JSAssignment (accessor arg (JSVar "this")) (var arg)
+ args :: [Ident]
+ args = sortBy (compare `on` runIdent) $ memberNames ++ superNames
+ memberNames :: [Ident]
+ memberNames = memberToName `map` members
+ superNames :: [Ident]
+ superNames = [ toSuperName superclass index
+ | (index, (superclass, _)) <- zip [0..] supers
+ ]
+ toSuperName :: Qualified ProperName -> Integer -> Ident
+ toSuperName pn index = Ident $ C.__superclass_ ++ show pn ++ "_" ++ show index
+ memberToName :: Declaration -> Ident
+ memberToName (TypeDeclaration ident _) = ident
+ memberToName (PositionedDeclaration _ d) = memberToName d
+ memberToName _ = error "Invalid declaration in type class definition"
declToJs _ _ (ExternDeclaration _ _ (Just js) _) _ = return $ Just [js]
declToJs opts mp (PositionedDeclaration _ d) e = declToJs opts mp d e
declToJs _ _ _ _ = return Nothing
@@ -124,6 +164,7 @@ exportToJs :: DeclarationRef -> [(String, JS)]
exportToJs (TypeRef _ (Just dctors)) = map ((\n -> (n, var (Ident n))) . runProperName) dctors
exportToJs (ValueRef name) = [(runIdent name, var name)]
exportToJs (TypeInstanceRef name) = [(runIdent name, var name)]
+exportToJs (TypeClassRef name) = [(runProperName name, var $ Ident $ runProperName name)]
exportToJs _ = []
-- |
@@ -143,8 +184,8 @@ accessor (Ident prop) = accessorString prop
accessor (Op op) = JSIndexer (JSStringLiteral op)
accessorString :: String -> JS -> JS
-accessorString prop | isIdent prop = JSAccessor prop
- | otherwise = JSIndexer (JSStringLiteral prop)
+accessorString prop | identNeedsEscaping prop = JSIndexer (JSStringLiteral prop)
+ | otherwise = JSAccessor prop
-- |
-- Generate code in the simplified Javascript intermediate representation for a value or expression.
@@ -155,17 +196,36 @@ valueToJs _ _ _ (StringLiteral s) = return $ JSStringLiteral s
valueToJs _ _ _ (BooleanLiteral b) = return $ JSBooleanLiteral b
valueToJs opts m e (ArrayLiteral xs) = JSArrayLiteral <$> mapM (valueToJs opts m e) xs
valueToJs opts m e (ObjectLiteral ps) = JSObjectLiteral <$> mapM (sndM (valueToJs opts m e)) ps
+valueToJs opts m e (TypeClassDictionaryConstructorApp name (TypedValue _ (ObjectLiteral ps) _)) =
+ JSUnary JSNew . JSApp (qualifiedToJS m (Ident . runProperName) name) <$> mapM (valueToJs opts m e . snd) (sortBy (compare `on` fst) ps)
+valueToJs _ _ _ TypeClassDictionaryConstructorApp{} =
+ error "TypeClassDictionaryConstructorApp did not contain object literal"
valueToJs opts m e (ObjectUpdate o ps) = do
obj <- valueToJs opts m e o
sts <- mapM (sndM (valueToJs opts m e)) ps
extendObj obj sts
-valueToJs _ m _ (Constructor name) = return $ qualifiedToJS m (Ident . runProperName) name
+valueToJs _ m e (Constructor name) =
+ let propName = if isNullaryConstructor e name then "value" else "create"
+ in return $ JSAccessor propName $ qualifiedToJS m (Ident . runProperName) name
valueToJs opts m e (Case values binders) = do
vals <- mapM (valueToJs opts m e) values
bindersToJs opts m e binders vals
valueToJs opts m e (IfThenElse cond th el) = JSConditional <$> valueToJs opts m e cond <*> valueToJs opts m e th <*> valueToJs opts m e el
valueToJs opts m e (Accessor prop val) = accessorString prop <$> valueToJs opts m e val
-valueToJs opts m e (App val arg) = JSApp <$> valueToJs opts m e val <*> (return <$> valueToJs opts m e arg)
+valueToJs opts m e v@App{} = do
+ let (f, args) = unApp v []
+ args' <- mapM (valueToJs opts m e) args
+ case f of
+ Constructor name | isNewtypeConstructor e name && length args == 1 -> return (head args')
+ Constructor name | getConstructorArity e name == length args ->
+ return $ JSUnary JSNew $ JSApp (qualifiedToJS m (Ident . runProperName) name) args'
+ _ -> flip (foldl (\fn a -> JSApp fn [a])) args' <$> valueToJs opts m e f
+ where
+ unApp :: Value -> [Value] -> (Value, [Value])
+ unApp (App val arg) args = unApp val (arg : args)
+ unApp (PositionedValue _ val) args = unApp val args
+ unApp (TypedValue _ val _) args = unApp val args
+ unApp other args = (other, args)
valueToJs opts m e (Let ds val) = do
decls <- concat . catMaybes <$> mapM (flip (declToJs opts m) e) ds
ret <- valueToJs opts m e val
@@ -260,7 +320,7 @@ bindersToJs opts m e binders vals = do
jss <- forM binders $ \(CaseAlternative bs grd result) -> do
ret <- valueToJs opts m e result
go valNames [JSReturn ret] bs grd
- return $ JSApp (JSFunction Nothing valNames (JSBlock (concat jss ++ [JSThrow (JSStringLiteral "Failed pattern match")])))
+ return $ JSApp (JSFunction Nothing valNames (JSBlock (concat jss ++ [JSThrow $ JSUnary JSNew $ JSApp (JSVar "Error") $ [(JSStringLiteral "Failed pattern match")]])))
vals
where
go :: (Functor m, Applicative m, Monad m) => [String] -> [JS] -> [Binder] -> Maybe Guard -> SupplyT m [JS]
@@ -289,13 +349,17 @@ binderToJs _ _ varName done (BooleanBinder False) =
return [JSIfElse (JSUnary Not (JSVar varName)) (JSBlock done) Nothing]
binderToJs _ _ varName done (VarBinder ident) =
return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : done)
+binderToJs m e varName done (ConstructorBinder ctor bs) | isNewtypeConstructor e ctor =
+ case bs of
+ [b] -> binderToJs m e varName done b
+ _ -> error "binder for newtype constructor should have a single argument"
binderToJs m e varName done (ConstructorBinder ctor bs) = do
js <- go 0 done bs
if isOnlyConstructor e ctor
then
return js
else
- return [JSIfElse (JSBinary EqualTo (JSAccessor "ctor" (JSVar varName)) (JSStringLiteral (show ctor)))
+ return [JSIfElse (JSInstanceOf (JSVar varName) (qualifiedToJS m (Ident . runProperName) ctor))
(JSBlock js)
Nothing]
where
@@ -305,7 +369,7 @@ binderToJs m e varName done (ConstructorBinder ctor bs) = do
argVar <- freshName
done'' <- go (index + 1) done' bs'
js <- binderToJs m e argVar done'' binder
- return (JSVariableIntroduction argVar (Just (JSIndexer (JSNumericLiteral (Left index)) (JSAccessor "values" (JSVar varName)))) : js)
+ return (JSVariableIntroduction argVar (Just (JSAccessor ("value" ++ show index) (JSVar varName))) : js)
binderToJs m e varName done (ObjectBinder bs) = go done bs
where
go :: (Functor m, Applicative m, Monad m) => [JS] -> [(String, Binder)] -> SupplyT m [JS]
@@ -341,17 +405,3 @@ binderToJs m e varName done (NamedBinder ident binder) = do
return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : js)
binderToJs m e varName done (PositionedBinder _ binder) =
binderToJs m e varName done binder
-
--- |
--- Checks whether a data constructor is the only constructor for that type, used to simplify the
--- check when generating code for binders.
---
-isOnlyConstructor :: Environment -> Qualified ProperName -> Bool
-isOnlyConstructor e ctor =
- let ty = fromMaybe (error "Data constructor not found") $ ctor `M.lookup` dataConstructors e
- in numConstructors (ctor, ty) == 1
- where
- numConstructors ty = length $ filter (((==) `on` typeConstructor) ty) $ M.toList $ dataConstructors e
- typeConstructor (Qualified (Just moduleName) _, (tyCtor, _)) = (moduleName, tyCtor)
- typeConstructor _ = error "Invalid argument to isOnlyConstructor"
-
diff --git a/src/Language/PureScript/CodeGen/JS/AST.hs b/src/Language/PureScript/CodeGen/JS/AST.hs
index 1aa800c..4666ab0 100644
--- a/src/Language/PureScript/CodeGen/JS/AST.hs
+++ b/src/Language/PureScript/CodeGen/JS/AST.hs
@@ -38,7 +38,11 @@ data UnaryOperator
-- |
-- Numeric unary \'plus\'
--
- | Positive deriving (Show, Eq, Data, Typeable)
+ | Positive
+ -- |
+ -- Constructor
+ --
+ | JSNew deriving (Show, Eq, Data, Typeable)
-- |
-- Built-in binary operators
@@ -218,6 +222,10 @@ data JS
--
| JSTypeOf JS
-- |
+ -- InstanceOf test
+ --
+ | JSInstanceOf JS JS
+ -- |
-- Labelled statement
--
| JSLabel String JS
@@ -262,6 +270,7 @@ everywhereOnJS f = go
go (JSThrow js) = f (JSThrow (go js))
go (JSTypeOf js) = f (JSTypeOf (go js))
go (JSLabel name js) = f (JSLabel name (go js))
+ go (JSInstanceOf j1 j2) = f (JSInstanceOf (go j1) (go j2))
go other = f other
everywhereOnJSTopDown :: (JS -> JS) -> JS -> JS
@@ -288,6 +297,7 @@ everywhereOnJSTopDown f = go . f
go (JSThrow j) = JSThrow (go (f j))
go (JSTypeOf j) = JSTypeOf (go (f j))
go (JSLabel name j) = JSLabel name (go (f j))
+ go (JSInstanceOf j1 j2) = JSInstanceOf (go (f j1)) (go (f j2))
go other = f other
everythingOnJS :: (r -> r -> r) -> (JS -> r) -> JS -> r
@@ -314,4 +324,5 @@ everythingOnJS (<>) f = go
go j@(JSThrow j1) = f j <> go j1
go j@(JSTypeOf j1) = f j <> go j1
go j@(JSLabel _ j1) = f j <> go j1
+ go j@(JSInstanceOf j1 j2) = f j <> go j1 <> go j2
go other = f other
diff --git a/src/Language/PureScript/Constants.hs b/src/Language/PureScript/Constants.hs
index 34c66a9..53879c6 100644
--- a/src/Language/PureScript/Constants.hs
+++ b/src/Language/PureScript/Constants.hs
@@ -23,6 +23,9 @@ module Language.PureScript.Constants where
(#) :: String
(#) = "#"
+(<>) :: String
+(<>) = "<>"
+
(++) :: String
(++) = "++"
@@ -105,6 +108,9 @@ not = "not"
return :: String
return = "return"
+pure' :: String
+pure' = "pure"
+
returnEscaped :: String
returnEscaped = "$return"
@@ -141,11 +147,20 @@ peekSTArray = "peekSTArray"
pokeSTArray :: String
pokeSTArray = "pokeSTArray"
+mkFn :: String
+mkFn = "mkFn"
+
+runFn :: String
+runFn = "runFn"
+
-- Type Class Dictionary Names
monadEffDictionary :: String
monadEffDictionary = "monadEff"
+applicativeEffDictionary :: String
+applicativeEffDictionary = "applicativeEff"
+
bindEffDictionary :: String
bindEffDictionary = "bindEff"
@@ -173,6 +188,9 @@ boolLikeBoolean = "boolLikeBoolean"
semigroupString :: String
semigroupString = "semigroupString"
+semigroupoidArr :: String
+semigroupoidArr = "semigroupoidArr"
+
-- Main module
main :: String
@@ -180,8 +198,8 @@ main = "main"
-- Code Generation
-__superclasses :: String
-__superclasses = "__superclasses"
+__superclass_ :: String
+__superclass_ = "__superclass_"
-- Modules
@@ -199,3 +217,6 @@ eff = "Control_Monad_Eff"
st :: String
st = "Control_Monad_ST"
+
+dataFunction :: String
+dataFunction = "Data_Function"
diff --git a/src/Language/PureScript/DeadCodeElimination.hs b/src/Language/PureScript/DeadCodeElimination.hs
index 3357125..ed891a5 100644
--- a/src/Language/PureScript/DeadCodeElimination.hs
+++ b/src/Language/PureScript/DeadCodeElimination.hs
@@ -39,7 +39,8 @@ eliminateDeadCode entryPoints ms = map go ms
entryPointVertices = mapMaybe (vertexFor . fst) . filter (\((mn, _), _) -> mn `elem` entryPoints) $ declarations
filterExport :: [Declaration] -> DeclarationRef -> Maybe DeclarationRef
- filterExport decls r@(TypeRef name _) | (any $ typeExists name) decls = Just r
+ filterExport decls r@(TypeRef name _) | (any $ typeOrClassExists name) decls = Just r
+ filterExport decls r@(TypeClassRef name) | (any $ typeOrClassExists name) decls = Just r
filterExport decls r@(ValueRef name) | (any $ valueExists name) decls = Just r
filterExport decls r@(TypeInstanceRef name) | (any $ valueExists name) decls = Just r
filterExport _ _ = Nothing
@@ -51,11 +52,12 @@ eliminateDeadCode entryPoints ms = map go ms
valueExists name (PositionedDeclaration _ d) = valueExists name d
valueExists _ _ = False
- typeExists :: ProperName -> Declaration -> Bool
- typeExists name (DataDeclaration name' _ _) = name == name'
- typeExists name (DataBindingGroupDeclaration decls) = any (typeExists name) decls
- typeExists name (PositionedDeclaration _ d) = typeExists name d
- typeExists _ _ = False
+ typeOrClassExists :: ProperName -> Declaration -> Bool
+ typeOrClassExists name (DataDeclaration _ name' _ _) = name == name'
+ typeOrClassExists name (TypeClassDeclaration name' _ _ _) = name == name'
+ typeOrClassExists name (DataBindingGroupDeclaration decls) = any (typeOrClassExists name) decls
+ typeOrClassExists name (PositionedDeclaration _ d) = typeOrClassExists name d
+ typeOrClassExists _ _ = False
type Key = (ModuleName, Either Ident ProperName)
@@ -64,10 +66,11 @@ declarationsByModule (Module moduleName ds _) = concatMap go ds
where
go :: Declaration -> [(Key, [Key])]
go d@(ValueDeclaration name _ _ _ _) = [((moduleName, Left name), dependencies moduleName d)]
- go (DataDeclaration _ _ dctors) = map (\(name, _) -> ((moduleName, Right name), [])) dctors
+ go (DataDeclaration _ _ _ dctors) = map (\(name, _) -> ((moduleName, Right name), [])) dctors
go (ExternDeclaration _ name _ _) = [((moduleName, Left name), [])]
go d@(BindingGroupDeclaration names') = map (\(name, _, _) -> ((moduleName, Left name), dependencies moduleName d)) names'
go (DataBindingGroupDeclaration ds') = concatMap go ds'
+ go (TypeClassDeclaration name _ _ _) = [((moduleName, Right name), [])]
go (PositionedDeclaration _ d) = go d
go _ = []
@@ -80,6 +83,8 @@ dependencies moduleName =
values (Var ident) = let (mn, name) = qualify moduleName ident in [(mn, Left name)]
values (Constructor (Qualified (Just mn) name)) = [(mn, Right name)]
values (Constructor (Qualified Nothing _)) = error "Found unqualified data constructor"
+ values (TypeClassDictionaryConstructorApp (Qualified (Just mn) name) _) = [(mn, Right name)]
+ values (TypeClassDictionaryConstructorApp (Qualified Nothing _) _) = error "Found unqualified class dictionary constructor"
values _ = []
isUsed :: ModuleName -> Graph -> (Key -> Maybe Vertex) -> [Vertex] -> Declaration -> Bool
@@ -89,7 +94,7 @@ isUsed moduleName graph vertexFor entryPointVertices (ValueDeclaration name _ _
isUsed moduleName graph vertexFor entryPointVertices (FixityDeclaration _ name) =
let Just v' = vertexFor (moduleName, Left $ Op name)
in any (\v -> path graph v v') entryPointVertices
-isUsed moduleName graph vertexFor entryPointVertices (DataDeclaration _ _ dctors) =
+isUsed moduleName graph vertexFor entryPointVertices (DataDeclaration _ _ _ dctors) =
any (\(pn, _) -> let Just v' = vertexFor (moduleName, Right pn)
in any (\v -> path graph v v') entryPointVertices) dctors
isUsed moduleName graph vertexFor entryPointVertices (ExternDeclaration _ name _ _) =
@@ -100,6 +105,9 @@ isUsed moduleName graph vertexFor entryPointVertices (BindingGroupDeclaration ds
in any (\v -> path graph v v') entryPointVertices) ds
isUsed moduleName graph vertexFor entryPointVertices (DataBindingGroupDeclaration ds) =
any (isUsed moduleName graph vertexFor entryPointVertices) ds
+isUsed moduleName graph vertexFor entryPointVertices (TypeClassDeclaration name _ _ _) =
+ let Just v' = vertexFor (moduleName, Right name)
+ in any (\v -> path graph v v') entryPointVertices
isUsed moduleName graph vertexFor entryPointVertices (PositionedDeclaration _ d) =
isUsed moduleName graph vertexFor entryPointVertices d
isUsed _ _ _ _ _ = True
diff --git a/src/Language/PureScript/Declarations.hs b/src/Language/PureScript/Declarations.hs
index 5e9d307..ef7e413 100644
--- a/src/Language/PureScript/Declarations.hs
+++ b/src/Language/PureScript/Declarations.hs
@@ -118,9 +118,9 @@ instance Eq DeclarationRef where
--
data Declaration
-- |
- -- A data type declaration (name, arguments, data constructors)
+ -- A data type declaration (data or newtype, name, arguments, data constructors)
--
- = DataDeclaration ProperName [String] [(ProperName, [Type])]
+ = DataDeclaration DataDeclType ProperName [String] [(ProperName, [Type])]
-- |
-- A minimal mutually recursive set of data type declarations
--
@@ -332,6 +332,11 @@ data Value
--
| Do [DoNotationElement]
-- |
+ -- An application of a typeclass dictionary constructor. The value should be
+ -- an ObjectLiteral.
+ --
+ | TypeClassDictionaryConstructorApp (Qualified ProperName) Value
+ -- |
-- A placeholder for a type class dictionary to be inserted later. At the end of type checking, these
-- placeholders will be replaced with actual expressions representing type classes dictionaries which
-- can be evaluated at runtime. The constructor arguments represent (in order): whether or not to look
@@ -483,6 +488,7 @@ everywhereOnValues f g h = (f', g', h')
g' (Parens v) = g (Parens (g' v))
g' (ArrayLiteral vs) = g (ArrayLiteral (map g' vs))
g' (ObjectLiteral vs) = g (ObjectLiteral (map (fmap g') vs))
+ g' (TypeClassDictionaryConstructorApp name v) = g (TypeClassDictionaryConstructorApp name (g' v))
g' (Accessor prop v) = g (Accessor prop (g' v))
g' (ObjectUpdate obj vs) = g (ObjectUpdate (g' obj) (map (fmap g') vs))
g' (Abs name v) = g (Abs name (g' v))
@@ -538,6 +544,7 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h)
g' (Parens v) = Parens <$> (g v >>= g')
g' (ArrayLiteral vs) = ArrayLiteral <$> mapM (g' <=< g) vs
g' (ObjectLiteral vs) = ObjectLiteral <$> mapM (sndM (g' <=< g)) vs
+ g' (TypeClassDictionaryConstructorApp name v) = TypeClassDictionaryConstructorApp name <$> (g v >>= g')
g' (Accessor prop v) = Accessor prop <$> (g v >>= g')
g' (ObjectUpdate obj vs) = ObjectUpdate <$> (g obj >>= g') <*> mapM (sndM (g' <=< g)) vs
g' (Abs name v) = Abs name <$> (g v >>= g')
@@ -587,6 +594,7 @@ everywhereOnValuesM f g h = (f' <=< f, g' <=< g, h' <=< h)
g' (Parens v) = (Parens <$> g' v) >>= g
g' (ArrayLiteral vs) = (ArrayLiteral <$> mapM g' vs) >>= g
g' (ObjectLiteral vs) = (ObjectLiteral <$> mapM (sndM g') vs) >>= g
+ g' (TypeClassDictionaryConstructorApp name v) = (TypeClassDictionaryConstructorApp name <$> g' v) >>= g
g' (Accessor prop v) = (Accessor prop <$> g' v) >>= g
g' (ObjectUpdate obj vs) = (ObjectUpdate <$> g' obj <*> mapM (sndM g') vs) >>= g
g' (Abs name v) = (Abs name <$> g' v) >>= g
@@ -639,6 +647,7 @@ everythingOnValues (<>) f g h i j = (f', g', h', i', j')
g' v@(Parens v1) = g v <> g' v1
g' v@(ArrayLiteral vs) = foldl (<>) (g v) (map g' vs)
g' v@(ObjectLiteral vs) = foldl (<>) (g v) (map (g' . snd) vs)
+ g' v@(TypeClassDictionaryConstructorApp _ v1) = g v <> g' v1
g' v@(Accessor _ v1) = g v <> g' v1
g' v@(ObjectUpdate obj vs) = foldl (<>) (g v <> g' obj) (map (g' . snd) vs)
g' v@(Abs _ v1) = g v <> g' v1
@@ -702,6 +711,7 @@ everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i'
g' s (Parens v1) = (g'' s) v1
g' s (ArrayLiteral vs) = foldl (<>) r0 (map (g'' s) vs)
g' s (ObjectLiteral vs) = foldl (<>) r0 (map (g'' s . snd) vs)
+ g' s (TypeClassDictionaryConstructorApp _ v1) = (g'' s) v1
g' s (Accessor _ v1) = (g'' s) v1
g' s (ObjectUpdate obj vs) = foldl (<>) ((g'' s) obj) (map (g'' s . snd) vs)
g' s (Abs _ v1) = (g'' s) v1
@@ -767,6 +777,7 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j
g' s (Parens v) = Parens <$> g'' s v
g' s (ArrayLiteral vs) = ArrayLiteral <$> mapM (g'' s) vs
g' s (ObjectLiteral vs) = ObjectLiteral <$> mapM (sndM (g'' s)) vs
+ g' s (TypeClassDictionaryConstructorApp name v) = TypeClassDictionaryConstructorApp name <$> (g'' s) v
g' s (Accessor prop v) = Accessor prop <$> g'' s v
g' s (ObjectUpdate obj vs) = ObjectUpdate <$> g'' s obj <*> mapM (sndM (g'' s)) vs
g' s (Abs name v) = Abs name <$> g'' s v
@@ -803,7 +814,7 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j
accumTypes :: (Monoid r) => (Type -> r) -> (Declaration -> r, Value -> r, Binder -> r, CaseAlternative -> r, DoNotationElement -> r)
accumTypes f = everythingOnValues mappend forDecls forValues (const mempty) (const mempty) (const mempty)
where
- forDecls (DataDeclaration _ _ dctors) = mconcat (concatMap (map f . snd) dctors)
+ forDecls (DataDeclaration _ _ _ dctors) = mconcat (concatMap (map f . snd) dctors)
forDecls (ExternDeclaration _ _ _ ty) = f ty
forDecls (ExternInstanceDeclaration _ cs _ tys) = mconcat (concatMap (map f . snd) cs) `mappend` mconcat (map f tys)
forDecls (TypeClassDeclaration _ _ implies _) = mconcat (concatMap (map f . snd) implies)
diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs
index a148869..6eef096 100644
--- a/src/Language/PureScript/Environment.hs
+++ b/src/Language/PureScript/Environment.hs
@@ -1,6 +1,6 @@
-----------------------------------------------------------------------------
--
--- Module : Language.PureScript.Prim
+-- Module : Language.PureScript.Environment
-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
-- License : MIT
--
@@ -33,7 +33,7 @@ data Environment = Environment {
-- |
-- Value names currently in scope
--
- names :: M.Map (ModuleName, Ident) (Type, NameKind)
+ names :: M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility)
-- |
-- Type names currently in scope
--
@@ -41,7 +41,7 @@ data Environment = Environment {
-- |
-- Data constructors currently in scope, along with their associated data type constructors
--
- , dataConstructors :: M.Map (Qualified ProperName) (ProperName, Type)
+ , dataConstructors :: M.Map (Qualified ProperName) (DataDeclType, ProperName, Type)
-- |
-- Type synonyms currently in scope
--
@@ -76,6 +76,19 @@ data ForeignImportType
| InlineJavascript deriving (Show, Eq, Data, Typeable)
-- |
+-- The visibility of a name in scope
+--
+data NameVisibility
+ -- |
+ -- The name is defined in the current binding group, but is not visible
+ --
+ = Undefined
+ -- |
+ -- The name is defined in the another binding group, or has been made visible by a function binder
+ --
+ | Defined deriving (Show, Eq)
+
+-- |
-- The kind of a name
--
data NameKind
@@ -126,6 +139,23 @@ data TypeKind
| LocalTypeVariable deriving (Show, Eq, Data, Typeable)
-- |
+-- The type ('data' or 'newtype') of a data type declaration
+--
+data DataDeclType
+ -- |
+ -- A standard data constructor
+ --
+ = Data
+ -- |
+ -- A newtype constructor
+ --
+ | Newtype deriving (Eq, Ord, Data, Typeable)
+
+instance Show DataDeclType where
+ show Data = "data"
+ show Newtype = "newtype"
+
+-- |
-- Construct a ProperName in the Prim module
--
primName :: String -> Qualified ProperName
diff --git a/src/Language/PureScript/Optimizer.hs b/src/Language/PureScript/Optimizer.hs
index d75c234..9ffc4b0 100644
--- a/src/Language/PureScript/Optimizer.hs
+++ b/src/Language/PureScript/Optimizer.hs
@@ -53,6 +53,7 @@ optimize :: Options -> JS -> JS
optimize opts | optionsNoOptimizations opts = id
| otherwise = untilFixedPoint (applyAll
[ collapseNestedBlocks
+ , collapseNestedIfs
, tco opts
, magicDo opts
, removeCodeAfterReturnStatements
diff --git a/src/Language/PureScript/Optimizer/Blocks.hs b/src/Language/PureScript/Optimizer/Blocks.hs
index 98d383c..ef95141 100644
--- a/src/Language/PureScript/Optimizer/Blocks.hs
+++ b/src/Language/PureScript/Optimizer/Blocks.hs
@@ -13,9 +13,10 @@
--
-----------------------------------------------------------------------------
-module Language.PureScript.Optimizer.Blocks (
- collapseNestedBlocks
-) where
+module Language.PureScript.Optimizer.Blocks
+ ( collapseNestedBlocks
+ , collapseNestedIfs
+ ) where
import Language.PureScript.CodeGen.JS.AST
@@ -31,3 +32,11 @@ collapseNestedBlocks = everywhereOnJS collapse
go :: JS -> [JS]
go (JSBlock sts) = sts
go s = [s]
+
+collapseNestedIfs :: JS -> JS
+collapseNestedIfs = everywhereOnJS collapse
+ where
+ collapse :: JS -> JS
+ collapse (JSIfElse cond1 (JSBlock [JSIfElse cond2 body Nothing]) Nothing) =
+ JSIfElse (JSBinary And cond1 cond2) body Nothing
+ collapse js = js
diff --git a/src/Language/PureScript/Optimizer/Inliner.hs b/src/Language/PureScript/Optimizer/Inliner.hs
index 0c3626e..bf39d2e 100644
--- a/src/Language/PureScript/Optimizer/Inliner.hs
+++ b/src/Language/PureScript/Optimizer/Inliner.hs
@@ -22,6 +22,8 @@ module Language.PureScript.Optimizer.Inliner (
evaluateIifes
) where
+import Data.Maybe (fromMaybe)
+
import Language.PureScript.CodeGen.JS.AST
import Language.PureScript.CodeGen.Common (identToJs)
import Language.PureScript.Optimizer.Common
@@ -47,6 +49,8 @@ etaConvert = everywhereOnJS convert
not (any (`isRebound` block) (map JSVar idents)) &&
not (any (`isRebound` block) args)
= JSBlock (map (replaceIdents (zip idents args)) body)
+ convert (JSFunction Nothing ["_"] (JSBlock [JSReturn (JSApp fn@JSVar{} [JSObjectLiteral []])]))
+ = fn
convert js = js
unThunk :: JS -> JS
@@ -88,7 +92,7 @@ inlineOperator (m, op) f = everywhereOnJS convert
isOp _ = False
inlineCommonOperators :: JS -> JS
-inlineCommonOperators = applyAll
+inlineCommonOperators = applyAll $
[ binary C.numNumber (C.+) Add
, binary C.numNumber (C.-) Subtract
, binary C.numNumber (C.*) Multiply
@@ -108,6 +112,7 @@ inlineCommonOperators = applyAll
, binary C.eqBoolean (C.==) EqualTo
, binary C.eqBoolean (C./=) NotEqualTo
+ , binary C.semigroupString (C.<>) Add
, binary C.semigroupString (C.++) Add
, binaryFunction C.bitsNumber C.shl ShiftLeft
@@ -121,7 +126,8 @@ inlineCommonOperators = applyAll
, binary C.boolLikeBoolean (C.&&) And
, binary C.boolLikeBoolean (C.||) Or
, unary C.boolLikeBoolean C.not Not
- ]
+ ] ++
+ [ fn | i <- [0..10], fn <- [ mkFn i, runFn i ] ]
where
binary :: String -> String -> BinaryOperator -> JS -> JS
binary dictName opString op = everywhereOnJS convert
@@ -150,3 +156,38 @@ inlineCommonOperators = applyAll
isOp _ = False
isOpDict dictName (JSApp (JSAccessor prop (JSVar prelude)) [JSObjectLiteral []]) = prelude == C.prelude && prop == dictName
isOpDict _ _ = False
+ mkFn :: Int -> JS -> JS
+ mkFn 0 = everywhereOnJS convert
+ where
+ convert :: JS -> JS
+ convert (JSApp mkFnN [JSFunction Nothing [_] (JSBlock js)]) | isNFn C.mkFn 0 mkFnN =
+ JSFunction Nothing [] (JSBlock js)
+ convert other = other
+ mkFn n = everywhereOnJS convert
+ where
+ convert :: JS -> JS
+ convert orig@(JSApp mkFnN [fn]) | isNFn C.mkFn n mkFnN =
+ case collectArgs n [] fn of
+ Just (args, js) -> JSFunction Nothing args (JSBlock js)
+ Nothing -> orig
+ convert other = other
+ collectArgs :: Int -> [String] -> JS -> Maybe ([String], [JS])
+ collectArgs 1 acc (JSFunction Nothing [oneArg] (JSBlock js)) | length acc == n - 1 = Just (reverse (oneArg : acc), js)
+ collectArgs m acc (JSFunction Nothing [oneArg] (JSBlock [JSReturn ret])) = collectArgs (m - 1) (oneArg : acc) ret
+ collectArgs _ _ _ = Nothing
+
+ isNFn :: String -> Int -> JS -> Bool
+ isNFn prefix n (JSVar name) = name == (prefix ++ show n)
+ isNFn prefix n (JSAccessor name (JSVar dataFunction)) | dataFunction == C.dataFunction = name == (prefix ++ show n)
+ isNFn _ _ _ = False
+
+ runFn :: Int -> JS -> JS
+ runFn n = everywhereOnJS convert
+ where
+ convert :: JS -> JS
+ convert js = fromMaybe js $ go n [] js
+
+ go :: Int -> [JS] -> JS -> Maybe JS
+ go 0 acc (JSApp runFnN [fn]) | isNFn C.runFn n runFnN && length acc == n = Just (JSApp fn acc)
+ go m acc (JSApp lhs [arg]) = go (m - 1) (arg : acc) lhs
+ go _ _ _ = Nothing
diff --git a/src/Language/PureScript/Optimizer/MagicDo.hs b/src/Language/PureScript/Optimizer/MagicDo.hs
index 9976ff6..e271de8 100644
--- a/src/Language/PureScript/Optimizer/MagicDo.hs
+++ b/src/Language/PureScript/Optimizer/MagicDo.hs
@@ -57,6 +57,8 @@ magicDo' = everywhereOnJS undo . everywhereOnJSTopDown convert
convert :: JS -> JS
-- Desugar return
convert (JSApp (JSApp ret [val]) []) | isReturn ret = val
+ -- Desugar pure
+ convert (JSApp (JSApp pure' [val]) []) | isPure pure' = val
-- Desugar >>
convert (JSApp (JSApp bind [m]) [JSFunction Nothing ["_"] (JSBlock js)]) | isBind bind && isJSReturn (last js) =
let JSReturn ret = last js in
@@ -78,6 +80,9 @@ magicDo' = everywhereOnJS undo . everywhereOnJSTopDown convert
-- Check if an expression represents a monomorphic call to return for the Eff monad
isReturn (JSApp retPoly [effDict]) | isRetPoly retPoly && isEffDict C.monadEffDictionary effDict = True
isReturn _ = False
+ -- Check if an expression represents a monomorphic call to pure for the Eff applicative
+ isPure (JSApp purePoly [effDict]) | isPurePoly purePoly && isEffDict C.applicativeEffDictionary effDict = True
+ isPure _ = False
-- Check if an expression represents the polymorphic >>= function
isBindPoly (JSAccessor prop (JSVar prelude)) = prelude == C.prelude && prop == identToJs (Op (C.>>=))
isBindPoly (JSIndexer (JSStringLiteral bind) (JSVar prelude)) = prelude == C.prelude && bind == (C.>>=)
@@ -86,6 +91,10 @@ magicDo' = everywhereOnJS undo . everywhereOnJSTopDown convert
isRetPoly (JSAccessor returnEscaped (JSVar prelude)) = prelude == C.prelude && returnEscaped == C.returnEscaped
isRetPoly (JSIndexer (JSStringLiteral return') (JSVar prelude)) = prelude == C.prelude && return' == C.return
isRetPoly _ = False
+ -- Check if an expression represents the polymorphic pure function
+ isPurePoly (JSAccessor pure' (JSVar prelude)) = prelude == C.prelude && pure' == C.pure'
+ isPurePoly (JSIndexer (JSStringLiteral pure') (JSVar prelude)) = prelude == C.prelude && pure' == C.pure'
+ isPurePoly _ = False
-- Check if an expression represents a function in the Ef module
isEffFunc name (JSAccessor name' (JSVar eff)) = eff == C.eff && name == name'
isEffFunc _ _ = False
diff --git a/src/Language/PureScript/Parser/Common.hs b/src/Language/PureScript/Parser/Common.hs
index 481ccc2..1789379 100644
--- a/src/Language/PureScript/Parser/Common.hs
+++ b/src/Language/PureScript/Parser/Common.hs
@@ -31,6 +31,7 @@ import Language.PureScript.Names
--
reservedPsNames :: [String]
reservedPsNames = [ "data"
+ , "newtype"
, "type"
, "foreign"
, "import"
diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs
index 47b9e18..26b7595 100644
--- a/src/Language/PureScript/Parser/Declarations.hs
+++ b/src/Language/PureScript/Parser/Declarations.hs
@@ -48,13 +48,13 @@ sourcePos = toSourcePos <$> P.getPosition
parseDataDeclaration :: P.Parsec String ParseState Declaration
parseDataDeclaration = do
- reserved "data"
+ dtype <- (reserved "data" *> return Data) <|> (reserved "newtype" *> return Newtype)
name <- indented *> properName
tyArgs <- many (indented *> identifier)
ctors <- P.option [] $ do
_ <- lexeme $ indented *> P.char '='
sepBy1 ((,) <$> properName <*> P.many (indented *> parseTypeAtom)) pipe
- return $ DataDeclaration name tyArgs ctors
+ return $ DataDeclaration dtype name tyArgs ctors
parseTypeDeclaration :: P.Parsec String ParseState Declaration
parseTypeDeclaration =
diff --git a/src/Language/PureScript/Parser/Types.hs b/src/Language/PureScript/Parser/Types.hs
index 76fab97..c5d2d21 100644
--- a/src/Language/PureScript/Parser/Types.hs
+++ b/src/Language/PureScript/Parser/Types.hs
@@ -30,15 +30,6 @@ import Language.PureScript.Environment
import qualified Text.Parsec as P
import qualified Text.Parsec.Expr as P
-parseNumber :: P.Parsec String ParseState Type
-parseNumber = const tyNumber <$> reserved "Number"
-
-parseString :: P.Parsec String ParseState Type
-parseString = const tyString <$> reserved "String"
-
-parseBoolean :: P.Parsec String ParseState Type
-parseBoolean = const tyBoolean <$> reserved "Boolean"
-
parseArray :: P.Parsec String ParseState Type
parseArray = squares $ return tyArray
@@ -69,10 +60,7 @@ parseForAll = mkForAll <$> (P.try (reserved "forall") *> P.many1 (indented *> id
--
parseTypeAtom :: P.Parsec String ParseState Type
parseTypeAtom = indented *> P.choice (map P.try
- [ parseNumber
- , parseString
- , parseBoolean
- , parseArray
+ [ parseArray
, parseArrayOf
, parseFunction
, parseObject
diff --git a/src/Language/PureScript/Pretty/JS.hs b/src/Language/PureScript/Pretty/JS.hs
index ebb42ed..7933302 100644
--- a/src/Language/PureScript/Pretty/JS.hs
+++ b/src/Language/PureScript/Pretty/JS.hs
@@ -18,7 +18,7 @@ module Language.PureScript.Pretty.JS (
) where
import Language.PureScript.Pretty.Common
-import Language.PureScript.CodeGen.JS (isIdent)
+import Language.PureScript.CodeGen.JS (identNeedsEscaping)
import Language.PureScript.CodeGen.JS.AST
import Data.List
@@ -56,8 +56,8 @@ literals = mkPattern' match
]
where
objectPropertyToString :: String -> String
- objectPropertyToString s | isIdent s = s
- | otherwise = show s
+ objectPropertyToString s | identNeedsEscaping s = show s
+ | otherwise = s
match (JSBlock sts) = fmap concat $ sequence
[ return "{\n"
, withIndent $ prettyStatements sts
@@ -174,6 +174,12 @@ typeOf = mkPattern match
match (JSTypeOf val) = Just ((), val)
match _ = Nothing
+instanceOf :: Pattern PrinterState JS (JS, JS)
+instanceOf = mkPattern match
+ where
+ match (JSInstanceOf val ty) = Just (val, ty)
+ match _ = Nothing
+
unary :: UnaryOperator -> String -> Operator PrinterState JS String
unary op str = Wrap match (++)
where
@@ -223,6 +229,7 @@ prettyPrintJS' = A.runKleisli $ runPattern matchValue
OperatorTable [ [ Wrap accessor $ \prop val -> val ++ "." ++ prop ]
, [ Wrap indexer $ \index val -> val ++ "[" ++ index ++ "]" ]
, [ Wrap app $ \args val -> val ++ "(" ++ args ++ ")" ]
+ , [ unary JSNew "new " ]
, [ Wrap lam $ \(name, args) ret -> "function "
++ fromMaybe "" name
++ "(" ++ intercalate ", " args ++ ") "
@@ -232,6 +239,7 @@ prettyPrintJS' = A.runKleisli $ runPattern matchValue
, [ binary GreaterThan ">" ]
, [ binary GreaterThanOrEqualTo ">=" ]
, [ Wrap typeOf $ \_ s -> "typeof " ++ s ]
+ , [ AssocR instanceOf $ \v1 v2 -> v1 ++ " instanceof " ++ v2 ]
, [ unary Not "!" ]
, [ unary BitwiseNot "~" ]
, [ unary Negate "-" ]
diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs
index ee0107d..9476053 100644
--- a/src/Language/PureScript/Pretty/Values.hs
+++ b/src/Language/PureScript/Pretty/Values.hs
@@ -51,6 +51,11 @@ literals = mkPattern' match
, currentIndent
, return "}"
]
+ match (TypeClassDictionaryConstructorApp className ps) = fmap concat $ sequence
+ [ return ((show className) ++ "(\n")
+ , match ps
+ , return ")"
+ ]
match (Constructor name) = return $ show name
match (Case values binders) = fmap concat $ sequence
[ return "case "
@@ -73,8 +78,8 @@ literals = mkPattern' match
, withIndent $ prettyPrintMany prettyPrintDoNotationElement els
, currentIndent
]
- match (TypeClassDictionary _ _ _) = return "<<dict>>"
- match (SuperClassDictionary _ _) = return "<<superclass dict>>"
+ match (TypeClassDictionary name _ _) = return $ "<<dict " ++ show name ++ ">>"
+ match (SuperClassDictionary name _) = return $ "<<superclass dict " ++ show name ++ ">>"
match (TypedValue _ val _) = prettyPrintValue' val
match (PositionedValue _ val) = prettyPrintValue' val
match _ = mzero
diff --git a/src/Language/PureScript/Renamer.hs b/src/Language/PureScript/Renamer.hs
new file mode 100644
index 0000000..259edef
--- /dev/null
+++ b/src/Language/PureScript/Renamer.hs
@@ -0,0 +1,206 @@
+-----------------------------------------------------------------------------
+--
+-- Module : Language.PureScript.Renamer
+-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
+-- License : MIT
+--
+-- Maintainer : Phil Freeman <paf31@cantab.net>
+-- Stability : experimental
+-- Portability :
+--
+-- |
+-- Renaming pass that prevents shadowing of local identifiers.
+--
+-----------------------------------------------------------------------------
+
+module Language.PureScript.Renamer (renameInModules) where
+
+import Control.Applicative
+import Control.Monad.State
+
+import Data.List (find)
+
+import qualified Data.Map as M
+import qualified Data.Set as S
+
+import Language.PureScript.Declarations
+import Language.PureScript.Environment
+import Language.PureScript.Names
+import Language.PureScript.Traversals
+
+-- |
+-- The state object used in this module
+--
+data RenameState = RenameState {
+ -- |
+ -- A map from names bound (in the input) to their names (in the output)
+ --
+ rsBoundNames :: M.Map Ident Ident
+ -- |
+ -- The set of names which have been used and are in scope in the output
+ --
+ , rsUsedNames :: S.Set Ident
+ }
+
+type Rename = State RenameState
+
+initState :: [Ident] -> RenameState
+initState scope = RenameState (M.fromList (zip scope scope)) (S.fromList scope)
+
+-- |
+-- Runs renaming starting with a list of idents for the initial scope.
+--
+runRename :: [Ident] -> Rename a -> a
+runRename scope = flip evalState (initState scope)
+
+-- |
+-- Creates a new renaming scope using the current as a basis. Used to backtrack
+-- when leaving an Abs.
+--
+newScope :: Rename a -> Rename a
+newScope x = do
+ scope <- get
+ a <- x
+ put scope
+ return a
+
+-- |
+-- Adds a new scope entry for an ident. If the ident is already present, a new
+-- unique name is generated and stored.
+--
+updateScope :: Ident -> Rename Ident
+updateScope name = do
+ scope <- get
+ let name' = case name `S.member` rsUsedNames scope of
+ True ->
+ let
+ newNames = [ Ident (runIdent name ++ "_" ++ show (i :: Int)) | i <- [1..] ]
+ Just newName = find (`S.notMember` rsUsedNames scope) newNames
+ in newName
+ False -> name
+ modify $ \s -> s { rsBoundNames = M.insert name name' (rsBoundNames s)
+ , rsUsedNames = S.insert name' (rsUsedNames s)
+ }
+ return name'
+
+-- |
+-- Finds the new name to use for an ident.
+--
+lookupIdent :: Ident -> Rename Ident
+lookupIdent name = do
+ name' <- gets $ M.lookup name . rsBoundNames
+ case name' of
+ Just name'' -> return name''
+ Nothing -> error $ "Rename scope is missing ident '" ++ show name ++ "'"
+
+-- |
+-- Finds idents introduced by declarations.
+--
+findDeclIdents :: [Declaration] -> [Ident]
+findDeclIdents = concatMap go
+ where
+ go (ValueDeclaration ident _ _ _ _) = [ident]
+ go (BindingGroupDeclaration ds) = map (\(name, _, _) -> name) ds
+ go (ExternDeclaration _ ident _ _) = [ident]
+ go (TypeClassDeclaration _ _ _ ds) = findDeclIdents ds
+ go (PositionedDeclaration _ d) = go d
+ go _ = []
+
+-- |
+-- Renames within each declaration in a module.
+--
+renameInModules :: [Module] -> [Module]
+renameInModules = map go
+ where
+ go :: Module -> Module
+ go (Module mn decls exps) = Module mn (renameInDecl' (findDeclIdents decls) `map` decls) exps
+ renameInDecl' :: [Ident] -> Declaration -> Declaration
+ renameInDecl' scope = runRename scope . renameInDecl True
+
+-- |
+-- Renames within a declaration. isTopLevel is used to determine whether the
+-- declaration is a module member or appearing within a Let. At the top level
+-- declarations are not renamed or added to the scope (they should already have
+-- been added), whereas in a Let declarations are renamed if their name shadows
+-- another in the current scope.
+--
+renameInDecl :: Bool -> Declaration -> Rename Declaration
+renameInDecl isTopLevel (ValueDeclaration name nameKind [] Nothing val) = do
+ name' <- if isTopLevel then return name else updateScope name
+ ValueDeclaration name' nameKind [] Nothing <$> renameInValue val
+renameInDecl isTopLevel (BindingGroupDeclaration ds) = do
+ ds' <- mapM updateNames ds
+ BindingGroupDeclaration <$> mapM updateValues ds'
+ where
+ updateNames :: (Ident, NameKind, Value) -> Rename (Ident, NameKind, Value)
+ updateNames (name, nameKind, val) = do
+ name' <- if isTopLevel then return name else updateScope name
+ return (name', nameKind, val)
+ updateValues :: (Ident, NameKind, Value) -> Rename (Ident, NameKind, Value)
+ updateValues (name, nameKind, val) =
+ (,,) name nameKind <$> renameInValue val
+renameInDecl _ (TypeInstanceDeclaration name cs className args ds) =
+ TypeInstanceDeclaration name cs className args <$> mapM (renameInDecl True) ds
+renameInDecl isTopLevel (PositionedDeclaration pos d) =
+ PositionedDeclaration pos <$> renameInDecl isTopLevel d
+renameInDecl _ other = return other
+
+-- |
+-- Renames within a value.
+--
+renameInValue :: Value -> Rename Value
+renameInValue (UnaryMinus v) =
+ UnaryMinus <$> renameInValue v
+renameInValue (ArrayLiteral vs) =
+ ArrayLiteral <$> mapM renameInValue vs
+renameInValue (ObjectLiteral vs) =
+ ObjectLiteral <$> mapM (\(name, v) -> (,) name <$> renameInValue v) vs
+renameInValue (Accessor prop v) =
+ Accessor prop <$> renameInValue v
+renameInValue (ObjectUpdate obj vs) =
+ ObjectUpdate <$> renameInValue obj <*> mapM (\(name, v) -> (,) name <$> renameInValue v) vs
+renameInValue (Abs (Left name) v) =
+ newScope $ Abs . Left <$> updateScope name <*> renameInValue v
+renameInValue (App v1 v2) =
+ App <$> renameInValue v1 <*> renameInValue v2
+renameInValue (Var (Qualified Nothing name)) =
+ Var . Qualified Nothing <$> lookupIdent name
+renameInValue (IfThenElse v1 v2 v3) =
+ IfThenElse <$> renameInValue v1 <*> renameInValue v2 <*> renameInValue v3
+renameInValue (Case vs alts) =
+ newScope $ Case <$> mapM renameInValue vs <*> mapM renameInCaseAlternative alts
+renameInValue (TypedValue check v ty) =
+ TypedValue check <$> renameInValue v <*> pure ty
+renameInValue (Let ds v) =
+ newScope $ Let <$> mapM (renameInDecl False) ds <*> renameInValue v
+renameInValue (TypeClassDictionaryConstructorApp name v) =
+ TypeClassDictionaryConstructorApp name <$> renameInValue v
+renameInValue (PositionedValue pos v) =
+ PositionedValue pos <$> renameInValue v
+renameInValue v = return v
+
+-- |
+-- Renames within case alternatives.
+--
+renameInCaseAlternative :: CaseAlternative -> Rename CaseAlternative
+renameInCaseAlternative (CaseAlternative bs g v) =
+ CaseAlternative <$> mapM renameInBinder bs <*> maybeM renameInValue g <*> renameInValue v
+
+-- |
+-- Renames within binders.
+--
+renameInBinder :: Binder -> Rename Binder
+renameInBinder (VarBinder name) =
+ VarBinder <$> updateScope name
+renameInBinder (ConstructorBinder name bs) =
+ ConstructorBinder name <$> mapM renameInBinder bs
+renameInBinder (ObjectBinder bs) =
+ ObjectBinder <$> mapM (sndM renameInBinder) bs
+renameInBinder (ArrayBinder bs) =
+ ArrayBinder <$> mapM renameInBinder bs
+renameInBinder (ConsBinder b1 b2) =
+ ConsBinder <$> renameInBinder b1 <*> renameInBinder b2
+renameInBinder (NamedBinder name b) =
+ NamedBinder <$> updateScope name <*> renameInBinder b
+renameInBinder (PositionedBinder _ b) = renameInBinder b
+renameInBinder other = return other
diff --git a/src/Language/PureScript/Sugar/BindingGroups.hs b/src/Language/PureScript/Sugar/BindingGroups.hs
index e4c587b..180ef7f 100644
--- a/src/Language/PureScript/Sugar/BindingGroups.hs
+++ b/src/Language/PureScript/Sugar/BindingGroups.hs
@@ -118,7 +118,7 @@ getIdent (PositionedDeclaration _ d) = getIdent d
getIdent _ = error "Expected ValueDeclaration"
getProperName :: Declaration -> ProperName
-getProperName (DataDeclaration pn _ _) = pn
+getProperName (DataDeclaration _ pn _ _) = pn
getProperName (TypeSynonymDeclaration pn _ _) = pn
getProperName (PositionedDeclaration _ d) = getProperName d
getProperName _ = error "Expected DataDeclaration"
diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs
index 7af9be4..205c57a 100644
--- a/src/Language/PureScript/Sugar/Names.hs
+++ b/src/Language/PureScript/Sugar/Names.hs
@@ -31,6 +31,8 @@ import Language.PureScript.Environment
import Language.PureScript.Errors
import Language.PureScript.Traversals
+import qualified Language.PureScript.Constants as C
+
-- |
-- The global export environment - every declaration exported from every module.
--
@@ -180,8 +182,8 @@ renameInModule imports exports (Module mn decls exps) =
updateDecl :: (Maybe SourcePos, [Ident]) -> Declaration -> Either ErrorStack ((Maybe SourcePos, [Ident]), Declaration)
updateDecl (_, bound) d@(PositionedDeclaration pos _) = return ((Just pos, bound), d)
- updateDecl (pos, bound) (DataDeclaration name args dctors) =
- (,) (pos, bound) <$> (DataDeclaration name args <$> mapM (sndM (mapM (updateTypesEverywhere pos))) dctors)
+ updateDecl (pos, bound) (DataDeclaration dtype name args dctors) =
+ (,) (pos, bound) <$> (DataDeclaration dtype name args <$> mapM (sndM (mapM (updateTypesEverywhere pos))) dctors)
updateDecl (pos, bound) (TypeSynonymDeclaration name ps ty) =
(,) (pos, bound) <$> (TypeSynonymDeclaration name ps <$> updateTypesEverywhere pos ty)
updateDecl (pos, bound) (TypeClassDeclaration className args implies ds) =
@@ -272,7 +274,7 @@ renameInModule imports exports (Module mn decls exps) =
-- Finds all exported declarations in a set of modules.
--
findExports :: [Module] -> Either ErrorStack ExportEnvironment
-findExports = foldM addModule $ M.singleton (ModuleName [ProperName "Prim"]) primExports
+findExports = foldM addModule $ M.singleton (ModuleName [ProperName C.prim]) primExports
where
-- The exported types from the Prim module
@@ -295,7 +297,7 @@ findExports = foldM addModule $ M.singleton (ModuleName [ProperName "Prim"]) pri
go env'' (TypeDeclaration name _) = addValue env'' mn name
go env'' (PositionedDeclaration pos d) = rethrowWithPosition pos $ go env'' d
go _ _ = error "Invalid declaration in TypeClassDeclaration"
- addDecl mn env (DataDeclaration tn _ dcs) = addType env mn tn (map fst dcs)
+ addDecl mn env (DataDeclaration _ tn _ dcs) = addType env mn tn (map fst dcs)
addDecl mn env (TypeSynonymDeclaration tn _ _) = addType env mn tn []
addDecl mn env (ExternDataDeclaration tn _) = addType env mn tn []
addDecl mn env (ValueDeclaration name _ _ _ _) = addValue env mn name
diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs
index 349f32e..b34425d 100644
--- a/src/Language/PureScript/Sugar/TypeClasses.hs
+++ b/src/Language/PureScript/Sugar/TypeClasses.hs
@@ -33,9 +33,9 @@ import Control.Applicative
import Control.Monad.Error
import Control.Monad.State
import Control.Arrow (first, second)
-import Data.List ((\\))
+import Data.List ((\\), find)
import Data.Monoid ((<>))
-import Data.Maybe (catMaybes, mapMaybe)
+import Data.Maybe (catMaybes, mapMaybe, isJust)
import qualified Data.Map as M
@@ -52,7 +52,7 @@ desugarTypeClasses = flip evalStateT M.empty . mapM desugarModule
desugarModule :: Module -> Desugar Module
desugarModule (Module name decls (Just exps)) = do
- (newExpss, declss) <- unzip <$> mapM (desugarDecl name) decls
+ (newExpss, declss) <- unzip <$> mapM (desugarDecl name exps) decls
return $ Module name (concat declss) $ Just (exps ++ catMaybes newExpss)
desugarModule _ = error "Exports should have been elaborated in name desugaring"
@@ -82,63 +82,120 @@ desugarModule _ = error "Exports should have been elaborated in name desugaring"
-- instance subString :: Sub String where
-- sub = ""
--
--- becomes
+-- becomes:
+--
+-- <TypeClassDeclaration Foo ...>
--
-- type Foo a = { foo :: a -> a }
--
--- foreign import foo "function foo(dict) {\
--- \ return dict.foo;\
--- \}" :: forall a. (Foo a) => a -> a
+-- -- this following type is marked as not needing to be checked so a new Abs
+-- -- is not introduced around the definition in type checking, but when
+-- -- called the dictionary value is still passed in for the `dict` argument
+-- foo :: forall a. (Foo a) => a -> a
+-- foo dict = dict.foo
--
-- fooString :: {} -> Foo String
--- fooString _ = { foo: \s -> s ++ s }
+-- fooString _ = <TypeClassDictionaryConstructorApp Foo { foo: \s -> s ++ s }>
--
-- fooArray :: forall a. (Foo a) => Foo [a]
--- fooArray = { foo: map foo }
+-- fooArray = <TypeClassDictionaryConstructorApp Foo { foo: map foo }>
--
-- {- Superclasses -}
--
--- ...
+-- <TypeClassDeclaration Sub ...>
+--
+-- type Sub a = { sub :: a
+-- , "__superclass_Foo_0" :: {} -> Foo a
+-- }
+--
+-- -- As with `foo` above, this type is unchecked at the declaration
+-- sub :: forall a. (Sub a) => a
+-- sub dict = dict.sub
+--
+-- subString :: {} -> Sub String
+-- subString _ = { sub: "",
+-- , "__superclass_Foo_0": \_ -> <SuperClassDictionary Foo String>
+-- }
+--
+-- and finally as the generated javascript:
+--
+-- function Foo(foo) {
+-- this.foo = foo;
+-- };
+--
+-- var foo = function (dict) {
+-- return dict.foo;
+-- };
--
--- subString :: {} -> { __superclasses :: { "Foo": {} -> Foo String }, sub :: String }
--- subString _ = {
--- __superclasses: {
--- "Foo": \_ -> <dictionary placeholder to be inserted during type checking\>
--- }
--- sub: ""
--- }
+-- var fooString = function (_) {
+-- return new Foo(function (s) {
+-- return s + s;
+-- });
+-- };
+--
+-- var fooArray = function (__dict_Foo_15) {
+-- return new Foo(map(foo(__dict_Foo_15)));
+-- };
+--
+-- function Sub(__superclass_Foo_0, sub) {
+-- this["__superclass_Foo_0"] = __superclass_Foo_0;
+-- this.sub = sub;
+-- };
+--
+-- var sub = function (dict) {
+-- return dict.sub;
+-- };
+--
+-- var subString = function (_) {
+-- return new Sub(fooString, "");
+-- };
-}
-desugarDecl :: ModuleName -> Declaration -> Desugar (Maybe DeclarationRef, [Declaration])
-desugarDecl mn d@(TypeClassDeclaration name args implies members) = do
+desugarDecl :: ModuleName -> [DeclarationRef] -> Declaration -> Desugar (Maybe DeclarationRef, [Declaration])
+desugarDecl mn _ d@(TypeClassDeclaration name args implies members) = do
modify (M.insert (mn, name) d)
return $ (Nothing, d : typeClassDictionaryDeclaration name args implies members : map (typeClassMemberToDictionaryAccessor mn name args) members)
-desugarDecl mn d@(TypeInstanceDeclaration name deps className ty members) = do
+desugarDecl mn exps d@(TypeInstanceDeclaration name deps className tys members) = do
desugared <- lift $ desugarCases members
- dictDecl <- typeInstanceDictionaryDeclaration name mn deps className ty desugared
- return $ (Just $ TypeInstanceRef name, [d, dictDecl])
-desugarDecl mn (PositionedDeclaration pos d) = do
- (dr, ds) <- rethrowWithPosition pos $ desugarDecl mn d
+ dictDecl <- typeInstanceDictionaryDeclaration name mn deps className tys desugared
+ let expRef = if isExportedClass className && all isExportedType (getConstructors `concatMap` tys)
+ then Just $ TypeInstanceRef name
+ else Nothing
+ return $ (expRef, [d, dictDecl])
+ where
+ isExportedClass :: Qualified ProperName -> Bool
+ isExportedClass = isExported (elem . TypeClassRef)
+ isExportedType :: Qualified ProperName -> Bool
+ isExportedType = isExported $ \pn -> isJust . find (matchesTypeRef pn)
+ isExported :: (ProperName -> [DeclarationRef] -> Bool) -> Qualified ProperName -> Bool
+ isExported test (Qualified (Just mn') pn) = mn /= mn' || test pn exps
+ isExported _ _ = error "Names should have been qualified in name desugaring"
+ matchesTypeRef :: ProperName -> DeclarationRef -> Bool
+ matchesTypeRef pn (TypeRef pn' _) = pn == pn'
+ matchesTypeRef _ _ = False
+ getConstructors :: Type -> [Qualified ProperName]
+ getConstructors = everythingOnTypes (++) getConstructor
+ getConstructor :: Type -> [Qualified ProperName]
+ getConstructor (TypeConstructor tcname) = [tcname]
+ getConstructor _ = []
+desugarDecl mn exps (PositionedDeclaration pos d) = do
+ (dr, ds) <- rethrowWithPosition pos $ desugarDecl mn exps d
return (dr, map (PositionedDeclaration pos) ds)
-desugarDecl _ other = return (Nothing, [other])
+desugarDecl _ _ other = return (Nothing, [other])
memberToNameAndType :: Declaration -> (Ident, Type)
memberToNameAndType (TypeDeclaration ident ty) = (ident, ty)
memberToNameAndType (PositionedDeclaration _ d) = memberToNameAndType d
memberToNameAndType _ = error "Invalid declaration in type class definition"
-identToProperty :: Ident -> String
-identToProperty (Ident name) = name
-identToProperty (Op op) = op
-
typeClassDictionaryDeclaration :: ProperName -> [String] -> [(Qualified ProperName, [Type])] -> [Declaration] -> Declaration
typeClassDictionaryDeclaration name args implies members =
- let superclassesType = TypeApp tyObject (rowFromList ([ (fieldName, function unit tySynApp)
- | (index, (superclass, tyArgs)) <- zip [0..] implies
- , let tySynApp = foldl TypeApp (TypeConstructor superclass) tyArgs
- , let fieldName = mkSuperclassDictionaryName superclass index
- ], REmpty))
- members' = map (first identToProperty . memberToNameAndType) members
- mtys = if null implies then members' else (C.__superclasses, superclassesType) : members'
+ let superclassTypes = [ (fieldName, function unit tySynApp)
+ | (index, (superclass, tyArgs)) <- zip [0..] implies
+ , let tySynApp = foldl TypeApp (TypeConstructor superclass) tyArgs
+ , let fieldName = mkSuperclassDictionaryName superclass index
+ ]
+ members' = map (first runIdent . memberToNameAndType) members
+ mtys = members' ++ superclassTypes
in TypeSynonymDeclaration name args (TypeApp tyObject $ rowFromList (mtys, REmpty))
typeClassMemberToDictionaryAccessor :: ModuleName -> ProperName -> [String] -> Declaration -> Declaration
@@ -151,7 +208,7 @@ typeClassMemberToDictionaryAccessor mn name args (PositionedDeclaration pos d) =
typeClassMemberToDictionaryAccessor _ _ _ _ = error "Invalid declaration in type class definition"
mkSuperclassDictionaryName :: Qualified ProperName -> Integer -> String
-mkSuperclassDictionaryName pn index = show pn ++ "_" ++ show index
+mkSuperclassDictionaryName pn index = C.__superclass_ ++ show pn ++ "_" ++ show index
unit :: Type
unit = TypeApp tyObject REmpty
@@ -175,25 +232,26 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls =
-- Replace the type arguments with the appropriate types in the member types
let memberTypes = map (second (replaceAllTypeVars (zip args tys))) instanceTys
-- Create values for the type instance members
- memberNames <- map (first identToProperty) <$> mapM (memberToNameAndValue memberTypes) decls
+ memberNames <- map (first runIdent) <$> mapM (memberToNameAndValue memberTypes) decls
-- Create the type of the dictionary
-- The type is an object type, but depending on type instance dependencies, may be constrained.
-- The dictionary itself is an object literal, but for reasons related to recursion, the dictionary
-- must be guarded by at least one function abstraction. For that reason, if the dictionary has no
-- dependencies, we introduce an unnamed function parameter.
- let superclasses = ObjectLiteral
+ let superclasses =
[ (fieldName, Abs (Left (Ident "_")) (SuperClassDictionary superclass tyArgs))
| (index, (superclass, suTyArgs)) <- zip [0..] implies
, let tyArgs = map (replaceAllTypeVars (zip args tys)) suTyArgs
, let fieldName = mkSuperclassDictionaryName superclass index
]
- let memberNames' = if null implies then memberNames else (C.__superclasses, superclasses) : memberNames
+ let memberNames' = ObjectLiteral (memberNames ++ superclasses)
dictTy = foldl TypeApp (TypeConstructor className) tys
constrainedTy = quantify (if null deps then function unit dictTy else ConstrainedType deps dictTy)
- dict = if null deps then Abs (Left (Ident "_")) (ObjectLiteral memberNames') else ObjectLiteral memberNames'
-
- return $ ValueDeclaration name TypeInstanceDictionaryValue [] Nothing (TypedValue True dict constrainedTy)
+ dict = TypeClassDictionaryConstructorApp className memberNames'
+ dict' = if null deps then Abs (Left (Ident "_")) dict else dict
+ result = ValueDeclaration name TypeInstanceDictionaryValue [] Nothing (TypedValue True dict' constrainedTy)
+ return result
where
diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs
index 63acafe..5aacf86 100644
--- a/src/Language/PureScript/TypeChecker.hs
+++ b/src/Language/PureScript/TypeChecker.hs
@@ -39,21 +39,21 @@ import Language.PureScript.TypeClassDictionaries
import Language.PureScript.Environment
import Language.PureScript.Errors
-addDataType :: ModuleName -> ProperName -> [String] -> [(ProperName, [Type])] -> Kind -> Check ()
-addDataType moduleName name args dctors ctorKind = do
+addDataType :: ModuleName -> DataDeclType -> ProperName -> [String] -> [(ProperName, [Type])] -> Kind -> Check ()
+addDataType moduleName dtype name args dctors ctorKind = do
env <- getEnv
putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (ctorKind, DataType args dctors) (types env) }
forM_ dctors $ \(dctor, tys) ->
rethrow (strMsg ("Error in data constructor " ++ show dctor) <>) $
- addDataConstructor moduleName name args dctor tys
+ addDataConstructor moduleName dtype name args dctor tys
-addDataConstructor :: ModuleName -> ProperName -> [String] -> ProperName -> [Type] -> Check ()
-addDataConstructor moduleName name args dctor tys = do
+addDataConstructor :: ModuleName -> DataDeclType -> ProperName -> [String] -> ProperName -> [Type] -> Check ()
+addDataConstructor moduleName dtype name args dctor tys = do
env <- getEnv
let retTy = foldl TypeApp (TypeConstructor (Qualified (Just moduleName) name)) (map TypeVar args)
let dctorTy = foldr function retTy tys
let polyType = mkForAll args dctorTy
- putEnv $ env { dataConstructors = M.insert (Qualified (Just moduleName) dctor) (name, polyType) (dataConstructors env) }
+ putEnv $ env { dataConstructors = M.insert (Qualified (Just moduleName) dctor) (dtype, name, polyType) (dataConstructors env) }
addTypeSynonym :: ModuleName -> ProperName -> [String] -> Type -> Kind -> Check ()
addTypeSynonym moduleName name args ty kind = do
@@ -71,7 +71,7 @@ valueIsNotDefined moduleName name = do
addValue :: ModuleName -> Ident -> Type -> NameKind -> Check ()
addValue moduleName name ty nameKind = do
env <- getEnv
- putEnv (env { names = M.insert (moduleName, name) (ty, nameKind) (names env) })
+ putEnv (env { names = M.insert (moduleName, name) (ty, nameKind, Defined) (names env) })
addTypeClass :: ModuleName -> ProperName -> [String] -> [(Qualified ProperName, [Type])] -> [Declaration] -> Check ()
addTypeClass moduleName pn args implies ds =
@@ -111,19 +111,25 @@ checkTypeClassInstance _ ty = throwError $ mkErrorStack "Type class instance hea
--
typeCheckAll :: Maybe ModuleName -> ModuleName -> [Declaration] -> Check [Declaration]
typeCheckAll _ _ [] = return []
-typeCheckAll mainModuleName moduleName (d@(DataDeclaration name args dctors) : rest) = do
+typeCheckAll mainModuleName moduleName (d@(DataDeclaration dtype name args dctors) : rest) = do
rethrow (strMsg ("Error in type constructor " ++ show name) <>) $ do
+ when (dtype == Newtype) $ checkNewtype dctors
ctorKind <- kindsOf True moduleName name args (concatMap snd dctors)
- addDataType moduleName name args dctors ctorKind
+ addDataType moduleName dtype name args dctors ctorKind
ds <- typeCheckAll mainModuleName moduleName rest
return $ d : ds
+ where
+ checkNewtype :: [(ProperName, [Type])] -> Check ()
+ checkNewtype [(_, [_])] = return ()
+ checkNewtype [(_, _)] = throwError . strMsg $ "newtypes constructors must have a single argument"
+ checkNewtype _ = throwError . strMsg $ "newtypes must have a single constructor"
typeCheckAll mainModuleName moduleName (d@(DataBindingGroupDeclaration tys) : rest) = do
rethrow (strMsg "Error in data binding group" <>) $ do
let syns = mapMaybe toTypeSynonym tys
let dataDecls = mapMaybe toDataDecl tys
- (syn_ks, data_ks) <- kindsOfAll moduleName syns (map (\(name, args, dctors) -> (name, args, concatMap snd dctors)) dataDecls)
- forM_ (zip dataDecls data_ks) $ \((name, args, dctors), ctorKind) ->
- addDataType moduleName name args dctors ctorKind
+ (syn_ks, data_ks) <- kindsOfAll moduleName syns (map (\(_, name, args, dctors) -> (name, args, concatMap snd dctors)) dataDecls)
+ forM_ (zip dataDecls data_ks) $ \((dtype, name, args, dctors), ctorKind) ->
+ addDataType moduleName dtype name args dctors ctorKind
forM_ (zip syns syn_ks) $ \((name, args, ty), kind) ->
addTypeSynonym moduleName name args ty kind
ds <- typeCheckAll mainModuleName moduleName rest
@@ -132,7 +138,7 @@ typeCheckAll mainModuleName moduleName (d@(DataBindingGroupDeclaration tys) : re
toTypeSynonym (TypeSynonymDeclaration nm args ty) = Just (nm, args, ty)
toTypeSynonym (PositionedDeclaration _ d') = toTypeSynonym d'
toTypeSynonym _ = Nothing
- toDataDecl (DataDeclaration nm args dctors) = Just (nm, args, dctors)
+ toDataDecl (DataDeclaration dtype nm args dctors) = Just (dtype, nm, args, dctors)
toDataDecl (PositionedDeclaration _ d') = toDataDecl d'
toDataDecl _ = Nothing
typeCheckAll mainModuleName moduleName (d@(TypeSynonymDeclaration name args ty) : rest) = do
@@ -174,7 +180,7 @@ typeCheckAll mainModuleName moduleName (d@(ExternDeclaration importTy name _ ty)
guardWith (strMsg "Expected kind *") $ kind == Star
case M.lookup (moduleName, name) (names env) of
Just _ -> throwError . strMsg $ show name ++ " is already defined"
- Nothing -> putEnv (env { names = M.insert (moduleName, name) (ty, Extern importTy) (names env) })
+ Nothing -> putEnv (env { names = M.insert (moduleName, name) (ty, Extern importTy, Defined) (names env) })
ds <- typeCheckAll mainModuleName moduleName rest
return $ d : ds
typeCheckAll mainModuleName moduleName (d@(FixityDeclaration _ name) : rest) = do
diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs
index 43b80d4..8c8731d 100644
--- a/src/Language/PureScript/TypeChecker/Monad.hs
+++ b/src/Language/PureScript/TypeChecker/Monad.hs
@@ -39,7 +39,7 @@ import qualified Data.Map as M
-- |
-- Temporarily bind a collection of names to values
--
-bindNames :: (MonadState CheckState m) => M.Map (ModuleName, Ident) (Type, NameKind) -> m a -> m a
+bindNames :: (MonadState CheckState m) => M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility) -> m a -> m a
bindNames newNames action = do
orig <- get
modify $ \st -> st { checkEnv = (checkEnv st) { names = newNames `M.union` (names . checkEnv $ st) } }
@@ -79,9 +79,9 @@ getTypeClassDictionaries = M.elems . typeClassDictionaries . checkEnv <$> get
-- |
-- Temporarily bind a collection of names to local variables
--
-bindLocalVariables :: (Functor m, MonadState CheckState m) => ModuleName -> [(Ident, Type)] -> m a -> m a
+bindLocalVariables :: (Functor m, MonadState CheckState m) => ModuleName -> [(Ident, Type, NameVisibility)] -> m a -> m a
bindLocalVariables moduleName bindings =
- bindNames (M.fromList $ flip map bindings $ \(name, ty) -> ((moduleName, name), (ty, LocalVariable)))
+ bindNames (M.fromList $ flip map bindings $ \(name, ty, visibility) -> ((moduleName, name), (ty, LocalVariable, visibility)))
-- |
-- Temporarily bind a collection of names to local type variables
@@ -91,6 +91,17 @@ bindLocalTypeVariables moduleName bindings =
bindTypes (M.fromList $ flip map bindings $ \(pn, kind) -> (Qualified (Just moduleName) pn, (kind, LocalTypeVariable)))
-- |
+-- Update the visibility of all names to Defined
+--
+makeBindingGroupVisible :: (Functor m, MonadState CheckState m) => m a -> m a
+makeBindingGroupVisible action = do
+ orig <- get
+ modify $ \st -> st { checkEnv = (checkEnv st) { names = M.map (\(ty, nk, _) -> (ty, nk, Defined)) (names . checkEnv $ st) } }
+ a <- action
+ modify $ \st -> st { checkEnv = (checkEnv st) { names = names . checkEnv $ orig } }
+ return a
+
+-- |
-- Lookup the type of a value by name in the @Environment@
--
lookupVariable :: (Error e, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified Ident -> m Type
@@ -98,7 +109,27 @@ lookupVariable currentModule (Qualified moduleName var) = do
env <- getEnv
case M.lookup (fromMaybe currentModule moduleName, var) (names env) of
Nothing -> throwError . strMsg $ show var ++ " is undefined"
- Just (ty, _) -> return ty
+ Just (ty, _, _) -> return ty
+
+-- |
+-- Lookup the visibility of a value by name in the @Environment@
+--
+getVisibility :: (Error e, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified Ident -> m NameVisibility
+getVisibility currentModule (Qualified moduleName var) = do
+ env <- getEnv
+ case M.lookup (fromMaybe currentModule moduleName, var) (names env) of
+ Nothing -> throwError . strMsg $ show var ++ " is undefined"
+ Just (_, _, vis) -> return vis
+
+-- |
+-- Assert that a name is visible
+--
+checkVisibility :: (Error e, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified Ident -> m ()
+checkVisibility currentModule name@(Qualified _ var) = do
+ vis <- getVisibility currentModule name
+ case vis of
+ Undefined -> throwError . strMsg $ show var ++ " may not be defined in the current scope."
+ _ -> return ()
-- |
-- Lookup the kind of a type by name in the @Environment@
diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
index 3b9f266..78a4d0b 100644
--- a/src/Language/PureScript/TypeChecker/Types.hs
+++ b/src/Language/PureScript/TypeChecker/Types.hs
@@ -194,7 +194,7 @@ typesOf mainModuleName moduleName vals = do
-- Apply the substitution that was returned from runUnify to both types and (type-annotated) values
tidyUp (ts, sub) = map (\(i, (val, ty)) -> (i, (overTypes (sub $?) val, sub $? ty))) ts
-typeDictionaryForBindingGroup :: ModuleName -> [(Ident, Value)] -> UnifyT Type Check ([(Ident, (Value, Maybe (Type, Bool)))], M.Map (ModuleName, Ident) (Type, NameKind), [(Ident, Type)])
+typeDictionaryForBindingGroup :: ModuleName -> [(Ident, Value)] -> UnifyT Type Check ([(Ident, (Value, Maybe (Type, Bool)))], M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility), [(Ident, Type)])
typeDictionaryForBindingGroup moduleName vals = do
let
-- Map each declaration to a name/value pair, with an optional type, if the declaration is typed
@@ -212,15 +212,14 @@ typeDictionaryForBindingGroup moduleName vals = do
-- Make a map of names to the unification variables of untyped declarations
untypedDict = zip (map fst untyped) untypedNames
-- Create the dictionary of all name/type pairs, which will be added to the environment during type checking
- dict = M.fromList (map (\(ident, ty) -> ((moduleName, ident), (ty, LocalVariable))) $ typedDict ++ untypedDict)
+ dict = M.fromList (map (\(ident, ty) -> ((moduleName, ident), (ty, LocalVariable, Undefined))) $ typedDict ++ untypedDict)
return (es, dict, untypedDict)
-typeForBindingGroupElement :: ModuleName -> (Ident, (Value, Maybe (Type, Bool))) -> M.Map (ModuleName, Ident) (Type, NameKind) -> [(Ident, Type)] -> UnifyT Type Check (Ident, (Value, Type))
-typeForBindingGroupElement moduleName e@(_, (val, _)) dict untypedDict = do
+typeForBindingGroupElement :: ModuleName -> (Ident, (Value, Maybe (Type, Bool))) -> M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility) -> [(Ident, Type)] -> UnifyT Type Check (Ident, (Value, Type))
+typeForBindingGroupElement moduleName el dict untypedDict =
-- If the declaration is a function, it has access to other values in the binding group.
-- If not, the generated code might fail at runtime since those values might be undefined.
- let dict' = if isFunction val then dict else M.empty
- case e of
+ case el of
-- Typed declarations
(ident, (val', Just (ty, checkType))) -> do
-- Kind check
@@ -228,27 +227,18 @@ typeForBindingGroupElement moduleName e@(_, (val, _)) dict untypedDict = do
guardWith (strMsg $ "Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star
-- Check the type with the new names in scope
ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty
- val'' <- bindNames dict' $ if checkType
- then TypedValue True <$> check val' ty' <*> pure ty'
- else return (TypedValue False val' ty')
+ val'' <- if checkType
+ then bindNames dict $ TypedValue True <$> check val' ty' <*> pure ty'
+ else return (TypedValue False val' ty')
return (ident, (val'', ty'))
-- Untyped declarations
(ident, (val', Nothing)) -> do
-- Infer the type with the new names in scope
- TypedValue _ val'' ty <- bindNames dict' $ infer val'
+ TypedValue _ val'' ty <- bindNames dict $ infer val'
ty =?= fromMaybe (error "name not found in dictionary") (lookup ident untypedDict)
return (ident, (TypedValue True val'' ty, ty))
-- |
--- Check if a value introduces a function
---
-isFunction :: Value -> Bool
-isFunction (Abs _ _) = True
-isFunction (TypedValue _ val _) = isFunction val
-isFunction (PositionedValue _ val) = isFunction val
-isFunction _ = False
-
--- |
-- Check if a value contains a type annotation
--
isTyped :: (Ident, Value) -> (Ident, (Value, Maybe (Type, Bool)))
@@ -317,7 +307,7 @@ entails env moduleName context = solve (sortedNubBy canonicalizeDictionary (filt
filterModule (TypeClassDictionaryInScope { tcdName = Qualified (Just mn) _ }) | mn == moduleName = True
filterModule (TypeClassDictionaryInScope { tcdName = Qualified Nothing _ }) = True
filterModule _ = False
-
+
solve context' (className, tys) trySuperclasses =
let
dicts = go trySuperclasses className tys
@@ -336,7 +326,7 @@ entails env moduleName context = solve (sortedNubBy canonicalizeDictionary (filt
, subst <- maybeToList . (>>= verifySubstitution) . fmap concat $ zipWithM (typeHeadsAreEqual moduleName env) tys' (tcdInstanceTypes tcd)
-- Solve any necessary subgoals
, args <- solveSubgoals subst (tcdDependencies tcd) ] ++
-
+
-- Look for implementations via superclasses
[ SubclassDictionaryValue suDict superclass index
| trySuperclasses'
@@ -350,7 +340,7 @@ entails env moduleName context = solve (sortedNubBy canonicalizeDictionary (filt
-- Finally, satisfy the subclass constraint
, args' <- maybeToList $ mapM (flip lookup subst) args
, suDict <- go True subclassName args' ]
-
+
-- Create dictionaries for subgoals which still need to be solved by calling go recursively
-- E.g. the goal (Show a, Show b) => Show (Either a b) can be satisfied if the current type
-- unifies with Either a b, and we can satisfy the subgoals Show a and Show b recursively.
@@ -370,8 +360,8 @@ entails env moduleName context = solve (sortedNubBy canonicalizeDictionary (filt
dictionaryValueToValue (GlobalDictionaryValue fnName) = App (Var fnName) (ObjectLiteral [])
dictionaryValueToValue (DependentDictionaryValue fnName dicts) = foldl App (Var fnName) (map dictionaryValueToValue dicts)
dictionaryValueToValue (SubclassDictionaryValue dict superclassName index) =
- App (Accessor (show superclassName ++ "_" ++ show index)
- (Accessor C.__superclasses (dictionaryValueToValue dict)))
+ App (Accessor (C.__superclass_ ++ show superclassName ++ "_" ++ show index)
+ (dictionaryValueToValue dict))
(ObjectLiteral [])
-- Ensure that a substitution is valid
verifySubstitution :: [(String, Type)] -> Maybe [(String, Type)]
@@ -630,7 +620,7 @@ infer' (Accessor prop val) = do
infer' (Abs (Left arg) ret) = do
ty <- fresh
Just moduleName <- checkCurrentModule <$> get
- bindLocalVariables moduleName [(arg, ty)] $ do
+ makeBindingGroupVisible $ bindLocalVariables moduleName [(arg, ty, Defined)] $ do
body@(TypedValue _ _ bodyTy) <- infer' ret
return $ TypedValue True (Abs (Left arg) body) $ function ty bodyTy
infer' (Abs (Right _) _) = error "Binder was not desugared"
@@ -640,6 +630,7 @@ infer' (App f arg) = do
return $ TypedValue True app ret
infer' (Var var) = do
Just moduleName <- checkCurrentModule <$> get
+ checkVisibility moduleName var
ty <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< lookupVariable moduleName $ var
case ty of
ConstrainedType constraints ty' -> do
@@ -650,8 +641,8 @@ infer' v@(Constructor c) = do
env <- getEnv
case M.lookup c (dataConstructors env) of
Nothing -> throwError . strMsg $ "Constructor " ++ show c ++ " is undefined"
- Just (_, ty) -> do ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty
- return $ TypedValue True v ty'
+ Just (_, _, ty) -> do ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty
+ return $ TypedValue True v ty'
infer' (Case vals binders) = do
ts <- mapM infer vals
ret <- fresh
@@ -680,29 +671,29 @@ infer' (PositionedValue pos val) = rethrowWithPosition pos $ infer' val
infer' _ = error "Invalid argument to infer"
inferLetBinding :: [Declaration] -> [Declaration] -> Value -> (Value -> UnifyT Type Check Value) -> UnifyT Type Check ([Declaration], Value)
-inferLetBinding seen [] ret j = (,) seen <$> j ret
+inferLetBinding seen [] ret j = (,) seen <$> makeBindingGroupVisible (j ret)
inferLetBinding seen (ValueDeclaration ident nameKind [] Nothing tv@(TypedValue checkType val ty) : rest) ret j = do
Just moduleName <- checkCurrentModule <$> get
kind <- liftCheck $ kindOf moduleName ty
guardWith (strMsg $ "Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star
- let dict = if isFunction val then M.singleton (moduleName, ident) (ty, nameKind) else M.empty
+ let dict = M.singleton (moduleName, ident) (ty, nameKind, Undefined)
ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty
TypedValue _ val' ty'' <- if checkType then bindNames dict (check val ty') else return tv
- bindNames (M.singleton (moduleName, ident) (ty'', nameKind)) $ inferLetBinding (seen ++ [ValueDeclaration ident nameKind [] Nothing (TypedValue checkType val' ty'')]) rest ret j
+ bindNames (M.singleton (moduleName, ident) (ty'', nameKind, Defined)) $ inferLetBinding (seen ++ [ValueDeclaration ident nameKind [] Nothing (TypedValue checkType val' ty'')]) rest ret j
inferLetBinding seen (ValueDeclaration ident nameKind [] Nothing val : rest) ret j = do
valTy <- fresh
Just moduleName <- checkCurrentModule <$> get
- let dict = if isFunction val then M.singleton (moduleName, ident) (valTy, nameKind) else M.empty
+ let dict = M.singleton (moduleName, ident) (valTy, nameKind, Undefined)
TypedValue _ val' valTy' <- bindNames dict $ infer val
valTy =?= valTy'
- bindNames (M.singleton (moduleName, ident) (valTy', nameKind)) $ inferLetBinding (seen ++ [ValueDeclaration ident nameKind [] Nothing val']) rest ret j
+ bindNames (M.singleton (moduleName, ident) (valTy', nameKind, Defined)) $ inferLetBinding (seen ++ [ValueDeclaration ident nameKind [] Nothing val']) rest ret j
inferLetBinding seen (BindingGroupDeclaration ds : rest) ret j = do
Just moduleName <- checkCurrentModule <$> get
(es, dict, untypedDict) <- typeDictionaryForBindingGroup moduleName (map (\(i, _, v) -> (i, v)) ds)
ds' <- forM es $ \e -> do
(ident, (val', _)) <- typeForBindingGroupElement moduleName e dict untypedDict
return $ (ident, LocalVariable, val')
- bindNames dict $ inferLetBinding (seen ++ [BindingGroupDeclaration ds']) rest ret j
+ makeBindingGroupVisible $ bindNames dict $ inferLetBinding (seen ++ [BindingGroupDeclaration ds']) rest ret j
inferLetBinding seen (PositionedDeclaration pos d : ds) ret j = rethrowWithPosition pos $ do
((d' : ds'), val') <- inferLetBinding seen (d : ds) ret j
return (PositionedDeclaration pos d' : ds', val')
@@ -735,9 +726,9 @@ inferBinder val (VarBinder name) = return $ M.singleton name val
inferBinder val (ConstructorBinder ctor binders) = do
env <- getEnv
case M.lookup ctor (dataConstructors env) of
- Just (_, ty) -> do
+ Just (_, _, ty) -> do
(_, fn) <- instantiatePolyTypeWithUnknowns (error "Data constructor types cannot contain constraints") ty
- fn' <- replaceAllTypeSynonyms fn
+ fn' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ fn
go binders fn'
where
go [] ty' = do
@@ -786,7 +777,7 @@ checkBinders _ _ [] = return []
checkBinders nvals ret (CaseAlternative binders grd val : bs) = do
Just moduleName <- checkCurrentModule <$> get
m1 <- M.unions <$> zipWithM inferBinder nvals binders
- r <- bindLocalVariables moduleName (M.toList m1) $ do
+ r <- bindLocalVariables moduleName [ (name, ty, Defined) | (name, ty) <- M.toList m1 ] $ do
val' <- TypedValue True <$> check val ret <*> pure ret
case grd of
Nothing -> return $ CaseAlternative binders Nothing val'
@@ -861,7 +852,7 @@ check' val t@(ConstrainedType constraints ty) = do
dictNames <- forM constraints $ \(Qualified _ (ProperName className), _) -> do
n <- liftCheck freshDictionaryName
return $ Ident $ "__dict_" ++ className ++ "_" ++ show n
- val' <- withTypeClassDictionaries (zipWith (\name (className, instanceTy) ->
+ val' <- makeBindingGroupVisible $ withTypeClassDictionaries (zipWith (\name (className, instanceTy) ->
TypeClassDictionaryInScope name className instanceTy Nothing TCDRegular) (map (Qualified Nothing) dictNames)
constraints) $ check val ty
return $ TypedValue True (foldr (Abs . Left) val' dictNames) t
@@ -886,7 +877,7 @@ check' (ArrayLiteral vals) t@(TypeApp a ty) = do
return $ TypedValue True array t
check' (Abs (Left arg) ret) ty@(TypeApp (TypeApp t argTy) retTy) | t == tyFunction = do
Just moduleName <- checkCurrentModule <$> get
- ret' <- bindLocalVariables moduleName [(arg, argTy)] $ check ret retTy
+ ret' <- makeBindingGroupVisible $ bindLocalVariables moduleName [(arg, argTy, Defined)] $ check ret retTy
return $ TypedValue True (Abs (Left arg) ret') ty
check' (Abs (Right _) _) _ = error "Binder was not desugared"
check' (App f arg) ret = do
@@ -895,6 +886,7 @@ check' (App f arg) ret = do
return $ TypedValue True app ret
check' v@(Var var) ty = do
Just moduleName <- checkCurrentModule <$> get
+ checkVisibility moduleName var
repl <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< lookupVariable moduleName $ var
ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty
v' <- subsumes (Just v) repl ty'
@@ -939,6 +931,9 @@ check' (ObjectLiteral ps) t@(TypeApp obj row) | obj == tyObject = do
ensureNoDuplicateProperties ps
ps' <- checkProperties ps row False
return $ TypedValue True (ObjectLiteral ps') t
+check' (TypeClassDictionaryConstructorApp name ps) t = do
+ ps' <- check' ps t
+ return $ TypedValue True (TypeClassDictionaryConstructorApp name ps') t
check' (ObjectUpdate obj ps) t@(TypeApp o row) | o == tyObject = do
ensureNoDuplicateProperties ps
us <- zip (map fst ps) <$> replicateM (length ps) fresh
@@ -956,7 +951,7 @@ check' (Constructor c) ty = do
env <- getEnv
case M.lookup c (dataConstructors env) of
Nothing -> throwError . strMsg $ "Constructor " ++ show c ++ " is undefined"
- Just (_, ty1) -> do
+ Just (_, _, ty1) -> do
repl <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty1
_ <- subsumes Nothing repl ty
return $ TypedValue True (Constructor c) ty
@@ -1013,7 +1008,9 @@ checkProperties ps row lax = let (ts, r') = rowToList row in go ps ts r' where
-- Check the type of a function application, rethrowing errors to provide a better error message
--
checkFunctionApplication :: Value -> Type -> Value -> Maybe Type -> UnifyT Type Check (Type, Value)
-checkFunctionApplication fn fnTy arg ret = rethrow (mkErrorStack errorMessage (Just (ValueError fn)) <>) $ checkFunctionApplication' fn fnTy arg ret
+checkFunctionApplication fn fnTy arg ret = rethrow (mkErrorStack errorMessage (Just (ValueError fn)) <>) $ do
+ subst <- unifyCurrentSubstitution <$> UnifyT get
+ checkFunctionApplication' fn (subst $? fnTy) arg (($?) subst <$> ret)
where
errorMessage = "Error applying function of type "
++ prettyPrintType fnTy
@@ -1025,10 +1022,12 @@ checkFunctionApplication fn fnTy arg ret = rethrow (mkErrorStack errorMessage (J
checkFunctionApplication' :: Value -> Type -> Value -> Maybe Type -> UnifyT Type Check (Type, Value)
checkFunctionApplication' fn (TypeApp (TypeApp tyFunction' argTy) retTy) arg ret = do
tyFunction' =?= tyFunction
- _ <- maybe (return Nothing) (subsumes Nothing retTy) ret
- subst <- unifyCurrentSubstitution <$> UnifyT get
- arg' <- check arg (subst $? argTy)
- return (retTy, App fn arg')
+ arg' <- check arg argTy
+ case ret of
+ Nothing -> return (retTy, App fn arg')
+ Just ret' -> do
+ Just app' <- subsumes (Just (App fn arg')) retTy ret'
+ return (retTy, app')
checkFunctionApplication' fn (ForAll ident ty _) arg ret = do
replaced <- replaceVarWithUnknown ident ty
checkFunctionApplication fn replaced arg ret
@@ -1088,8 +1087,7 @@ subsumes' val ty1 (SaturatedTypeSynonym name tyArgs) = do
subsumes val ty1 ty2
subsumes' (Just val) (ConstrainedType constraints ty1) ty2 = do
dicts <- getTypeClassDictionaries
- _ <- subsumes' Nothing ty1 ty2
- return . Just $ foldl App val (map (flip (TypeClassDictionary True) dicts) constraints)
+ subsumes' (Just $ foldl App val (map (flip (TypeClassDictionary True) dicts) constraints)) ty1 ty2
subsumes' val (TypeApp f1 r1) (TypeApp f2 r2) | f1 == tyObject && f2 == tyObject = do
let
(ts1, r1') = rowToList r1