git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Initial modules implementation
commit34f1a08517a26e9eaeca2483e6fbd5154cd2169e authorPhil Freeman <paf31@cantab.net> dateSat 9 Nov 2013, 19:11 (13 years ago) parentaca3ec1
22 files changed+364−214
compare with golang
unifiedsplit
examples/passing/Module.ps+22 src/Language/PureScript/CodeGen/Externs.hs+18−11 src/Language/PureScript/CodeGen/JS.hs+97−73 src/Language/PureScript/CodeGen/JS/AST.hs+6−2 src/Language/PureScript/Declarations.hs+5−4 src/Language/PureScript/Names.hs+22 src/Language/PureScript/Optimize.hs+6−3 src/Language/PureScript/Parser/Common.hs+12−3 src/Language/PureScript/Parser/Declarations.hs+12−2 src/Language/PureScript/Parser/Types.hs+1−1 src/Language/PureScript/Parser/Values.hs+7−7 src/Language/PureScript/Pretty/JS.hs+6−2 src/Language/PureScript/Pretty/Types.hs+2−2 src/Language/PureScript/Pretty/Values.hs+3−3 src/Language/PureScript/TypeChecker.hs+31−21 src/Language/PureScript/TypeChecker/Kinds.hs+38−33 src/Language/PureScript/TypeChecker/Monad.hs+27−13 src/Language/PureScript/TypeChecker/Synonyms.hs+5−4 src/Language/PureScript/TypeChecker/Types.hs+35−22 src/Language/PureScript/Types.hs+3−2 src/Language/PureScript/Values.hs+4−4 src/Main.hs+2−2
examples/passing/Module.psnew file+22
@@ -0,0 +1,22 @@
1+module Test where
2+
3+ data Foo = Foo String
4+
5+ foo :: Test:Foo -> String
6+ foo = \f -> case f of Foo s -> s ++ "foo"
7+
8+ bar :: Foo -> String
9+ bar = foo
10+
11+ module Inner where
12+
13+ inner = "Inner"
14+
15+baz :: Test:Foo -> String
16+baz = Test:foo
17+
18+innerCopy :: String
19+innerCopy = Test:Inner:inner
20+
21+match :: Test:Foo -> String
22+match = \f -> case f of Test:Foo s -> s ++ "foo"
src/Language/PureScript/CodeGen/Externs.hs+18−11
@@ -17,19 +17,26 @@ module Language.PureScript.CodeGen.Externs (
1717) where
1818
1919import Data.List (intercalate)
20+import Data.Maybe (mapMaybe)
2021import qualified Data.Map as M
2122import Language.PureScript.Declarations
2223import Language.PureScript.TypeChecker.Monad
2324import Language.PureScript.Pretty
25+import Language.PureScript.Names
2426
25−externToPs :: Environment -> Declaration -> Maybe String
26−externToPs env (ValueDeclaration name _) = do
27− (ty, _) <- M.lookup name $ names env
28− return $ "foreign import " ++ show name ++ " :: " ++ prettyPrintPolyType ty
29−externToPs env (ExternMemberDeclaration member name ty) =
30− return $ "foreign import member " ++ show member ++ " " ++ show name ++ " :: " ++ prettyPrintPolyType ty
31−externToPs env (ExternDataDeclaration name kind) =
32− return $ "foreign import data " ++ name ++ " :: " ++ prettyPrintKind kind
33−externToPs env (TypeSynonymDeclaration name args ty) =
34− return $ "type " ++ name ++ " " ++ unwords args ++ " = " ++ prettyPrintType ty
35−externToPs _ _ = Nothing
27+externToPs :: Int -> ModulePath -> Environment -> Declaration -> Maybe String
28+externToPs indent path env (ValueDeclaration name _) = do
29+ (ty, _) <- M.lookup (path, name) $ names env
30+ return $ replicate indent ' ' ++ "foreign import " ++ show name ++ " :: " ++ prettyPrintPolyType ty
31+externToPs indent path env (DataDeclaration name _ _) = do
32+ (kind, _) <- M.lookup (path, name) $ types env
33+ return $ replicate indent ' ' ++ "foreign import data " ++ show name ++ " :: " ++ prettyPrintKind kind
34+externToPs indent path env (ExternMemberDeclaration member name ty) =
35+ return $ replicate indent ' ' ++ "foreign import member " ++ show member ++ " " ++ show name ++ " :: " ++ prettyPrintPolyType ty
36+externToPs indent path env (ExternDataDeclaration name kind) =
37+ return $ replicate indent ' ' ++ "foreign import data " ++ show name ++ " :: " ++ prettyPrintKind kind
38+externToPs indent path env (TypeSynonymDeclaration name args ty) =
39+ return $ replicate indent ' ' ++ "type " ++ show name ++ " " ++ unwords args ++ " = " ++ prettyPrintType ty
40+externToPs indent path env (ModuleDeclaration name decls) =
41+ return $ replicate indent ' ' ++ "module " ++ show name ++ " where\n" ++ unlines (mapMaybe (externToPs (indent + 2) (subModule path name) env) decls)
42+externToPs _ _ _ _ = Nothing
src/Language/PureScript/CodeGen/JS.hs+97−73
@@ -18,7 +18,7 @@ module Language.PureScript.CodeGen.JS (
1818) where
1919
2020import Data.Char
21−import Data.Maybe (fromMaybe)
21+import Data.Maybe (fromMaybe, mapMaybe)
2222import Data.List (intercalate)
2323import qualified Control.Arrow as A
2424import Control.Arrow ((<+>), second)
@@ -33,76 +33,100 @@ import Language.PureScript.Pretty.Common
3333import Language.PureScript.CodeGen.Monad
3434import Language.PureScript.CodeGen.JS.AST as AST
3535
36−declToJs :: Declaration -> Maybe [JS]
37−declToJs (ValueDeclaration ident (Abs args ret)) = Just [JSFunction (Just ident) args (JSBlock [JSReturn (valueToJs ret)])]
38−declToJs (ValueDeclaration ident val) = Just [JSVariableIntroduction ident (valueToJs val)]
39−declToJs (ExternMemberDeclaration member ident _) =
40− Just [JSFunction (Just ident) [Ident "value"] (JSBlock [JSReturn (JSAccessor member (JSVar (Ident "value")))])]
41−declToJs (DataDeclaration _ _ ctors) =
42− Just $ flip map ctors $ \(ctor, maybeTy) ->
43− case maybeTy of
44− Nothing -> JSVariableIntroduction (Ident ctor) (JSObjectLiteral [ ("ctor", JSStringLiteral ctor) ])
45− Just _ -> JSFunction (Just (Ident ctor)) [Ident "value"]
46− (JSBlock [JSReturn
47− (JSObjectLiteral [ ("ctor", JSStringLiteral ctor)
48− , ("value", JSVar (Ident "value")) ])])
49−declToJs _ = Nothing
36+declToJs :: Maybe Ident -> ModulePath -> Declaration -> Maybe [JS]
37+declToJs mod mp (ValueDeclaration ident (Abs args ret)) =
38+ Just $ JSFunction (Just ident) args (JSBlock [JSReturn (valueToJs mp ret)]) :
39+ maybe [] (return . setProperty (show ident) (JSVar ident)) mod
40+declToJs mod mp (ValueDeclaration ident val) =
41+ Just $ JSVariableIntroduction ident (Just (valueToJs mp val)) :
42+ maybe [] (return . setProperty (show ident) (JSVar ident)) mod
43+declToJs mod _ (ExternMemberDeclaration member ident _) =
44+ Just $ JSFunction (Just ident) [Ident "value"] (JSBlock [JSReturn (JSAccessor member (JSVar (Ident "value")))]) :
45+ maybe [] (return . setProperty (show ident) (JSVar ident)) mod
46+declToJs mod mp (DataDeclaration _ _ ctors) =
47+ Just $ flip concatMap ctors $ \(pn@(ProperName ctor), maybeTy) ->
48+ let
49+ ctorJs =
50+ case maybeTy of
51+ Nothing -> JSVariableIntroduction (Ident ctor) (Just (JSObjectLiteral [ ("ctor", JSStringLiteral (show (Qualified mp pn))) ]))
52+ Just _ -> JSFunction (Just (Ident ctor)) [Ident "value"]
53+ (JSBlock [JSReturn
54+ (JSObjectLiteral [ ("ctor", JSStringLiteral (show (Qualified mp pn)))
55+ , ("value", JSVar (Ident "value")) ])])
56+ in ctorJs : maybe [] (return . setProperty ctor (JSVar (Ident ctor))) mod
57+declToJs mod mp (ModuleDeclaration pn@(ProperName name) decls) =
58+ Just $ [ JSVariableIntroduction (Ident name) Nothing
59+ , JSApp (JSFunction Nothing [Ident name]
60+ (JSBlock (concat $ mapMaybe (declToJs (Just (Ident name)) (subModule mp pn)) decls)))
61+ [JSAssignment (JSAssignVariable (Ident name) )
62+ (JSBinary Or (JSVar (Ident name)) (JSObjectLiteral []))]] ++
63+ maybe [] (return . setProperty name (JSVar (Ident name))) mod
64+declToJs _ _ _ = Nothing
5065
51−valueToJs :: Value -> JS
52−valueToJs (NumericLiteral n) = JSNumericLiteral n
53−valueToJs (StringLiteral s) = JSStringLiteral s
54−valueToJs (BooleanLiteral b) = JSBooleanLiteral b
55−valueToJs (ArrayLiteral xs) = JSArrayLiteral (map valueToJs xs)
56−valueToJs (ObjectLiteral ps) = JSObjectLiteral (map (second valueToJs) ps)
57−valueToJs (ObjectUpdate o ps) = JSApp (JSAccessor "extend" (JSVar (Ident "Object"))) [ valueToJs o, JSObjectLiteral (map (second valueToJs) ps)]
58−valueToJs (Constructor name) = JSVar (Ident name)
59−valueToJs (Block sts) = JSApp (JSFunction Nothing [] (JSBlock (map statementToJs sts))) []
60−valueToJs (Case value binders) = runGen (bindersToJs binders (valueToJs value))
61−valueToJs (IfThenElse cond th el) = JSConditional (valueToJs cond) (valueToJs th) (valueToJs el)
62−valueToJs (Accessor prop val) = JSAccessor prop (valueToJs val)
63−valueToJs (Indexer index val) = JSIndexer (valueToJs index) (valueToJs val)
64−valueToJs (App val args) = JSApp (valueToJs val) (map valueToJs args)
65−valueToJs (Abs args val) = JSFunction Nothing args (JSBlock [JSReturn (valueToJs val)])
66−valueToJs (Unary op val) = JSUnary op (valueToJs val)
67−valueToJs (Binary op v1 v2) = JSBinary op (valueToJs v1) (valueToJs v2)
68−valueToJs (Var ident) = JSVar ident
69−valueToJs (TypedValue val _) = valueToJs val
66+setProperty :: String -> JS -> Ident -> JS
67+setProperty prop val mod = JSAssignment (JSAssignProperty prop (JSAssignVariable mod)) val
7068
71−bindersToJs :: [(Binder, Value)] -> JS -> Gen JS
72−bindersToJs binders val = do
69+valueToJs :: ModulePath -> Value -> JS
70+valueToJs _ (NumericLiteral n) = JSNumericLiteral n
71+valueToJs _ (StringLiteral s) = JSStringLiteral s
72+valueToJs _ (BooleanLiteral b) = JSBooleanLiteral b
73+valueToJs m (ArrayLiteral xs) = JSArrayLiteral (map (valueToJs m) xs)
74+valueToJs m (ObjectLiteral ps) = JSObjectLiteral (map (second (valueToJs m)) ps)
75+valueToJs m (ObjectUpdate o ps) = JSApp (JSAccessor "extend" (JSVar (Ident "Object"))) [ valueToJs m o, JSObjectLiteral (map (second (valueToJs m)) ps)]
76+valueToJs m (Constructor name) = qualifiedToJS runProperName name
77+valueToJs m (Block sts) = JSApp (JSFunction Nothing [] (JSBlock (map (statementToJs m) sts))) []
78+valueToJs m (Case value binders) = runGen (bindersToJs m binders (valueToJs m value))
79+valueToJs m (IfThenElse cond th el) = JSConditional (valueToJs m cond) (valueToJs m th) (valueToJs m el)
80+valueToJs m (Accessor prop val) = JSAccessor prop (valueToJs m val)
81+valueToJs m (Indexer index val) = JSIndexer (valueToJs m index) (valueToJs m val)
82+valueToJs m (App val args) = JSApp (valueToJs m val) (map (valueToJs m) args)
83+valueToJs m (Abs args val) = JSFunction Nothing args (JSBlock [JSReturn (valueToJs m val)])
84+valueToJs m (Unary op val) = JSUnary op (valueToJs m val)
85+valueToJs m (Binary op v1 v2) = JSBinary op (valueToJs m v1) (valueToJs m v2)
86+valueToJs m (Var ident) = qualifiedToJS identToJs ident
87+valueToJs m (TypedValue val _) = valueToJs m val
88+
89+qualifiedToJS :: (a -> String) -> Qualified a -> JS
90+qualifiedToJS f (Qualified (ModulePath parts) a) = delimited (f a : reverse (map show parts))
91+ where
92+ delimited [part] = JSVar (Ident (part))
93+ delimited (part:parts) = JSAccessor part (delimited parts)
94+
95+bindersToJs :: ModulePath -> [(Binder, Value)] -> JS -> Gen JS
96+bindersToJs m binders val = do
7397 valName <- fresh
74− jss <- forM binders $ \(binder, result) -> binderToJs valName [JSReturn (valueToJs result)] binder
98+ jss <- forM binders $ \(binder, result) -> binderToJs m valName [JSReturn (valueToJs m result)] binder
7599 return $ JSApp (JSFunction Nothing [Ident valName] (JSBlock (concat jss ++ [JSThrow (JSStringLiteral "Failed pattern match")])))
76100 [val]
77101
78−binderToJs :: String -> [JS] -> Binder -> Gen [JS]
79−binderToJs varName done NullBinder = return done
80−binderToJs varName done (StringBinder str) =
102+binderToJs :: ModulePath -> String -> [JS] -> Binder -> Gen [JS]
103+binderToJs _ varName done NullBinder = return done
104+binderToJs _ varName done (StringBinder str) =
81105 return [JSIfElse (JSBinary EqualTo (JSVar (Ident varName)) (JSStringLiteral str)) (JSBlock done) Nothing]
82−binderToJs varName done (NumberBinder num) =
106+binderToJs _ varName done (NumberBinder num) =
83107 return [JSIfElse (JSBinary EqualTo (JSVar (Ident varName)) (JSNumericLiteral num)) (JSBlock done) Nothing]
84−binderToJs varName done (BooleanBinder True) =
108+binderToJs _ varName done (BooleanBinder True) =
85109 return [JSIfElse (JSVar (Ident varName)) (JSBlock done) Nothing]
86−binderToJs varName done (BooleanBinder False) =
110+binderToJs _ varName done (BooleanBinder False) =
87111 return [JSIfElse (JSUnary Not (JSVar (Ident varName))) (JSBlock done) Nothing]
88−binderToJs varName done (VarBinder ident) =
89− return (JSVariableIntroduction ident (JSVar (Ident varName)) : done)
90−binderToJs varName done (NullaryBinder ctor) =
91− return [JSIfElse (JSBinary EqualTo (JSAccessor "ctor" (JSVar (Ident varName))) (JSStringLiteral ctor)) (JSBlock done) Nothing]
92−binderToJs varName done (UnaryBinder ctor b) = do
112+binderToJs _ varName done (VarBinder ident) =
113+ return (JSVariableIntroduction ident (Just (JSVar (Ident varName))) : done)
114+binderToJs m varName done (NullaryBinder ctor) =
115+ return [JSIfElse (JSBinary EqualTo (JSAccessor "ctor" (JSVar (Ident varName))) (JSStringLiteral (show (uncurry Qualified $ qualify m ctor)))) (JSBlock done) Nothing]
116+binderToJs m varName done (UnaryBinder ctor b) = do
93117 value <- fresh
94− js <- binderToJs value done b
95− return [JSIfElse (JSBinary EqualTo (JSAccessor "ctor" (JSVar (Ident varName))) (JSStringLiteral ctor)) (JSBlock (JSVariableIntroduction (Ident value) (JSAccessor "value" (JSVar (Ident varName))) : js)) Nothing]
96−binderToJs varName done (ObjectBinder bs) = go done bs
118+ js <- binderToJs m value done b
119+ return [JSIfElse (JSBinary EqualTo (JSAccessor "ctor" (JSVar (Ident varName))) (JSStringLiteral (show (uncurry Qualified $ qualify m ctor)))) (JSBlock (JSVariableIntroduction (Ident value) (Just (JSAccessor "value" (JSVar (Ident varName)))) : js)) Nothing]
120+binderToJs m varName done (ObjectBinder bs) = go done bs
97121 where
98122 go :: [JS] -> [(String, Binder)] -> Gen [JS]
99123 go done [] = return done
100124 go done ((prop, binder):bs) = do
101125 propVar <- fresh
102126 done' <- go done bs
103− js <- binderToJs propVar done' binder
104− return (JSVariableIntroduction (Ident propVar) (JSAccessor prop (JSVar (Ident varName))) : js)
105−binderToJs varName done (ArrayBinder bs rest) = do
127+ js <- binderToJs m propVar done' binder
128+ return (JSVariableIntroduction (Ident propVar) (Just (JSAccessor prop (JSVar (Ident varName)))) : js)
129+binderToJs m varName done (ArrayBinder bs rest) = do
106130 js <- go done rest 0 bs
107131 return [JSIfElse (JSBinary cmp (JSAccessor "length" (JSVar (Ident varName))) (JSNumericLiteral (Left (fromIntegral $ length bs)))) (JSBlock js) Nothing]
108132 where
@@ -112,31 +136,31 @@ binderToJs varName done (ArrayBinder bs rest) = do
112136 go done Nothing _ [] = return done
113137 go done (Just binder) index [] = do
114138 restVar <- fresh
115− js <- binderToJs restVar done binder
116− return (JSVariableIntroduction (Ident restVar) (JSApp (JSAccessor "slice" (JSVar (Ident varName))) [JSNumericLiteral (Left index)]) : js)
139+ js <- binderToJs m restVar done binder
140+ return (JSVariableIntroduction (Ident restVar) (Just (JSApp (JSAccessor "slice" (JSVar (Ident varName))) [JSNumericLiteral (Left index)])) : js)
117141 go done rest index (binder:bs) = do
118142 elVar <- fresh
119143 done' <- go done rest (index + 1) bs
120− js <- binderToJs elVar done' binder
121− return (JSVariableIntroduction (Ident elVar) (JSIndexer (JSNumericLiteral (Left index)) (JSVar (Ident varName))) : js)
122−binderToJs varName done (NamedBinder ident binder) = do
123− js <- binderToJs varName done binder
124− return (JSVariableIntroduction ident (JSVar (Ident varName)) : js)
125−binderToJs varName done (GuardedBinder cond binder) = binderToJs varName done' binder
144+ js <- binderToJs m elVar done' binder
145+ return (JSVariableIntroduction (Ident elVar) (Just (JSIndexer (JSNumericLiteral (Left index)) (JSVar (Ident varName)))) : js)
146+binderToJs m varName done (NamedBinder ident binder) = do
147+ js <- binderToJs m varName done binder
148+ return (JSVariableIntroduction ident (Just (JSVar (Ident varName))) : js)
149+binderToJs m varName done (GuardedBinder cond binder) = binderToJs m varName done' binder
126150 where
127− done' = [JSIfElse (valueToJs cond) (JSBlock done) Nothing]
151+ done' = [JSIfElse (valueToJs m cond) (JSBlock done) Nothing]
128152
129−statementToJs :: Statement -> JS
130−statementToJs (VariableIntroduction ident value) = JSVariableIntroduction ident (valueToJs value)
131−statementToJs (Assignment target value) = JSAssignment target (valueToJs value)
132−statementToJs (While cond sts) = JSWhile (valueToJs cond) (JSBlock (map statementToJs sts))
133−statementToJs (For ident start end sts) = JSFor ident (valueToJs start) (valueToJs end) (JSBlock (map statementToJs sts))
134−statementToJs (ForEach ident arr sts) = JSApp (JSAccessor "forEach" (valueToJs arr)) [JSFunction Nothing [ident] (JSBlock (map statementToJs sts))]
135−statementToJs (If ifst) = ifToJs ifst
153+statementToJs :: ModulePath -> Statement -> JS
154+statementToJs m (VariableIntroduction ident value) = JSVariableIntroduction ident (Just (valueToJs m value))
155+statementToJs m (Assignment target value) = JSAssignment (JSAssignVariable target) (valueToJs m value)
156+statementToJs m (While cond sts) = JSWhile (valueToJs m cond) (JSBlock (map (statementToJs m) sts))
157+statementToJs m (For ident start end sts) = JSFor ident (valueToJs m start) (valueToJs m end) (JSBlock (map (statementToJs m) sts))
158+statementToJs m (ForEach ident arr sts) = JSApp (JSAccessor "forEach" (valueToJs m arr)) [JSFunction Nothing [ident] (JSBlock (map (statementToJs m) sts))]
159+statementToJs m (If ifst) = ifToJs ifst
136160 where
137161 ifToJs :: IfStatement -> JS
138− ifToJs (IfStatement cond thens elses) = JSIfElse (valueToJs cond) (JSBlock (map statementToJs thens)) (fmap elseToJs elses)
162+ ifToJs (IfStatement cond thens elses) = JSIfElse (valueToJs m cond) (JSBlock (map (statementToJs m) thens)) (fmap elseToJs elses)
139163 elseToJs :: ElseStatement -> JS
140− elseToJs (Else sts) = JSBlock (map statementToJs sts)
164+ elseToJs (Else sts) = JSBlock (map (statementToJs m) sts)
141165 elseToJs (ElseIf ifst) = ifToJs ifst
142−statementToJs (Return value) = JSReturn (valueToJs value)
166+statementToJs m (Return value) = JSReturn (valueToJs m value)
src/Language/PureScript/CodeGen/JS/AST.hs+6−2
@@ -36,10 +36,14 @@ data JS
3636 | JSVar Ident
3737 | JSConditional JS JS JS
3838 | JSBlock [JS]
39− | JSVariableIntroduction Ident JS
40− | JSAssignment Ident JS
39+ | JSVariableIntroduction Ident (Maybe JS)
40+ | JSAssignment JSAssignment JS
4141 | JSWhile JS JS
4242 | JSFor Ident JS JS JS
4343 | JSIfElse JS JS (Maybe JS)
4444 | JSReturn JS
4545 | JSThrow JS deriving (Show, Data, Typeable)
46+
47+data JSAssignment
48+ = JSAssignVariable Ident
49+ | JSAssignProperty String JSAssignment deriving (Show, Data, Typeable)
src/Language/PureScript/Declarations.hs+5−4
@@ -30,11 +30,12 @@ data Associativity = Infixl | Infixr deriving (Show, D.Data, D.Typeable)
3030data Fixity = Fixity Associativity Precedence deriving (Show, D.Data, D.Typeable)
3131
3232data Declaration
33− = DataDeclaration String [String] [(String, Maybe Type)]
34− | TypeSynonymDeclaration String [String] Type
33+ = DataDeclaration ProperName [String] [(ProperName, Maybe Type)]
34+ | TypeSynonymDeclaration ProperName [String] Type
3535 | TypeDeclaration Ident PolyType
3636 | ValueDeclaration Ident Value
3737 | ExternDeclaration Ident PolyType
3838 | ExternMemberDeclaration String Ident PolyType
39− | ExternDataDeclaration String Kind
40− | FixityDeclaration Fixity String deriving (Show, D.Data, D.Typeable)
39+ | ExternDataDeclaration ProperName Kind
40+ | FixityDeclaration Fixity String
41+ | ModuleDeclaration ProperName [Declaration] deriving (Show, D.Data, D.Typeable)
src/Language/PureScript/Names.hs+22
@@ -17,6 +17,7 @@
1717module Language.PureScript.Names where
1818
1919import Data.Data
20+import Data.List (intercalate)
2021
2122data Ident = Ident String | Op String deriving (Eq, Ord, Data, Typeable)
2223
@@ -24,3 +25,24 @@ instance Show Ident where
2425 show (Ident s) = s
2526 show (Op op) = '(':op ++ ")"
2627
28+newtype ProperName = ProperName { runProperName :: String } deriving (Eq, Ord, Data, Typeable)
29+
30+instance Show ProperName where
31+ show = runProperName
32+
33+data ModulePath = ModulePath [ProperName] deriving (Show, Eq, Ord, Data, Typeable)
34+
35+subModule :: ModulePath -> ProperName -> ModulePath
36+subModule (ModulePath mp) name = ModulePath (mp ++ [name])
37+
38+global :: ModulePath
39+global = ModulePath []
40+
41+data Qualified a = Qualified ModulePath a deriving (Eq, Ord, Data, Typeable)
42+
43+instance (Show a) => Show (Qualified a) where
44+ show (Qualified (ModulePath names) a) = intercalate ":" (map show names ++ [show a])
45+
46+qualify :: ModulePath -> Qualified a -> (ModulePath, a)
47+qualify mp (Qualified (ModulePath []) a) = (mp, a)
48+qualify _ (Qualified mp a) = (mp, a)
src/Language/PureScript/Optimize.hs+6−3
@@ -35,7 +35,7 @@ isReassigned :: (Data d) => Ident -> d -> Bool
3535isReassigned var1 = everything (||) (mkQ False check)
3636 where
3737 check :: JS -> Bool
38− check (JSAssignment var2 _) | var1 == var2 = True
38+ check (JSAssignment (JSAssignVariable var2) _) | var1 == var2 = True
3939 check _ = False
4040
4141isUsed :: (Data d) => Ident -> d -> Bool
@@ -43,8 +43,11 @@ isUsed var1 = everything (||) (mkQ False check)
4343 where
4444 check :: JS -> Bool
4545 check (JSVar var2) | var1 == var2 = True
46− check (JSAssignment var2 _) | var1 == var2 = True
46+ check (JSAssignment target _) | var1 == targetVariable target = True
4747 check _ = False
48+ targetVariable :: JSAssignment -> Ident
49+ targetVariable (JSAssignVariable var) = var
50+ targetVariable (JSAssignProperty _ tgt) = targetVariable tgt
4851
4952shouldInline :: JS -> Bool
5053shouldInline (JSVar _) = True
@@ -63,7 +66,7 @@ inlineVariables = everywhere (mkT removeFromBlock)
6366 removeFromBlock js = js
6467 go :: [JS] -> [JS]
6568 go [] = []
66− go (JSVariableIntroduction var js : sts) | shouldInline js && not (isReassigned var sts) = go (replaceIdent var js sts)
69+ go (JSVariableIntroduction var (Just js) : sts) | shouldInline js && not (isReassigned var sts) = go (replaceIdent var js sts)
6770 go (s:sts) = s : go sts
6871
6972removeUnusedVariables :: JS -> JS
src/Language/PureScript/Parser/Common.hs+12−3
@@ -72,7 +72,8 @@ reservedNames = [ "case"
7272 , "String"
7373 , "Boolean"
7474 , "infixl"
75− , "infixr" ]
75+ , "infixr"
76+ , "module" ]
7677
7778reservedOpNames :: [String]
7879reservedOpNames = [ "!", "~", "-", "<=", ">=", "<", ">", "*", "/", "%", "++", "+", "<<", ">>>", ">>"
@@ -133,8 +134,16 @@ natural = PT.natural tokenParser
133134tick :: P.Parsec String u Char
134135tick = lexeme $ P.char '`'
135136
136−properName :: P.Parsec String u String
137−properName = lexeme $ P.try ((:) <$> P.upper <*> many (PT.identLetter langDef) P.<?> "name")
137+properName :: P.Parsec String u ProperName
138+properName = lexeme $ ProperName <$> P.try ((:) <$> P.upper <*> many (PT.identLetter langDef) P.<?> "name")
139+
140+parseQualified :: P.Parsec String ParseState a -> P.Parsec String ParseState (Qualified a)
141+parseQualified parser = part global
142+ where
143+ part path = (do name <- P.try (properName <* delimiter)
144+ part (subModule path name))
145+ <|> (Qualified path <$> P.try parser)
146+ delimiter = indented *> colon <* P.notFollowedBy colon
138147
139148integerOrFloat :: P.Parsec String u (Either Integer Double)
140149integerOrFloat = (Left <$> P.try (PT.natural tokenParser) <|>
src/Language/PureScript/Parser/Declarations.hs+12−2
@@ -90,6 +90,15 @@ parseFixityDeclaration = do
9090 P.modifyState $ \st -> st { fixities = M.insert name fixity current }
9191 return $ FixityDeclaration fixity name
9292
93+parseModuleDeclaration :: P.Parsec String ParseState Declaration
94+parseModuleDeclaration = do
95+ reserved "module"
96+ indented
97+ name <- properName
98+ lexeme $ P.string "where"
99+ decls <- mark (P.many (same *> parseDeclaration))
100+ return $ ModuleDeclaration name decls
101+
93102parseDeclaration :: P.Parsec String ParseState Declaration
94103parseDeclaration = P.choice
95104 [ parseDataDeclaration
@@ -97,7 +106,8 @@ parseDeclaration = P.choice
97106 , parseTypeSynonymDeclaration
98107 , parseValueDeclaration
99108 , parseExternDeclaration
100− , parseFixityDeclaration ] P.<?> "declaration"
109+ , parseFixityDeclaration
110+ , parseModuleDeclaration ] P.<?> "declaration"
101111
102112parseDeclarations :: P.Parsec String ParseState [Declaration]
103−parseDeclarations = whiteSpace *> mark (same *> P.many parseDeclaration) <* P.eof
113+parseDeclarations = whiteSpace *> mark (P.many (same *> parseDeclaration)) <* P.eof
src/Language/PureScript/Parser/Types.hs+1−1
@@ -52,7 +52,7 @@ parseTypeVariable :: P.Parsec String ParseState Type
5252parseTypeVariable = TypeVar <$> identifier
5353
5454parseTypeConstructor :: P.Parsec String ParseState Type
55−parseTypeConstructor = TypeConstructor <$> properName
55+parseTypeConstructor = TypeConstructor <$> parseQualified properName
5656
5757parseTypeAtom :: P.Parsec String ParseState Type
5858parseTypeAtom = indented *> P.choice (map P.try
src/Language/PureScript/Parser/Values.hs+7−7
@@ -79,10 +79,10 @@ parseApp = App <$> parseValue
7979 <*> (C.indented *> C.parens (parseValue `P.sepBy` (C.indented *> C.comma)))
8080
8181parseVar :: P.Parsec String ParseState Value
82−parseVar = Var <$> C.parseIdent
82+parseVar = Var <$> C.parseQualified C.parseIdent
8383
8484parseConstructor :: P.Parsec String ParseState Value
85−parseConstructor = Constructor <$> C.properName
85+parseConstructor = Constructor <$> C.parseQualified C.properName
8686
8787parseCase :: P.Parsec String ParseState Value
8888parseCase = Case <$> P.between (P.try (C.reserved "case")) (C.indented *> C.reserved "of") parseValue
@@ -112,8 +112,8 @@ parseValueAtom = C.indented *> P.choice
112112 , parseArrayLiteral
113113 , parseObjectLiteral
114114 , parseAbs
115− , P.try parseVar
116115 , P.try parseConstructor
116+ , P.try parseVar
117117 , parseBlock
118118 , parseCase
119119 , parseIfThenElse
@@ -145,7 +145,7 @@ parseValue = do
145145 , Prefix $ C.lexeme (P.try $ C.indented *> C.reservedOp "-") >> return (Unary Negate)
146146 , Prefix $ C.lexeme (P.try $ C.indented *> C.reservedOp "+") >> return id ]
147147 ] ++ customOperatorTable user ++
148− [ [ Infix (C.lexeme (P.try (C.indented *> C.parseIdentInfix P.<?> "operator") >>= \ident -> return $ \t1 t2 -> App (App (Var ident) [t1]) [t2])) AssocLeft ]
148+ [ [ Infix (C.lexeme (P.try (C.indented *> C.parseQualified C.parseIdentInfix P.<?> "operator") >>= \ident -> return $ \t1 t2 -> App (App (Var ident) [t1]) [t2])) AssocLeft ]
149149 , [ Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "!!") >> return (flip Indexer)) AssocRight ]
150150 , [ Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "<=") >> return (Binary LessThanOrEqualTo)) AssocRight
151151 , Infix (C.lexeme (P.try $ C.indented *> C.reservedOp ">=") >> return (Binary GreaterThanOrEqualTo)) AssocRight ]
@@ -181,7 +181,7 @@ customOperatorTable fixities =
181181 C.lexeme $ P.try $ do
182182 C.indented
183183 C.reservedOp name P.<?> "operator"
184− return $ \t1 t2 -> App (App (Var (Op name)) [t1]) [t2])
184+ return $ \t1 t2 -> App (App (Var (Qualified global (Op name))) [t1]) [t2])
185185 levels
186186
187187toAssoc :: Associativity -> Assoc
@@ -257,10 +257,10 @@ parseVarBinder :: P.Parsec String ParseState Binder
257257parseVarBinder = VarBinder <$> C.parseIdent
258258
259259parseNullaryBinder :: P.Parsec String ParseState Binder
260−parseNullaryBinder = NullaryBinder <$> C.lexeme C.properName
260+parseNullaryBinder = NullaryBinder <$> C.lexeme (C.parseQualified C.properName)
261261
262262parseUnaryBinder :: P.Parsec String ParseState Binder
263−parseUnaryBinder = UnaryBinder <$> C.lexeme C.properName <*> (C.indented *> parseBinder)
263+parseUnaryBinder = UnaryBinder <$> C.lexeme (C.parseQualified C.properName) <*> (C.indented *> parseBinder)
264264
265265parseObjectBinder :: P.Parsec String ParseState Binder
266266parseObjectBinder = ObjectBinder <$> C.braces ((C.indented *> parseIdentifierAndBinder) `P.sepBy` (C.indented *> C.comma))
src/Language/PureScript/Pretty/JS.hs+6−2
@@ -37,8 +37,8 @@ literals = Pattern $ A.Kleisli match
3737 match (JSObjectLiteral ps) = Just $ "{ " ++ intercalate ", " (map (\(key, value) -> key ++ ": " ++ prettyPrintJS value) ps) ++ " }"
3838 match (JSBlock sts) = Just $ "{ " ++ intercalate "; " (map prettyPrintJS sts) ++ " }"
3939 match (JSVar ident) = Just (identToJs ident)
40− match (JSVariableIntroduction ident value) = Just $ "var " ++ identToJs ident ++ " = " ++ prettyPrintJS value
41− match (JSAssignment target value) = Just $ identToJs target ++ " = " ++ prettyPrintJS value
40+ match (JSVariableIntroduction ident value) = Just $ "var " ++ identToJs ident ++ maybe "" ((" = " ++) . prettyPrintJS) value
41+ match (JSAssignment target value) = Just $ targetToJs target ++ " = " ++ prettyPrintJS value
4242 match (JSWhile cond sts) = Just $ "while ("
4343 ++ prettyPrintJS cond ++ ") "
4444 ++ prettyPrintJS sts
@@ -55,6 +55,10 @@ literals = Pattern $ A.Kleisli match
5555 match (JSThrow value) = Just $ "throw " ++ prettyPrintJS value
5656 match _ = Nothing
5757
58+targetToJs :: JSAssignment -> String
59+targetToJs (JSAssignVariable ident) = identToJs ident
60+targetToJs (JSAssignProperty prop target) = targetToJs target ++ "." ++ prop
61+
5862conditional :: Pattern JS ((JS, JS), JS)
5963conditional = Pattern $ A.Kleisli match
6064 where
src/Language/PureScript/Pretty/Types.hs+2−2
@@ -41,9 +41,9 @@ typeLiterals = Pattern $ A.Kleisli match
4141 match (Array ty) = Just $ "[" ++ prettyPrintType ty ++ "]"
4242 match (Object row) = Just $ "{ " ++ prettyPrintRow row ++ " }"
4343 match (TypeVar var) = Just var
44− match (TypeConstructor ctor) = Just ctor
44+ match (TypeConstructor ctor) = Just $ show ctor
4545 match (TUnknown u) = Just $ 'u' : show u
46− match (SaturatedTypeSynonym name args) = Just $ name ++ "<" ++ intercalate "," (map prettyPrintType args) ++ ">"
46+ match (SaturatedTypeSynonym name args) = Just $ show name ++ "<" ++ intercalate "," (map prettyPrintType args) ++ ">"
4747 match _ = Nothing
4848
4949prettyPrintRow :: Row -> String
src/Language/PureScript/Pretty/Values.hs+3−3
@@ -38,7 +38,7 @@ literals = Pattern $ A.Kleisli match
3838 match (BooleanLiteral False) = Just "false"
3939 match (ArrayLiteral xs) = Just $ "[" ++ intercalate ", " (map prettyPrintValue xs) ++ "]"
4040 match (ObjectLiteral ps) = Just $ "{" ++ intercalate ", " (map (uncurry prettyPrintObjectProperty) ps) ++ "}"
41− match (Constructor name) = Just name
41+ match (Constructor name) = Just $ show name
4242 match (Block sts) = Just $ "do { " ++ intercalate " ; " (map prettyPrintStatement sts) ++ " }"
4343 match (Case value binders) = Just $ "case " ++ prettyPrintValue value ++ " of { " ++ intercalate " ; " (map (uncurry prettyPrintCaseAlternative) binders) ++ " }"
4444 match (Var ident) = Just $ show ident
@@ -146,8 +146,8 @@ prettyPrintBinder (NumberBinder num) = either show show num
146146prettyPrintBinder (BooleanBinder True) = "true"
147147prettyPrintBinder (BooleanBinder False) = "false"
148148prettyPrintBinder (VarBinder ident) = show ident
149−prettyPrintBinder (NullaryBinder ctor) = ctor
150−prettyPrintBinder (UnaryBinder ctor b) = ctor ++ prettyPrintBinder b
149+prettyPrintBinder (NullaryBinder ctor) = show ctor
150+prettyPrintBinder (UnaryBinder ctor b) = show ctor ++ prettyPrintBinder b
151151prettyPrintBinder (ObjectBinder bs) = "{ " ++ intercalate ", " (map (uncurry prettyPrintObjectPropertyBinder) bs) ++ " }"
152152prettyPrintBinder (ArrayBinder bs rest) = "[ " ++ intercalate ", " (map prettyPrintBinder bs) ++ maybe "" (("; " ++) . prettyPrintBinder) rest ++ " ]"
153153prettyPrintBinder (NamedBinder ident binder) = show ident ++ "@" ++ prettyPrintBinder binder
src/Language/PureScript/TypeChecker.hs+31−21
@@ -42,27 +42,29 @@ import Control.Monad.Error
4242typeCheckAll :: [Declaration] -> Check ()
4343typeCheckAll [] = return ()
4444typeCheckAll (DataDeclaration name args dctors : rest) = do
45− rethrow (("Error in type constructor " ++ name ++ ": ") ++) $ do
45+ rethrow (("Error in type constructor " ++ show name ++ ": ") ++) $ do
4646 env <- getEnv
47− guardWith (name ++ " is already defined") $ not $ M.member name (types env)
47+ modulePath <- checkModulePath `fmap` get
48+ guardWith (show name ++ " is already defined") $ not $ M.member (modulePath, name) (types env)
4849 ctorKind <- kindsOf (Just name) args (mapMaybe snd dctors)
49− putEnv $ env { types = M.insert name (ctorKind, Data) (types env) }
50+ putEnv $ env { types = M.insert (modulePath, name) (ctorKind, Data) (types env) }
5051 forM_ dctors $ \(dctor, maybeTy) ->
51− rethrow (("Error in data constructor " ++ name ++ ": ") ++) $ do
52+ rethrow (("Error in data constructor " ++ show name ++ ": ") ++) $ do
5253 env' <- getEnv
53− guardWith (dctor ++ " is already defined") $ not $ M.member dctor (dataConstructors env')
54− let retTy = foldl TypeApp (TypeConstructor name) (map TypeVar args)
54+ guardWith (show dctor ++ " is already defined") $ not $ M.member (modulePath, dctor) (dataConstructors env')
55+ let retTy = foldl TypeApp (TypeConstructor (Qualified modulePath name)) (map TypeVar args)
5556 let dctorTy = maybe retTy (\ty -> Function [ty] retTy) maybeTy
5657 let polyType = PolyType args dctorTy
57− putEnv $ env' { dataConstructors = M.insert dctor polyType (dataConstructors env') }
58+ putEnv $ env' { dataConstructors = M.insert (modulePath, dctor) polyType (dataConstructors env') }
5859 typeCheckAll rest
5960typeCheckAll (TypeSynonymDeclaration name args ty : rest) = do
60− rethrow (("Error in type synonym " ++ name ++ ": ") ++) $ do
61+ rethrow (("Error in type synonym " ++ show name ++ ": ") ++) $ do
6162 env <- getEnv
62− guardWith (name ++ " is already defined") $ not $ M.member name (types env)
63+ modulePath <- checkModulePath `fmap` get
64+ guardWith (show name ++ " is already defined") $ not $ M.member (modulePath, name) (types env)
6365 kind <- kindsOf (Just name) args [ty]
64− putEnv $ env { types = M.insert name (kind, TypeSynonym) (types env)
65− , typeSynonyms = M.insert name (args, ty) (typeSynonyms env) }
66+ putEnv $ env { types = M.insert (modulePath, name) (kind, TypeSynonym) (types env)
67+ , typeSynonyms = M.insert (modulePath, name) (args, ty) (typeSynonyms env) }
6668 typeCheckAll rest
6769typeCheckAll (TypeDeclaration name ty : ValueDeclaration name' val : rest) | name == name' =
6870 typeCheckAll (ValueDeclaration name (TypedValue val ty) : rest)
@@ -70,40 +72,48 @@ typeCheckAll (TypeDeclaration name _ : _) = throwError $ "Orphan type declaratio
7072typeCheckAll (ValueDeclaration name val : rest) = do
7173 rethrow (("Error in declaration " ++ show name ++ ": ") ++) $ do
7274 env <- getEnv
73− case M.lookup name (names env) of
75+ modulePath <- checkModulePath `fmap` get
76+ case M.lookup (modulePath, name) (names env) of
7477 Just ty -> throwError $ show name ++ " is already defined"
7578 Nothing -> do
7679 ty <- typeOf name val
77− putEnv (env { names = M.insert name (ty, Value) (names env) })
80+ putEnv (env { names = M.insert (modulePath, name) (ty, Value) (names env) })
7881 typeCheckAll rest
7982typeCheckAll (ExternDataDeclaration name kind : rest) = do
8083 env <- getEnv
81− guardWith (name ++ " is already defined") $ not $ M.member name (types env)
82− putEnv $ env { types = M.insert name (kind, TypeSynonym) (types env) }
84+ modulePath <- checkModulePath `fmap` get
85+ guardWith (show name ++ " is already defined") $ not $ M.member (modulePath, name) (types env)
86+ putEnv $ env { types = M.insert (modulePath, name) (kind, TypeSynonym) (types env) }
8387 typeCheckAll rest
8488typeCheckAll (ExternMemberDeclaration member name ty : rest) = do
8589 rethrow (("Error in foreign import member declaration " ++ show name ++ ": ") ++) $ do
8690 env <- getEnv
91+ modulePath <- checkModulePath `fmap` get
8792 kind <- kindOf ty
8893 guardWith "Expected kind *" $ kind == Star
89− case M.lookup name (names env) of
94+ case M.lookup (modulePath, name) (names env) of
9095 Just _ -> throwError $ show name ++ " is already defined"
9196 Nothing -> case ty of
9297 (PolyType _ (Function [_] _)) -> do
93− putEnv (env { names = M.insert name (ty, Extern) (names env)
94− , members = M.insert name member (members env) })
98+ putEnv (env { names = M.insert (modulePath, name) (ty, Extern) (names env)
99+ , members = M.insert (modulePath, name) member (members env) })
95100 _ -> throwError "Foreign member declarations must have function types, with an single argument."
96101 typeCheckAll rest
97102typeCheckAll (ExternDeclaration name ty : rest) = do
98103 rethrow (("Error in foreign import declaration " ++ show name ++ ": ") ++) $ do
99104 env <- getEnv
105+ modulePath <- checkModulePath `fmap` get
100106 kind <- kindOf ty
101107 guardWith "Expected kind *" $ kind == Star
102− case M.lookup name (names env) of
108+ case M.lookup (modulePath, name) (names env) of
103109 Just _ -> throwError $ show name ++ " is already defined"
104− Nothing -> putEnv (env { names = M.insert name (ty, Extern) (names env) })
110+ Nothing -> putEnv (env { names = M.insert (modulePath, name) (ty, Extern) (names env) })
105111 typeCheckAll rest
106112typeCheckAll (FixityDeclaration _ name : rest) = do
107113 typeCheckAll rest
108114 env <- getEnv
109− guardWith ("Fixity declaration with no binding: " ++ name) $ M.member (Op name) $ names env
115+ modulePath <- checkModulePath `fmap` get
116+ guardWith ("Fixity declaration with no binding: " ++ name) $ M.member (modulePath, Op name) $ names env
117+typeCheckAll (ModuleDeclaration name decls : rest) = do
118+ withModule name $ typeCheckAll decls
119+ typeCheckAll rest
src/Language/PureScript/TypeChecker/Kinds.hs+38−33
@@ -28,6 +28,7 @@ import Data.Data
2828
2929import Language.PureScript.Types
3030import Language.PureScript.Kinds
31+import Language.PureScript.Names
3132import Language.PureScript.Declarations
3233import Language.PureScript.TypeChecker.Monad
3334import Language.PureScript.Pretty
@@ -61,15 +62,15 @@ emptyKindSolution = KindSolution KUnknown
6162kindOf :: PolyType -> Check Kind
6263kindOf (PolyType idents ty) = do
6364 ns <- replicateM (length idents) fresh
64− (cs, n, m) <- kindConstraints (M.fromList (zip idents ns)) ty
65+ (cs, n, m) <- kindConstraints Nothing (M.fromList (zip idents ns)) ty
6566 solution <- solveKindConstraints cs emptyKindSolution
6667 return $ starIfUnknown $ runKindSolution solution n
6768
68−kindsOf :: Maybe String -> [String] -> [Type] -> Check Kind
69+kindsOf :: Maybe ProperName -> [String] -> [Type] -> Check Kind
6970kindsOf name args ts = do
7071 tyCon <- fresh
7172 nargs <- replicateM (length args) fresh
72− (cs, ns, m) <- kindConstraintsAll (maybe id (`M.insert` tyCon) name $ M.fromList (zip args nargs)) ts
73+ (cs, ns, m) <- kindConstraintsAll (fmap (\pn -> (pn, tyCon)) name) (M.fromList (zip args nargs)) ts
7374 let extraConstraints =
7475 KindConstraint tyCon (foldr (FunKind . KUnknown) Star nargs) DataDeclOrigin
7576 : zipWith (\n arg -> KindConstraint n Star (TypeOrigin arg)) ns ts
@@ -81,61 +82,65 @@ starIfUnknown (KUnknown _) = Star
8182starIfUnknown (FunKind k1 k2) = FunKind (starIfUnknown k1) (starIfUnknown k2)
8283starIfUnknown k = k
8384
84−kindConstraintsAll :: M.Map String Int -> [Type] -> Check ([KindConstraint], [Int], M.Map String Int)
85−kindConstraintsAll m [] = return ([], [], m)
86−kindConstraintsAll m (t:ts) = do
87− (cs, n1, m') <- kindConstraints m t
88− (cs', ns, m'') <- kindConstraintsAll m' ts
85+kindConstraintsAll :: Maybe (ProperName, Int) -> M.Map String Int -> [Type] -> Check ([KindConstraint], [Int], M.Map String Int)
86+kindConstraintsAll _ m [] = return ([], [], m)
87+kindConstraintsAll name m (t:ts) = do
88+ (cs, n1, m') <- kindConstraints name m t
89+ (cs', ns, m'') <- kindConstraintsAll name m' ts
8990 return (KindConstraint n1 Star (TypeOrigin t) : cs ++ cs', n1:ns, m'')
9091
91−kindConstraints :: M.Map String Int -> Type -> Check ([KindConstraint], Int, M.Map String Int)
92−kindConstraints m a@(Array t) = do
92+kindConstraints :: Maybe (ProperName, Int) -> M.Map String Int -> Type -> Check ([KindConstraint], Int, M.Map String Int)
93+kindConstraints name m a@(Array t) = do
9394 me <- fresh
94− (cs, n1, m') <- kindConstraints m t
95+ (cs, n1, m') <- kindConstraints name m t
9596 return (KindConstraint n1 Star (TypeOrigin t) : KindConstraint me Star (TypeOrigin a) : cs, me, m')
96−kindConstraints m o@(Object row) = do
97+kindConstraints name m o@(Object row) = do
9798 me <- fresh
98− (cs, r, m') <- kindConstraintsForRow m row
99+ (cs, r, m') <- kindConstraintsForRow name m row
99100 return (KindConstraint me Star (TypeOrigin o) : KindConstraint r Row (RowOrigin row) : cs, me, m')
100−kindConstraints m f@(Function args ret) = do
101+kindConstraints name m f@(Function args ret) = do
101102 me <- fresh
102− (cs, ns, m') <- kindConstraintsAll m args
103− (cs', retN, m'') <- kindConstraints m' ret
103+ (cs, ns, m') <- kindConstraintsAll name m args
104+ (cs', retN, m'') <- kindConstraints name m' ret
104105 return (KindConstraint retN Star (TypeOrigin ret) : KindConstraint me Star (TypeOrigin f) : zipWith (\n arg -> KindConstraint n Star (TypeOrigin arg)) ns args ++ cs ++ cs', me, m'')
105−kindConstraints m (TypeVar v) =
106+kindConstraints _ m (TypeVar v) =
106107 case M.lookup v m of
107108 Just u -> return ([], u, m)
108109 Nothing -> throwError $ "Unbound type variable " ++ v
109−kindConstraints m c@(TypeConstructor v) = do
110+kindConstraints (Just (name, u)) m c@(TypeConstructor v@(Qualified (ModulePath []) pn)) | name == pn = do
110111 env <- getEnv
111112 me <- fresh
112− case M.lookup v m of
113− Nothing -> case M.lookup v (types env) of
114− Nothing -> throwError $ "Unknown type constructor '" ++ v ++ "'"
115− Just (kind, _) -> return ([KindConstraint me kind (TypeOrigin c)], me, m)
116− Just u -> return ([KindConstraint me (KUnknown u) (TypeOrigin c)], me, m)
117−kindConstraints m a@(TypeApp t1 t2) = do
113+ modulePath <- checkModulePath `fmap` get
114+ return ([KindConstraint me (KUnknown u) (TypeOrigin c)], me, m)
115+kindConstraints name m c@(TypeConstructor v) = do
116+ env <- getEnv
117+ me <- fresh
118+ modulePath <- checkModulePath `fmap` get
119+ case M.lookup (qualify modulePath v) (types env) of
120+ Nothing -> throwError $ "Unknown type constructor '" ++ show v ++ "'"
121+ Just (kind, _) -> return ([KindConstraint me kind (TypeOrigin c)], me, m)
122+kindConstraints name m a@(TypeApp t1 t2) = do
118123 me <- fresh
119− (cs1, n1, m1) <- kindConstraints m t1
120− (cs2, n2, m2) <- kindConstraints m1 t2
124+ (cs1, n1, m1) <- kindConstraints name m t1
125+ (cs2, n2, m2) <- kindConstraints name m1 t2
121126 return (KindConstraint n1 (FunKind (KUnknown n2) (KUnknown me)) (TypeOrigin a) : cs1 ++ cs2, me, m2)
122−kindConstraints m t = do
127+kindConstraints _ m t = do
123128 me <- fresh
124129 return ([KindConstraint me Star (TypeOrigin t)], me, m)
125130
126−kindConstraintsForRow :: M.Map String Int -> Row -> Check ([KindConstraint], Int, M.Map String Int)
127−kindConstraintsForRow m r@(RowVar v) = do
131+kindConstraintsForRow :: Maybe (ProperName, Int) -> M.Map String Int -> Row -> Check ([KindConstraint], Int, M.Map String Int)
132+kindConstraintsForRow _ m r@(RowVar v) = do
128133 me <- case M.lookup v m of
129134 Just u -> return u
130135 Nothing -> fresh
131136 return ([KindConstraint me Row (RowOrigin r)], me, M.insert v me m)
132−kindConstraintsForRow m r@REmpty = do
137+kindConstraintsForRow _ m r@REmpty = do
133138 me <- fresh
134139 return ([KindConstraint me Row (RowOrigin r)], me, m)
135−kindConstraintsForRow m r@(RCons _ ty row) = do
140+kindConstraintsForRow name m r@(RCons _ ty row) = do
136141 me <- fresh
137− (cs1, n1, m1) <- kindConstraints m ty
138− (cs2, n2, m2) <- kindConstraintsForRow m1 row
142+ (cs1, n1, m1) <- kindConstraints name m ty
143+ (cs2, n2, m2) <- kindConstraintsForRow name m1 row
139144 return (KindConstraint me Row (RowOrigin r) : KindConstraint n1 Star (TypeOrigin ty) : KindConstraint n2 Row (RowOrigin r) : cs1 ++ cs2, me, m2)
140145
141146solveKindConstraints :: [KindConstraint] -> KindSolution -> Check KindSolution
src/Language/PureScript/TypeChecker/Monad.hs+27−13
@@ -33,32 +33,38 @@ data NameKind = Value | Extern deriving Show
3333data TypeDeclarationKind = Data | ExternData | TypeSynonym deriving Show
3434
3535data Environment = Environment
36− { names :: M.Map Ident (PolyType, NameKind)
37− , types :: M.Map String (Kind, TypeDeclarationKind)
38− , dataConstructors :: M.Map String PolyType
39− , typeSynonyms :: M.Map String ([String], Type)
40− , members :: M.Map Ident String
41− }
36+ { names :: M.Map (ModulePath, Ident) (PolyType, NameKind)
37+ , types :: M.Map (ModulePath, ProperName) (Kind, TypeDeclarationKind)
38+ , dataConstructors :: M.Map (ModulePath, ProperName) PolyType
39+ , typeSynonyms :: M.Map (ModulePath, ProperName) ([String], Type)
40+ , members :: M.Map (ModulePath, Ident) String
41+ } deriving (Show)
4242
4343emptyEnvironment :: Environment
4444emptyEnvironment = Environment M.empty M.empty M.empty M.empty M.empty
4545
46−newtype Check a = Check { unCheck :: StateT (Environment, Int) (Either String) a } deriving (Functor, Monad, Applicative, MonadPlus, MonadState (Environment, Int), MonadError String)
46+data CheckState = CheckState { checkEnv :: Environment
47+ , checkNextVar :: Int
48+ , checkModulePath :: ModulePath
49+ } deriving (Show)
50+
51+newtype Check a = Check { unCheck :: StateT CheckState (Either String) a }
52+ deriving (Functor, Monad, Applicative, MonadPlus, MonadState CheckState, MonadError String)
4753
4854getEnv :: Check Environment
49−getEnv = fmap fst get
55+getEnv = fmap checkEnv get
5056
5157putEnv :: Environment -> Check ()
52−putEnv env = fmap (first (const env)) get >>= put
58+putEnv env = modify (\s -> s { checkEnv = env })
5359
5460fresh :: Check Int
5561fresh = do
56− (env, n) <- get
57− put (env, n + 1)
58− return n
62+ st <- get
63+ put $ st { checkNextVar = checkNextVar st + 1 }
64+ return $ checkNextVar st
5965
6066check :: Check a -> Either String (a, Environment)
61−check = fmap (second fst) . flip runStateT (emptyEnvironment, 0) . unCheck
67+check = fmap (second checkEnv) . flip runStateT (CheckState emptyEnvironment 0 global) . unCheck
6268
6369guardWith :: (MonadError e m) => e -> Bool -> m ()
6470guardWith _ True = return ()
@@ -66,3 +72,11 @@ guardWith e False = throwError e
6672
6773rethrow :: (MonadError e m) => (e -> e) -> m a -> m a
6874rethrow f = flip catchError $ \e -> throwError (f e)
75+
76+withModule :: ProperName -> Check a -> Check a
77+withModule name act = do
78+ original <- checkModulePath `fmap` get
79+ modify $ \s -> s { checkModulePath = subModule (checkModulePath s) name }
80+ a <- act
81+ modify $ \s -> s { checkModulePath = original }
82+ return a
src/Language/PureScript/TypeChecker/Synonyms.hs+5−4
@@ -21,6 +21,7 @@ module Language.PureScript.TypeChecker.Synonyms (
2121
2222import Language.PureScript.Types
2323import Language.PureScript.Declarations
24+import Language.PureScript.Names
2425
2526import Data.Maybe (fromMaybe)
2627import Data.Data
@@ -30,12 +31,12 @@ import Control.Monad.Writer
3031import Control.Monad.Error
3132import qualified Data.Map as M
3233
33−buildTypeSubstitution :: String -> Int -> Type -> Either String (Maybe Type)
34+buildTypeSubstitution :: Qualified ProperName -> Int -> Type -> Either String (Maybe Type)
3435buildTypeSubstitution name n = go n []
3536 where
3637 go :: Int -> [Type] -> Type -> Either String (Maybe Type)
3738 go 0 args (TypeConstructor ctor) | name == ctor = return (Just $ SaturatedTypeSynonym ctor args)
38− go n _ (TypeConstructor ctor) | n > 0 && name == ctor = throwError $ "Partially applied type synonym " ++ name
39+ go n _ (TypeConstructor ctor) | n > 0 && name == ctor = throwError $ "Partially applied type synonym " ++ show name
3940 go n args (TypeApp f arg) = go (n - 1) (arg:args) f
4041 go _ _ _ = return Nothing
4142
@@ -44,12 +45,12 @@ everywhereM' f x = do
4445 y <- f x
4546 gmapM (everywhereM' f) y
4647
47−saturateTypeSynonym :: (Data d) => String -> Int -> d -> Either String d
48+saturateTypeSynonym :: (Data d) => Qualified ProperName -> Int -> d -> Either String d
4849saturateTypeSynonym name n = everywhereM' (mkM replace)
4950 where
5051 replace t = fmap (fromMaybe t) $ buildTypeSubstitution name n t
5152
52−saturateAllTypeSynonyms :: (Data d) => [(String, Int)] -> d -> Either String d
53+saturateAllTypeSynonyms :: (Data d) => [(Qualified ProperName, Int)] -> d -> Either String d
5354saturateAllTypeSynonyms syns d = foldM (\d (name, n) -> saturateTypeSynonym name n d) d syns
5455
5556
src/Language/PureScript/TypeChecker/Types.hs+35−22
@@ -192,7 +192,7 @@ replaceVarsWithUnknowns idents = flip evalStateT M.empty . everywhereM (flip ext
192192replaceAllTypeSynonyms :: (D.Data d) => d -> Check d
193193replaceAllTypeSynonyms d = do
194194 env <- getEnv
195− let syns = map (\(name, (args, _)) -> (name, length args)) . M.toList $ typeSynonyms env
195+ let syns = map (\((path, name), (args, _)) -> (Qualified path name, length args)) . M.toList $ typeSynonyms env
196196 either throwError return $ saturateAllTypeSynonyms syns d
197197
198198desaturateAllTypeSynonyms :: (D.Data d) => d -> d
@@ -306,19 +306,25 @@ typeConstraints m v@(App f xs) = do
306306 let (cs2, ns) = (concatMap fst &&& map snd) all
307307 me <- fresh
308308 return (TypeConstraint n1 (Function (map TUnknown ns) (TUnknown me)) (ValueOrigin v) : cs1 ++ cs2, me)
309−typeConstraints m v@(Var var) =
310− case M.lookup var m of
311− Nothing -> do
312− env <- getEnv
313− case M.lookup var (names env) of
314− Nothing -> throwError $ show var ++ " is undefined"
315− Just (PolyType idents ty, _) -> do
309+typeConstraints m v@(Var var@(Qualified mp name)) = do
310+ case mp of
311+ ModulePath [] ->
312+ case M.lookup name m of
313+ Just u -> do
316314 me <- fresh
317− replaced <- replaceVarsWithUnknowns idents ty
318− return ([TypeConstraint me replaced (ValueOrigin v)], me)
319− Just u -> do
320− me <- fresh
321− return ([TypeConstraint u (TUnknown me) (ValueOrigin v)], me)
315+ return ([TypeConstraint u (TUnknown me) (ValueOrigin v)], me)
316+ Nothing -> lookupGlobal
317+ _ -> lookupGlobal
318+ where
319+ lookupGlobal = do
320+ env <- getEnv
321+ modulePath <- checkModulePath `fmap` get
322+ case M.lookup (qualify modulePath var) (names env) of
323+ Nothing -> throwError $ show var ++ " is undefined"
324+ Just (PolyType idents ty, _) -> do
325+ me <- fresh
326+ replaced <- replaceVarsWithUnknowns idents ty
327+ return ([TypeConstraint me replaced (ValueOrigin v)], me)
322328typeConstraints m (Block ss) = do
323329 ret <- fresh
324330 (cs, allCodePathsReturn, _) <- typeConstraintsForBlock m M.empty ret ss
@@ -326,8 +332,9 @@ typeConstraints m (Block ss) = do
326332 return (cs, ret)
327333typeConstraints m v@(Constructor c) = do
328334 env <- getEnv
329− case M.lookup c (dataConstructors env) of
330− Nothing -> throwError $ "Constructor " ++ c ++ " is undefined"
335+ modulePath <- checkModulePath `fmap` get
336+ case M.lookup (qualify modulePath c) (dataConstructors env) of
337+ Nothing -> throwError $ "Constructor " ++ show c ++ " is undefined"
331338 Just (PolyType idents ty) -> do
332339 me <- fresh
333340 replaced <- replaceVarsWithUnknowns idents ty
@@ -394,21 +401,23 @@ typeConstraintsForBinder val b@(VarBinder name) = do
394401 return ([TypeConstraint me (TUnknown val) (BinderOrigin b)], M.singleton name me)
395402typeConstraintsForBinder val b@(NullaryBinder ctor) = do
396403 env <- getEnv
397− case M.lookup ctor (dataConstructors env) of
404+ modulePath <- checkModulePath `fmap` get
405+ case M.lookup (qualify modulePath ctor) (dataConstructors env) of
398406 Just (PolyType args ret) -> do
399407 ret' <- replaceVarsWithUnknowns args ret
400408 return ([TypeConstraint val ret' (BinderOrigin b)], M.empty)
401− _ -> throwError $ "Constructor " ++ ctor ++ " is not defined"
409+ _ -> throwError $ "Constructor " ++ show ctor ++ " is not defined"
402410typeConstraintsForBinder val b@(UnaryBinder ctor binder) = do
403411 env <- getEnv
404− case M.lookup ctor (dataConstructors env) of
412+ modulePath <- checkModulePath `fmap` get
413+ case M.lookup (qualify modulePath ctor) (dataConstructors env) of
405414 Just (PolyType idents f@(Function [_] _)) -> do
406415 obj <- fresh
407416 (Function [ty] ret) <- replaceVarsWithUnknowns idents f
408417 (cs, m1) <- typeConstraintsForBinder obj binder
409418 return (TypeConstraint val ret (BinderOrigin b) : TypeConstraint obj ty (BinderOrigin b) : cs, m1)
410− Just _ -> throwError $ ctor ++ " is not a unary constructor"
411− _ -> throwError $ "Constructor " ++ ctor ++ " is not defined"
419+ Just _ -> throwError $ show ctor ++ " is not a unary constructor"
420+ _ -> throwError $ "Constructor " ++ show ctor ++ " is not defined"
412421typeConstraintsForBinder val b@(ObjectBinder props) = do
413422 row <- fresh
414423 rest <- fresh
@@ -573,7 +582,8 @@ unifyTypes o (SaturatedTypeSynonym name1 args1) (SaturatedTypeSynonym name2 args
573582 fmap concat $ zipWithM (unifyTypes o) args1 args2
574583unifyTypes o (SaturatedTypeSynonym name args) ty = do
575584 env <- getEnv
576− case M.lookup name (typeSynonyms env) of
585+ modulePath <- checkModulePath `fmap` get
586+ case M.lookup (qualify modulePath name) (typeSynonyms env) of
577587 Just (synArgs, body) -> do
578588 let m = M.fromList $ zip synArgs args
579589 let replaced = replaceTypeVars m body
@@ -591,7 +601,10 @@ unifyTypes o (Function args1 ret1) (Function args2 ret2) = do
591601 cs2 <- unifyTypes o ret1 ret2
592602 return $ cs1 ++ cs2
593603unifyTypes _ (TypeVar v1) (TypeVar v2) | v1 == v2 = return []
594−unifyTypes _ (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = return []
604+unifyTypes _ (TypeConstructor c1) (TypeConstructor c2) = do
605+ modulePath <- checkModulePath `fmap` get
606+ guardWith ("Cannot unify " ++ show c1 ++ " with " ++ show c2 ++ ".") (qualify modulePath c1 == qualify modulePath c2)
607+ return []
595608unifyTypes o (TypeApp t1 t2) (TypeApp t3 t4) = do
596609 cs1 <- unifyTypes o t1 t3
597610 cs2 <- unifyTypes o t2 t4
src/Language/PureScript/Types.hs+3−2
@@ -17,6 +17,7 @@
1717module Language.PureScript.Types where
1818
1919import Data.Data
20+import Language.PureScript.Names
2021
2122data Type
2223 = TUnknown Int
@@ -27,9 +28,9 @@ data Type
2728 | Object Row
2829 | Function [Type] Type
2930 | TypeVar String
30− | TypeConstructor String
31+ | TypeConstructor (Qualified ProperName)
3132 | TypeApp Type Type
32− | SaturatedTypeSynonym String [Type] deriving (Show, Eq, Data, Typeable)
33+ | SaturatedTypeSynonym (Qualified ProperName) [Type] deriving (Show, Eq, Data, Typeable)
3334
3435data PolyType = PolyType [String] Type deriving (Show, Eq, Data, Typeable)
3536
src/Language/PureScript/Values.hs+4−4
@@ -61,10 +61,10 @@ data Value
6161 | ObjectUpdate Value [(String, Value)]
6262 | Abs [Ident] Value
6363 | App Value [Value]
64− | Var Ident
64+ | Var (Qualified Ident)
6565 | IfThenElse Value Value Value
6666 | Block [Statement]
67− | Constructor String
67+ | Constructor (Qualified ProperName)
6868 | Case Value [(Binder, Value)]
6969 | TypedValue Value PolyType deriving (Show, Data, Typeable)
7070
@@ -89,8 +89,8 @@ data Binder
8989 | StringBinder String
9090 | NumberBinder (Either Integer Double)
9191 | VarBinder Ident
92− | NullaryBinder String
93− | UnaryBinder String Binder
92+ | NullaryBinder (Qualified ProperName)
93+ | UnaryBinder (Qualified ProperName) Binder
9494 | ObjectBinder [(String, Binder)]
9595 | ArrayBinder [Binder] (Maybe Binder)
9696 | NamedBinder Ident Binder
src/Main.hs+2−2
@@ -40,13 +40,13 @@ compile inputFiles outputFile externsFile = do
4040 U.putStrLn typeError
4141 exitFailure
4242 Right (_, env) -> do
43− let js = intercalate "; " . map (prettyPrintJS . optimize) . concat . mapMaybe (declToJs) $ decls
43+ let js = intercalate "; " . map (prettyPrintJS . optimize) . concat . mapMaybe (declToJs Nothing global) $ decls
4444 case outputFile of
4545 Just path -> U.writeFile path js
4646 Nothing -> U.putStrLn js
4747 case externsFile of
4848 Nothing -> return ()
49− Just filePath -> U.writeFile filePath $ intercalate "\n" $ mapMaybe (externToPs env) decls
49+ Just filePath -> U.writeFile filePath $ intercalate "\n" $ mapMaybe (externToPs 0 global env) decls
5050 exitSuccess
5151
5252inputFiles :: Term [FilePath]