git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Initial modules implementation
34f1a08Phil Freeman
examples/passing/Module.psnew file+22
compare with golang
unifiedsplit
@@ -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 (
17) where
17) where
18
18
19import Data.List (intercalate)
19import Data.List (intercalate)
20+import Data.Maybe (mapMaybe)
20import qualified Data.Map as M
21import qualified Data.Map as M
21import Language.PureScript.Declarations
22import Language.PureScript.Declarations
22import Language.PureScript.TypeChecker.Monad
23import Language.PureScript.TypeChecker.Monad
23import Language.PureScript.Pretty
24import Language.PureScript.Pretty
25+import Language.PureScript.Names
24
26
25−externToPs :: Environment -> Declaration -> Maybe String
27+externToPs :: Int -> ModulePath -> Environment -> Declaration -> Maybe String
26−externToPs env (ValueDeclaration name _) = do
28+externToPs indent path env (ValueDeclaration name _) = do
27− (ty, _) <- M.lookup name $ names env
29+ (ty, _) <- M.lookup (path, name) $ names env
28− return $ "foreign import " ++ show name ++ " :: " ++ prettyPrintPolyType ty
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
29−externToPs env (ExternMemberDeclaration member name ty) =
34+externToPs indent path env (ExternMemberDeclaration member name ty) =
30− return $ "foreign import member " ++ show member ++ " " ++ show name ++ " :: " ++ prettyPrintPolyType ty
35+ return $ replicate indent ' ' ++ "foreign import member " ++ show member ++ " " ++ show name ++ " :: " ++ prettyPrintPolyType ty
31−externToPs env (ExternDataDeclaration name kind) =
36+externToPs indent path env (ExternDataDeclaration name kind) =
32− return $ "foreign import data " ++ name ++ " :: " ++ prettyPrintKind kind
37+ return $ replicate indent ' ' ++ "foreign import data " ++ show name ++ " :: " ++ prettyPrintKind kind
33−externToPs env (TypeSynonymDeclaration name args ty) =
38+externToPs indent path env (TypeSynonymDeclaration name args ty) =
34− return $ "type " ++ name ++ " " ++ unwords args ++ " = " ++ prettyPrintType 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)
35−externToPs _ _ = Nothing
42+externToPs _ _ _ _ = Nothing
src/Language/PureScript/CodeGen/JS.hs+97−73
@@ -18,7 +18,7 @@ module Language.PureScript.CodeGen.JS (
18) where
18) where
19
19
20import Data.Char
20import Data.Char
21−import Data.Maybe (fromMaybe)
21+import Data.Maybe (fromMaybe, mapMaybe)
22import Data.List (intercalate)
22import Data.List (intercalate)
23import qualified Control.Arrow as A
23import qualified Control.Arrow as A
24import Control.Arrow ((<+>), second)
24import Control.Arrow ((<+>), second)
@@ -33,76 +33,100 @@ import Language.PureScript.Pretty.Common
33import Language.PureScript.CodeGen.Monad
33import Language.PureScript.CodeGen.Monad
34import Language.PureScript.CodeGen.JS.AST as AST
34import Language.PureScript.CodeGen.JS.AST as AST
35
35
36−declToJs :: Declaration -> Maybe [JS]
36+declToJs :: Maybe Ident -> ModulePath -> Declaration -> Maybe [JS]
37+declToJs mod mp (ValueDeclaration ident (Abs args ret)) =
37−declToJs (ValueDeclaration ident (Abs args ret)) = Just [JSFunction (Just ident) args (JSBlock [JSReturn (valueToJs 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) =
38−declToJs (ValueDeclaration ident val) = Just [JSVariableIntroduction ident (valueToJs val)]
41+ Just $ JSVariableIntroduction ident (Just (valueToJs mp val)) :
42+ maybe [] (return . setProperty (show ident) (JSVar ident)) mod
39−declToJs (ExternMemberDeclaration member ident _) =
43+declToJs mod _ (ExternMemberDeclaration member ident _) =
40− Just [JSFunction (Just ident) [Ident "value"] (JSBlock [JSReturn (JSAccessor member (JSVar (Ident "value")))])]
44+ Just $ JSFunction (Just ident) [Ident "value"] (JSBlock [JSReturn (JSAccessor member (JSVar (Ident "value")))]) :
45+ maybe [] (return . setProperty (show ident) (JSVar ident)) mod
41−declToJs (DataDeclaration _ _ ctors) =
46+declToJs mod mp (DataDeclaration _ _ ctors) =
42− Just $ flip map ctors $ \(ctor, maybeTy) ->
47+ Just $ flip concatMap ctors $ \(pn@(ProperName ctor), maybeTy) ->
48+ let
49+ ctorJs =
43− case maybeTy of
50+ case maybeTy of
44− Nothing -> JSVariableIntroduction (Ident ctor) (JSObjectLiteral [ ("ctor", JSStringLiteral ctor) ])
51+ Nothing -> JSVariableIntroduction (Ident ctor) (Just (JSObjectLiteral [ ("ctor", JSStringLiteral (show (Qualified mp pn))) ]))
45− Just _ -> JSFunction (Just (Ident ctor)) [Ident "value"]
52+ Just _ -> JSFunction (Just (Ident ctor)) [Ident "value"]
46− (JSBlock [JSReturn
53+ (JSBlock [JSReturn
47− (JSObjectLiteral [ ("ctor", JSStringLiteral ctor)
54+ (JSObjectLiteral [ ("ctor", JSStringLiteral (show (Qualified mp pn)))
48− , ("value", JSVar (Ident "value")) ])])
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
49−declToJs _ = Nothing
64+declToJs _ _ _ = Nothing
50
65
51−valueToJs :: Value -> JS
66+setProperty :: String -> JS -> Ident -> JS
52−valueToJs (NumericLiteral n) = JSNumericLiteral n
67+setProperty prop val mod = JSAssignment (JSAssignProperty prop (JSAssignVariable mod)) val
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
70
68
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+
71−bindersToJs :: [(Binder, Value)] -> JS -> Gen JS
95+bindersToJs :: ModulePath -> [(Binder, Value)] -> JS -> Gen JS
72−bindersToJs binders val = do
96+bindersToJs m binders val = do
73 valName <- fresh
97 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
75 return $ JSApp (JSFunction Nothing [Ident valName] (JSBlock (concat jss ++ [JSThrow (JSStringLiteral "Failed pattern match")])))
99 return $ JSApp (JSFunction Nothing [Ident valName] (JSBlock (concat jss ++ [JSThrow (JSStringLiteral "Failed pattern match")])))
76 [val]
100 [val]
77
101
78−binderToJs :: String -> [JS] -> Binder -> Gen [JS]
102+binderToJs :: ModulePath -> String -> [JS] -> Binder -> Gen [JS]
79−binderToJs varName done NullBinder = return done
103+binderToJs _ varName done NullBinder = return done
80−binderToJs varName done (StringBinder str) =
104+binderToJs _ varName done (StringBinder str) =
81 return [JSIfElse (JSBinary EqualTo (JSVar (Ident varName)) (JSStringLiteral str)) (JSBlock done) Nothing]
105 return [JSIfElse (JSBinary EqualTo (JSVar (Ident varName)) (JSStringLiteral str)) (JSBlock done) Nothing]
82−binderToJs varName done (NumberBinder num) =
106+binderToJs _ varName done (NumberBinder num) =
83 return [JSIfElse (JSBinary EqualTo (JSVar (Ident varName)) (JSNumericLiteral num)) (JSBlock done) Nothing]
107 return [JSIfElse (JSBinary EqualTo (JSVar (Ident varName)) (JSNumericLiteral num)) (JSBlock done) Nothing]
84−binderToJs varName done (BooleanBinder True) =
108+binderToJs _ varName done (BooleanBinder True) =
85 return [JSIfElse (JSVar (Ident varName)) (JSBlock done) Nothing]
109 return [JSIfElse (JSVar (Ident varName)) (JSBlock done) Nothing]
86−binderToJs varName done (BooleanBinder False) =
110+binderToJs _ varName done (BooleanBinder False) =
87 return [JSIfElse (JSUnary Not (JSVar (Ident varName))) (JSBlock done) Nothing]
111 return [JSIfElse (JSUnary Not (JSVar (Ident varName))) (JSBlock done) Nothing]
88−binderToJs varName done (VarBinder ident) =
112+binderToJs _ varName done (VarBinder ident) =
89− return (JSVariableIntroduction ident (JSVar (Ident varName)) : done)
113+ return (JSVariableIntroduction ident (Just (JSVar (Ident varName))) : done)
90−binderToJs varName done (NullaryBinder ctor) =
114+binderToJs m varName done (NullaryBinder ctor) =
91− return [JSIfElse (JSBinary EqualTo (JSAccessor "ctor" (JSVar (Ident varName))) (JSStringLiteral ctor)) (JSBlock done) Nothing]
115+ return [JSIfElse (JSBinary EqualTo (JSAccessor "ctor" (JSVar (Ident varName))) (JSStringLiteral (show (uncurry Qualified $ qualify m ctor)))) (JSBlock done) Nothing]
92−binderToJs varName done (UnaryBinder ctor b) = do
116+binderToJs m varName done (UnaryBinder ctor b) = do
93 value <- fresh
117 value <- fresh
94− js <- binderToJs value done b
118+ js <- binderToJs m 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]
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]
96−binderToJs varName done (ObjectBinder bs) = go done bs
120+binderToJs m varName done (ObjectBinder bs) = go done bs
97 where
121 where
98 go :: [JS] -> [(String, Binder)] -> Gen [JS]
122 go :: [JS] -> [(String, Binder)] -> Gen [JS]
99 go done [] = return done
123 go done [] = return done
100 go done ((prop, binder):bs) = do
124 go done ((prop, binder):bs) = do
101 propVar <- fresh
125 propVar <- fresh
102 done' <- go done bs
126 done' <- go done bs
103− js <- binderToJs propVar done' binder
127+ js <- binderToJs m propVar done' binder
104− return (JSVariableIntroduction (Ident propVar) (JSAccessor prop (JSVar (Ident varName))) : js)
128+ return (JSVariableIntroduction (Ident propVar) (Just (JSAccessor prop (JSVar (Ident varName)))) : js)
105−binderToJs varName done (ArrayBinder bs rest) = do
129+binderToJs m varName done (ArrayBinder bs rest) = do
106 js <- go done rest 0 bs
130 js <- go done rest 0 bs
107 return [JSIfElse (JSBinary cmp (JSAccessor "length" (JSVar (Ident varName))) (JSNumericLiteral (Left (fromIntegral $ length bs)))) (JSBlock js) Nothing]
131 return [JSIfElse (JSBinary cmp (JSAccessor "length" (JSVar (Ident varName))) (JSNumericLiteral (Left (fromIntegral $ length bs)))) (JSBlock js) Nothing]
108 where
132 where
@@ -112,31 +136,31 @@ binderToJs varName done (ArrayBinder bs rest) = do
112 go done Nothing _ [] = return done
136 go done Nothing _ [] = return done
113 go done (Just binder) index [] = do
137 go done (Just binder) index [] = do
114 restVar <- fresh
138 restVar <- fresh
115− js <- binderToJs restVar done binder
139+ js <- binderToJs m restVar done binder
116− return (JSVariableIntroduction (Ident restVar) (JSApp (JSAccessor "slice" (JSVar (Ident varName))) [JSNumericLiteral (Left index)]) : js)
140+ return (JSVariableIntroduction (Ident restVar) (Just (JSApp (JSAccessor "slice" (JSVar (Ident varName))) [JSNumericLiteral (Left index)])) : js)
117 go done rest index (binder:bs) = do
141 go done rest index (binder:bs) = do
118 elVar <- fresh
142 elVar <- fresh
119 done' <- go done rest (index + 1) bs
143 done' <- go done rest (index + 1) bs
120− js <- binderToJs elVar done' binder
144+ js <- binderToJs m elVar done' binder
121− return (JSVariableIntroduction (Ident elVar) (JSIndexer (JSNumericLiteral (Left index)) (JSVar (Ident varName))) : js)
145+ return (JSVariableIntroduction (Ident elVar) (Just (JSIndexer (JSNumericLiteral (Left index)) (JSVar (Ident varName)))) : js)
122−binderToJs varName done (NamedBinder ident binder) = do
146+binderToJs m varName done (NamedBinder ident binder) = do
123− js <- binderToJs varName done binder
147+ js <- binderToJs m varName done binder
124− return (JSVariableIntroduction ident (JSVar (Ident varName)) : js)
148+ return (JSVariableIntroduction ident (Just (JSVar (Ident varName))) : js)
125−binderToJs varName done (GuardedBinder cond binder) = binderToJs varName done' binder
149+binderToJs m varName done (GuardedBinder cond binder) = binderToJs m varName done' binder
126 where
150 where
127− done' = [JSIfElse (valueToJs cond) (JSBlock done) Nothing]
151+ done' = [JSIfElse (valueToJs m cond) (JSBlock done) Nothing]
128
152
129−statementToJs :: Statement -> JS
153+statementToJs :: ModulePath -> Statement -> JS
130−statementToJs (VariableIntroduction ident value) = JSVariableIntroduction ident (valueToJs value)
154+statementToJs m (VariableIntroduction ident value) = JSVariableIntroduction ident (Just (valueToJs m value))
131−statementToJs (Assignment target value) = JSAssignment target (valueToJs value)
155+statementToJs m (Assignment target value) = JSAssignment (JSAssignVariable target) (valueToJs m value)
132−statementToJs (While cond sts) = JSWhile (valueToJs cond) (JSBlock (map statementToJs sts))
156+statementToJs m (While cond sts) = JSWhile (valueToJs m cond) (JSBlock (map (statementToJs m) sts))
133−statementToJs (For ident start end sts) = JSFor ident (valueToJs start) (valueToJs end) (JSBlock (map statementToJs sts))
157+statementToJs m (For ident start end sts) = JSFor ident (valueToJs m start) (valueToJs m end) (JSBlock (map (statementToJs m) sts))
134−statementToJs (ForEach ident arr sts) = JSApp (JSAccessor "forEach" (valueToJs arr)) [JSFunction Nothing [ident] (JSBlock (map statementToJs sts))]
158+statementToJs m (ForEach ident arr sts) = JSApp (JSAccessor "forEach" (valueToJs m arr)) [JSFunction Nothing [ident] (JSBlock (map (statementToJs m) sts))]
135−statementToJs (If ifst) = ifToJs ifst
159+statementToJs m (If ifst) = ifToJs ifst
136 where
160 where
137 ifToJs :: IfStatement -> JS
161 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)
139 elseToJs :: ElseStatement -> JS
163 elseToJs :: ElseStatement -> JS
140− elseToJs (Else sts) = JSBlock (map statementToJs sts)
164+ elseToJs (Else sts) = JSBlock (map (statementToJs m) sts)
141 elseToJs (ElseIf ifst) = ifToJs ifst
165 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
36 | JSVar Ident
36 | JSVar Ident
37 | JSConditional JS JS JS
37 | JSConditional JS JS JS
38 | JSBlock [JS]
38 | JSBlock [JS]
39− | JSVariableIntroduction Ident JS
39+ | JSVariableIntroduction Ident (Maybe JS)
40− | JSAssignment Ident JS
40+ | JSAssignment JSAssignment JS
41 | JSWhile JS JS
41 | JSWhile JS JS
42 | JSFor Ident JS JS JS
42 | JSFor Ident JS JS JS
43 | JSIfElse JS JS (Maybe JS)
43 | JSIfElse JS JS (Maybe JS)
44 | JSReturn JS
44 | JSReturn JS
45 | JSThrow JS deriving (Show, Data, Typeable)
45 | 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)
30data Fixity = Fixity Associativity Precedence deriving (Show, D.Data, D.Typeable)
30data Fixity = Fixity Associativity Precedence deriving (Show, D.Data, D.Typeable)
31
31
32data Declaration
32data Declaration
33− = DataDeclaration String [String] [(String, Maybe Type)]
33+ = DataDeclaration ProperName [String] [(ProperName, Maybe Type)]
34− | TypeSynonymDeclaration String [String] Type
34+ | TypeSynonymDeclaration ProperName [String] Type
35 | TypeDeclaration Ident PolyType
35 | TypeDeclaration Ident PolyType
36 | ValueDeclaration Ident Value
36 | ValueDeclaration Ident Value
37 | ExternDeclaration Ident PolyType
37 | ExternDeclaration Ident PolyType
38 | ExternMemberDeclaration String Ident PolyType
38 | ExternMemberDeclaration String Ident PolyType
39− | ExternDataDeclaration String Kind
39+ | ExternDataDeclaration ProperName Kind
40− | FixityDeclaration Fixity String deriving (Show, D.Data, D.Typeable)
40+ | FixityDeclaration Fixity String
41+ | ModuleDeclaration ProperName [Declaration] deriving (Show, D.Data, D.Typeable)
src/Language/PureScript/Names.hs+22
@@ -17,6 +17,7 @@
17module Language.PureScript.Names where
17module Language.PureScript.Names where
18
18
19import Data.Data
19import Data.Data
20+import Data.List (intercalate)
20
21
21data Ident = Ident String | Op String deriving (Eq, Ord, Data, Typeable)
22data Ident = Ident String | Op String deriving (Eq, Ord, Data, Typeable)
22
23
@@ -24,3 +25,24 @@ instance Show Ident where
24 show (Ident s) = s
25 show (Ident s) = s
25 show (Op op) = '(':op ++ ")"
26 show (Op op) = '(':op ++ ")"
26
27
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
35isReassigned var1 = everything (||) (mkQ False check)
35isReassigned var1 = everything (||) (mkQ False check)
36 where
36 where
37 check :: JS -> Bool
37 check :: JS -> Bool
38− check (JSAssignment var2 _) | var1 == var2 = True
38+ check (JSAssignment (JSAssignVariable var2) _) | var1 == var2 = True
39 check _ = False
39 check _ = False
40
40
41isUsed :: (Data d) => Ident -> d -> Bool
41isUsed :: (Data d) => Ident -> d -> Bool
@@ -43,8 +43,11 @@ isUsed var1 = everything (||) (mkQ False check)
43 where
43 where
44 check :: JS -> Bool
44 check :: JS -> Bool
45 check (JSVar var2) | var1 == var2 = True
45 check (JSVar var2) | var1 == var2 = True
46− check (JSAssignment var2 _) | var1 == var2 = True
46+ check (JSAssignment target _) | var1 == targetVariable target = True
47 check _ = False
47 check _ = False
48+ targetVariable :: JSAssignment -> Ident
49+ targetVariable (JSAssignVariable var) = var
50+ targetVariable (JSAssignProperty _ tgt) = targetVariable tgt
48
51
49shouldInline :: JS -> Bool
52shouldInline :: JS -> Bool
50shouldInline (JSVar _) = True
53shouldInline (JSVar _) = True
@@ -63,7 +66,7 @@ inlineVariables = everywhere (mkT removeFromBlock)
63 removeFromBlock js = js
66 removeFromBlock js = js
64 go :: [JS] -> [JS]
67 go :: [JS] -> [JS]
65 go [] = []
68 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)
67 go (s:sts) = s : go sts
70 go (s:sts) = s : go sts
68
71
69removeUnusedVariables :: JS -> JS
72removeUnusedVariables :: JS -> JS
src/Language/PureScript/Parser/Common.hs+12−3
@@ -72,7 +72,8 @@ reservedNames = [ "case"
72 , "String"
72 , "String"
73 , "Boolean"
73 , "Boolean"
74 , "infixl"
74 , "infixl"
75− , "infixr" ]
75+ , "infixr"
76+ , "module" ]
76
77
77reservedOpNames :: [String]
78reservedOpNames :: [String]
78reservedOpNames = [ "!", "~", "-", "<=", ">=", "<", ">", "*", "/", "%", "++", "+", "<<", ">>>", ">>"
79reservedOpNames = [ "!", "~", "-", "<=", ">=", "<", ">", "*", "/", "%", "++", "+", "<<", ">>>", ">>"
@@ -133,8 +134,16 @@ natural = PT.natural tokenParser
133tick :: P.Parsec String u Char
134tick :: P.Parsec String u Char
134tick = lexeme $ P.char '`'
135tick = lexeme $ P.char '`'
135
136
136−properName :: P.Parsec String u String
137+properName :: P.Parsec String u ProperName
137−properName = lexeme $ P.try ((:) <$> P.upper <*> many (PT.identLetter langDef) P.<?> "name")
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
138
147
139integerOrFloat :: P.Parsec String u (Either Integer Double)
148integerOrFloat :: P.Parsec String u (Either Integer Double)
140integerOrFloat = (Left <$> P.try (PT.natural tokenParser) <|>
149integerOrFloat = (Left <$> P.try (PT.natural tokenParser) <|>
src/Language/PureScript/Parser/Declarations.hs+12−2
@@ -90,6 +90,15 @@ parseFixityDeclaration = do
90 P.modifyState $ \st -> st { fixities = M.insert name fixity current }
90 P.modifyState $ \st -> st { fixities = M.insert name fixity current }
91 return $ FixityDeclaration fixity name
91 return $ FixityDeclaration fixity name
92
92
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+
93parseDeclaration :: P.Parsec String ParseState Declaration
102parseDeclaration :: P.Parsec String ParseState Declaration
94parseDeclaration = P.choice
103parseDeclaration = P.choice
95 [ parseDataDeclaration
104 [ parseDataDeclaration
@@ -97,7 +106,8 @@ parseDeclaration = P.choice
97 , parseTypeSynonymDeclaration
106 , parseTypeSynonymDeclaration
98 , parseValueDeclaration
107 , parseValueDeclaration
99 , parseExternDeclaration
108 , parseExternDeclaration
100− , parseFixityDeclaration ] P.<?> "declaration"
109+ , parseFixityDeclaration
110+ , parseModuleDeclaration ] P.<?> "declaration"
101
111
102parseDeclarations :: P.Parsec String ParseState [Declaration]
112parseDeclarations :: 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
52parseTypeVariable = TypeVar <$> identifier
52parseTypeVariable = TypeVar <$> identifier
53
53
54parseTypeConstructor :: P.Parsec String ParseState Type
54parseTypeConstructor :: P.Parsec String ParseState Type
55−parseTypeConstructor = TypeConstructor <$> properName
55+parseTypeConstructor = TypeConstructor <$> parseQualified properName
56
56
57parseTypeAtom :: P.Parsec String ParseState Type
57parseTypeAtom :: P.Parsec String ParseState Type
58parseTypeAtom = indented *> P.choice (map P.try
58parseTypeAtom = indented *> P.choice (map P.try
src/Language/PureScript/Parser/Values.hs+7−7
@@ -79,10 +79,10 @@ parseApp = App <$> parseValue
79 <*> (C.indented *> C.parens (parseValue `P.sepBy` (C.indented *> C.comma)))
79 <*> (C.indented *> C.parens (parseValue `P.sepBy` (C.indented *> C.comma)))
80
80
81parseVar :: P.Parsec String ParseState Value
81parseVar :: P.Parsec String ParseState Value
82−parseVar = Var <$> C.parseIdent
82+parseVar = Var <$> C.parseQualified C.parseIdent
83
83
84parseConstructor :: P.Parsec String ParseState Value
84parseConstructor :: P.Parsec String ParseState Value
85−parseConstructor = Constructor <$> C.properName
85+parseConstructor = Constructor <$> C.parseQualified C.properName
86
86
87parseCase :: P.Parsec String ParseState Value
87parseCase :: P.Parsec String ParseState Value
88parseCase = Case <$> P.between (P.try (C.reserved "case")) (C.indented *> C.reserved "of") parseValue
88parseCase = Case <$> P.between (P.try (C.reserved "case")) (C.indented *> C.reserved "of") parseValue
@@ -112,8 +112,8 @@ parseValueAtom = C.indented *> P.choice
112 , parseArrayLiteral
112 , parseArrayLiteral
113 , parseObjectLiteral
113 , parseObjectLiteral
114 , parseAbs
114 , parseAbs
115− , P.try parseVar
116 , P.try parseConstructor
115 , P.try parseConstructor
116+ , P.try parseVar
117 , parseBlock
117 , parseBlock
118 , parseCase
118 , parseCase
119 , parseIfThenElse
119 , parseIfThenElse
@@ -145,7 +145,7 @@ parseValue = do
145 , Prefix $ C.lexeme (P.try $ C.indented *> C.reservedOp "-") >> return (Unary Negate)
145 , Prefix $ C.lexeme (P.try $ C.indented *> C.reservedOp "-") >> return (Unary Negate)
146 , Prefix $ C.lexeme (P.try $ C.indented *> C.reservedOp "+") >> return id ]
146 , Prefix $ C.lexeme (P.try $ C.indented *> C.reservedOp "+") >> return id ]
147 ] ++ customOperatorTable user ++
147 ] ++ 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 ]
149 , [ Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "!!") >> return (flip Indexer)) AssocRight ]
149 , [ Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "!!") >> return (flip Indexer)) AssocRight ]
150 , [ Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "<=") >> return (Binary LessThanOrEqualTo)) AssocRight
150 , [ Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "<=") >> return (Binary LessThanOrEqualTo)) AssocRight
151 , Infix (C.lexeme (P.try $ C.indented *> C.reservedOp ">=") >> return (Binary GreaterThanOrEqualTo)) AssocRight ]
151 , Infix (C.lexeme (P.try $ C.indented *> C.reservedOp ">=") >> return (Binary GreaterThanOrEqualTo)) AssocRight ]
@@ -181,7 +181,7 @@ customOperatorTable fixities =
181 C.lexeme $ P.try $ do
181 C.lexeme $ P.try $ do
182 C.indented
182 C.indented
183 C.reservedOp name P.<?> "operator"
183 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])
185 levels
185 levels
186
186
187toAssoc :: Associativity -> Assoc
187toAssoc :: Associativity -> Assoc
@@ -257,10 +257,10 @@ parseVarBinder :: P.Parsec String ParseState Binder
257parseVarBinder = VarBinder <$> C.parseIdent
257parseVarBinder = VarBinder <$> C.parseIdent
258
258
259parseNullaryBinder :: P.Parsec String ParseState Binder
259parseNullaryBinder :: P.Parsec String ParseState Binder
260−parseNullaryBinder = NullaryBinder <$> C.lexeme C.properName
260+parseNullaryBinder = NullaryBinder <$> C.lexeme (C.parseQualified C.properName)
261
261
262parseUnaryBinder :: P.Parsec String ParseState Binder
262parseUnaryBinder :: 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)
264
264
265parseObjectBinder :: P.Parsec String ParseState Binder
265parseObjectBinder :: P.Parsec String ParseState Binder
266parseObjectBinder = ObjectBinder <$> C.braces ((C.indented *> parseIdentifierAndBinder) `P.sepBy` (C.indented *> C.comma))
266parseObjectBinder = 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
37 match (JSObjectLiteral ps) = Just $ "{ " ++ intercalate ", " (map (\(key, value) -> key ++ ": " ++ prettyPrintJS value) ps) ++ " }"
37 match (JSObjectLiteral ps) = Just $ "{ " ++ intercalate ", " (map (\(key, value) -> key ++ ": " ++ prettyPrintJS value) ps) ++ " }"
38 match (JSBlock sts) = Just $ "{ " ++ intercalate "; " (map prettyPrintJS sts) ++ " }"
38 match (JSBlock sts) = Just $ "{ " ++ intercalate "; " (map prettyPrintJS sts) ++ " }"
39 match (JSVar ident) = Just (identToJs ident)
39 match (JSVar ident) = Just (identToJs ident)
40− match (JSVariableIntroduction ident value) = Just $ "var " ++ identToJs ident ++ " = " ++ prettyPrintJS value
40+ match (JSVariableIntroduction ident value) = Just $ "var " ++ identToJs ident ++ maybe "" ((" = " ++) . prettyPrintJS) value
41− match (JSAssignment target value) = Just $ identToJs target ++ " = " ++ prettyPrintJS value
41+ match (JSAssignment target value) = Just $ targetToJs target ++ " = " ++ prettyPrintJS value
42 match (JSWhile cond sts) = Just $ "while ("
42 match (JSWhile cond sts) = Just $ "while ("
43 ++ prettyPrintJS cond ++ ") "
43 ++ prettyPrintJS cond ++ ") "
44 ++ prettyPrintJS sts
44 ++ prettyPrintJS sts
@@ -55,6 +55,10 @@ literals = Pattern $ A.Kleisli match
55 match (JSThrow value) = Just $ "throw " ++ prettyPrintJS value
55 match (JSThrow value) = Just $ "throw " ++ prettyPrintJS value
56 match _ = Nothing
56 match _ = Nothing
57
57
58+targetToJs :: JSAssignment -> String
59+targetToJs (JSAssignVariable ident) = identToJs ident
60+targetToJs (JSAssignProperty prop target) = targetToJs target ++ "." ++ prop
61+
58conditional :: Pattern JS ((JS, JS), JS)
62conditional :: Pattern JS ((JS, JS), JS)
59conditional = Pattern $ A.Kleisli match
63conditional = Pattern $ A.Kleisli match
60 where
64 where
src/Language/PureScript/Pretty/Types.hs+2−2
@@ -41,9 +41,9 @@ typeLiterals = Pattern $ A.Kleisli match
41 match (Array ty) = Just $ "[" ++ prettyPrintType ty ++ "]"
41 match (Array ty) = Just $ "[" ++ prettyPrintType ty ++ "]"
42 match (Object row) = Just $ "{ " ++ prettyPrintRow row ++ " }"
42 match (Object row) = Just $ "{ " ++ prettyPrintRow row ++ " }"
43 match (TypeVar var) = Just var
43 match (TypeVar var) = Just var
44− match (TypeConstructor ctor) = Just ctor
44+ match (TypeConstructor ctor) = Just $ show ctor
45 match (TUnknown u) = Just $ 'u' : show u
45 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) ++ ">"
47 match _ = Nothing
47 match _ = Nothing
48
48
49prettyPrintRow :: Row -> String
49prettyPrintRow :: Row -> String
src/Language/PureScript/Pretty/Values.hs+3−3
@@ -38,7 +38,7 @@ literals = Pattern $ A.Kleisli match
38 match (BooleanLiteral False) = Just "false"
38 match (BooleanLiteral False) = Just "false"
39 match (ArrayLiteral xs) = Just $ "[" ++ intercalate ", " (map prettyPrintValue xs) ++ "]"
39 match (ArrayLiteral xs) = Just $ "[" ++ intercalate ", " (map prettyPrintValue xs) ++ "]"
40 match (ObjectLiteral ps) = Just $ "{" ++ intercalate ", " (map (uncurry prettyPrintObjectProperty) ps) ++ "}"
40 match (ObjectLiteral ps) = Just $ "{" ++ intercalate ", " (map (uncurry prettyPrintObjectProperty) ps) ++ "}"
41− match (Constructor name) = Just name
41+ match (Constructor name) = Just $ show name
42 match (Block sts) = Just $ "do { " ++ intercalate " ; " (map prettyPrintStatement sts) ++ " }"
42 match (Block sts) = Just $ "do { " ++ intercalate " ; " (map prettyPrintStatement sts) ++ " }"
43 match (Case value binders) = Just $ "case " ++ prettyPrintValue value ++ " of { " ++ intercalate " ; " (map (uncurry prettyPrintCaseAlternative) binders) ++ " }"
43 match (Case value binders) = Just $ "case " ++ prettyPrintValue value ++ " of { " ++ intercalate " ; " (map (uncurry prettyPrintCaseAlternative) binders) ++ " }"
44 match (Var ident) = Just $ show ident
44 match (Var ident) = Just $ show ident
@@ -146,8 +146,8 @@ prettyPrintBinder (NumberBinder num) = either show show num
146prettyPrintBinder (BooleanBinder True) = "true"
146prettyPrintBinder (BooleanBinder True) = "true"
147prettyPrintBinder (BooleanBinder False) = "false"
147prettyPrintBinder (BooleanBinder False) = "false"
148prettyPrintBinder (VarBinder ident) = show ident
148prettyPrintBinder (VarBinder ident) = show ident
149−prettyPrintBinder (NullaryBinder ctor) = ctor
149+prettyPrintBinder (NullaryBinder ctor) = show ctor
150−prettyPrintBinder (UnaryBinder ctor b) = ctor ++ prettyPrintBinder b
150+prettyPrintBinder (UnaryBinder ctor b) = show ctor ++ prettyPrintBinder b
151prettyPrintBinder (ObjectBinder bs) = "{ " ++ intercalate ", " (map (uncurry prettyPrintObjectPropertyBinder) bs) ++ " }"
151prettyPrintBinder (ObjectBinder bs) = "{ " ++ intercalate ", " (map (uncurry prettyPrintObjectPropertyBinder) bs) ++ " }"
152prettyPrintBinder (ArrayBinder bs rest) = "[ " ++ intercalate ", " (map prettyPrintBinder bs) ++ maybe "" (("; " ++) . prettyPrintBinder) rest ++ " ]"
152prettyPrintBinder (ArrayBinder bs rest) = "[ " ++ intercalate ", " (map prettyPrintBinder bs) ++ maybe "" (("; " ++) . prettyPrintBinder) rest ++ " ]"
153prettyPrintBinder (NamedBinder ident binder) = show ident ++ "@" ++ prettyPrintBinder binder
153prettyPrintBinder (NamedBinder ident binder) = show ident ++ "@" ++ prettyPrintBinder binder
src/Language/PureScript/TypeChecker.hs+31−21
@@ -42,27 +42,29 @@ import Control.Monad.Error
42typeCheckAll :: [Declaration] -> Check ()
42typeCheckAll :: [Declaration] -> Check ()
43typeCheckAll [] = return ()
43typeCheckAll [] = return ()
44typeCheckAll (DataDeclaration name args dctors : rest) = do
44typeCheckAll (DataDeclaration name args dctors : rest) = do
45− rethrow (("Error in type constructor " ++ name ++ ": ") ++) $ do
45+ rethrow (("Error in type constructor " ++ show name ++ ": ") ++) $ do
46 env <- getEnv
46 env <- getEnv
47+ modulePath <- checkModulePath `fmap` get
47− guardWith (name ++ " is already defined") $ not $ M.member name (types env)
48+ guardWith (show name ++ " is already defined") $ not $ M.member (modulePath, name) (types env)
48 ctorKind <- kindsOf (Just name) args (mapMaybe snd dctors)
49 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) }
50 forM_ dctors $ \(dctor, maybeTy) ->
51 forM_ dctors $ \(dctor, maybeTy) ->
51− rethrow (("Error in data constructor " ++ name ++ ": ") ++) $ do
52+ rethrow (("Error in data constructor " ++ show name ++ ": ") ++) $ do
52 env' <- getEnv
53 env' <- getEnv
53− guardWith (dctor ++ " is already defined") $ not $ M.member dctor (dataConstructors env')
54+ guardWith (show dctor ++ " is already defined") $ not $ M.member (modulePath, dctor) (dataConstructors env')
54− let retTy = foldl TypeApp (TypeConstructor name) (map TypeVar args)
55+ let retTy = foldl TypeApp (TypeConstructor (Qualified modulePath name)) (map TypeVar args)
55 let dctorTy = maybe retTy (\ty -> Function [ty] retTy) maybeTy
56 let dctorTy = maybe retTy (\ty -> Function [ty] retTy) maybeTy
56 let polyType = PolyType args dctorTy
57 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') }
58 typeCheckAll rest
59 typeCheckAll rest
59typeCheckAll (TypeSynonymDeclaration name args ty : rest) = do
60typeCheckAll (TypeSynonymDeclaration name args ty : rest) = do
60− rethrow (("Error in type synonym " ++ name ++ ": ") ++) $ do
61+ rethrow (("Error in type synonym " ++ show name ++ ": ") ++) $ do
61 env <- getEnv
62 env <- getEnv
63+ modulePath <- checkModulePath `fmap` get
62− guardWith (name ++ " is already defined") $ not $ M.member name (types env)
64+ guardWith (show name ++ " is already defined") $ not $ M.member (modulePath, name) (types env)
63 kind <- kindsOf (Just name) args [ty]
65 kind <- kindsOf (Just name) args [ty]
64− putEnv $ env { types = M.insert name (kind, TypeSynonym) (types env)
66+ putEnv $ env { types = M.insert (modulePath, name) (kind, TypeSynonym) (types env)
65− , typeSynonyms = M.insert name (args, ty) (typeSynonyms env) }
67+ , typeSynonyms = M.insert (modulePath, name) (args, ty) (typeSynonyms env) }
66 typeCheckAll rest
68 typeCheckAll rest
67typeCheckAll (TypeDeclaration name ty : ValueDeclaration name' val : rest) | name == name' =
69typeCheckAll (TypeDeclaration name ty : ValueDeclaration name' val : rest) | name == name' =
68 typeCheckAll (ValueDeclaration name (TypedValue val ty) : rest)
70 typeCheckAll (ValueDeclaration name (TypedValue val ty) : rest)
@@ -70,40 +72,48 @@ typeCheckAll (TypeDeclaration name _ : _) = throwError $ "Orphan type declaratio
70typeCheckAll (ValueDeclaration name val : rest) = do
72typeCheckAll (ValueDeclaration name val : rest) = do
71 rethrow (("Error in declaration " ++ show name ++ ": ") ++) $ do
73 rethrow (("Error in declaration " ++ show name ++ ": ") ++) $ do
72 env <- getEnv
74 env <- getEnv
75+ modulePath <- checkModulePath `fmap` get
73− case M.lookup name (names env) of
76+ case M.lookup (modulePath, name) (names env) of
74 Just ty -> throwError $ show name ++ " is already defined"
77 Just ty -> throwError $ show name ++ " is already defined"
75 Nothing -> do
78 Nothing -> do
76 ty <- typeOf name val
79 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) })
78 typeCheckAll rest
81 typeCheckAll rest
79typeCheckAll (ExternDataDeclaration name kind : rest) = do
82typeCheckAll (ExternDataDeclaration name kind : rest) = do
80 env <- getEnv
83 env <- getEnv
84+ modulePath <- checkModulePath `fmap` get
81− guardWith (name ++ " is already defined") $ not $ M.member name (types env)
85+ guardWith (show name ++ " is already defined") $ not $ M.member (modulePath, name) (types env)
82− putEnv $ env { types = M.insert name (kind, TypeSynonym) (types env) }
86+ putEnv $ env { types = M.insert (modulePath, name) (kind, TypeSynonym) (types env) }
83 typeCheckAll rest
87 typeCheckAll rest
84typeCheckAll (ExternMemberDeclaration member name ty : rest) = do
88typeCheckAll (ExternMemberDeclaration member name ty : rest) = do
85 rethrow (("Error in foreign import member declaration " ++ show name ++ ": ") ++) $ do
89 rethrow (("Error in foreign import member declaration " ++ show name ++ ": ") ++) $ do
86 env <- getEnv
90 env <- getEnv
91+ modulePath <- checkModulePath `fmap` get
87 kind <- kindOf ty
92 kind <- kindOf ty
88 guardWith "Expected kind *" $ kind == Star
93 guardWith "Expected kind *" $ kind == Star
89− case M.lookup name (names env) of
94+ case M.lookup (modulePath, name) (names env) of
90 Just _ -> throwError $ show name ++ " is already defined"
95 Just _ -> throwError $ show name ++ " is already defined"
91 Nothing -> case ty of
96 Nothing -> case ty of
92 (PolyType _ (Function [_] _)) -> do
97 (PolyType _ (Function [_] _)) -> do
93− putEnv (env { names = M.insert name (ty, Extern) (names env)
98+ putEnv (env { names = M.insert (modulePath, name) (ty, Extern) (names env)
94− , members = M.insert name member (members env) })
99+ , members = M.insert (modulePath, name) member (members env) })
95 _ -> throwError "Foreign member declarations must have function types, with an single argument."
100 _ -> throwError "Foreign member declarations must have function types, with an single argument."
96 typeCheckAll rest
101 typeCheckAll rest
97typeCheckAll (ExternDeclaration name ty : rest) = do
102typeCheckAll (ExternDeclaration name ty : rest) = do
98 rethrow (("Error in foreign import declaration " ++ show name ++ ": ") ++) $ do
103 rethrow (("Error in foreign import declaration " ++ show name ++ ": ") ++) $ do
99 env <- getEnv
104 env <- getEnv
105+ modulePath <- checkModulePath `fmap` get
100 kind <- kindOf ty
106 kind <- kindOf ty
101 guardWith "Expected kind *" $ kind == Star
107 guardWith "Expected kind *" $ kind == Star
102− case M.lookup name (names env) of
108+ case M.lookup (modulePath, name) (names env) of
103 Just _ -> throwError $ show name ++ " is already defined"
109 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) })
105 typeCheckAll rest
111 typeCheckAll rest
106typeCheckAll (FixityDeclaration _ name : rest) = do
112typeCheckAll (FixityDeclaration _ name : rest) = do
107 typeCheckAll rest
113 typeCheckAll rest
108 env <- getEnv
114 env <- getEnv
115+ modulePath <- checkModulePath `fmap` get
109− guardWith ("Fixity declaration with no binding: " ++ name) $ M.member (Op name) $ names env
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
28
28
29import Language.PureScript.Types
29import Language.PureScript.Types
30import Language.PureScript.Kinds
30import Language.PureScript.Kinds
31+import Language.PureScript.Names
31import Language.PureScript.Declarations
32import Language.PureScript.Declarations
32import Language.PureScript.TypeChecker.Monad
33import Language.PureScript.TypeChecker.Monad
33import Language.PureScript.Pretty
34import Language.PureScript.Pretty
@@ -61,15 +62,15 @@ emptyKindSolution = KindSolution KUnknown
61kindOf :: PolyType -> Check Kind
62kindOf :: PolyType -> Check Kind
62kindOf (PolyType idents ty) = do
63kindOf (PolyType idents ty) = do
63 ns <- replicateM (length idents) fresh
64 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
65 solution <- solveKindConstraints cs emptyKindSolution
66 solution <- solveKindConstraints cs emptyKindSolution
66 return $ starIfUnknown $ runKindSolution solution n
67 return $ starIfUnknown $ runKindSolution solution n
67
68
68−kindsOf :: Maybe String -> [String] -> [Type] -> Check Kind
69+kindsOf :: Maybe ProperName -> [String] -> [Type] -> Check Kind
69kindsOf name args ts = do
70kindsOf name args ts = do
70 tyCon <- fresh
71 tyCon <- fresh
71 nargs <- replicateM (length args) fresh
72 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
73 let extraConstraints =
74 let extraConstraints =
74 KindConstraint tyCon (foldr (FunKind . KUnknown) Star nargs) DataDeclOrigin
75 KindConstraint tyCon (foldr (FunKind . KUnknown) Star nargs) DataDeclOrigin
75 : zipWith (\n arg -> KindConstraint n Star (TypeOrigin arg)) ns ts
76 : zipWith (\n arg -> KindConstraint n Star (TypeOrigin arg)) ns ts
@@ -81,61 +82,65 @@ starIfUnknown (KUnknown _) = Star
81starIfUnknown (FunKind k1 k2) = FunKind (starIfUnknown k1) (starIfUnknown k2)
82starIfUnknown (FunKind k1 k2) = FunKind (starIfUnknown k1) (starIfUnknown k2)
82starIfUnknown k = k
83starIfUnknown k = k
83
84
84−kindConstraintsAll :: M.Map String Int -> [Type] -> Check ([KindConstraint], [Int], M.Map String Int)
85+kindConstraintsAll :: Maybe (ProperName, Int) -> M.Map String Int -> [Type] -> Check ([KindConstraint], [Int], M.Map String Int)
85−kindConstraintsAll m [] = return ([], [], m)
86+kindConstraintsAll _ m [] = return ([], [], m)
86−kindConstraintsAll m (t:ts) = do
87+kindConstraintsAll name m (t:ts) = do
87− (cs, n1, m') <- kindConstraints m t
88+ (cs, n1, m') <- kindConstraints name m t
88− (cs', ns, m'') <- kindConstraintsAll m' ts
89+ (cs', ns, m'') <- kindConstraintsAll name m' ts
89 return (KindConstraint n1 Star (TypeOrigin t) : cs ++ cs', n1:ns, m'')
90 return (KindConstraint n1 Star (TypeOrigin t) : cs ++ cs', n1:ns, m'')
90
91
91−kindConstraints :: M.Map String Int -> Type -> Check ([KindConstraint], Int, M.Map String Int)
92+kindConstraints :: Maybe (ProperName, Int) -> M.Map String Int -> Type -> Check ([KindConstraint], Int, M.Map String Int)
92−kindConstraints m a@(Array t) = do
93+kindConstraints name m a@(Array t) = do
93 me <- fresh
94 me <- fresh
94− (cs, n1, m') <- kindConstraints m t
95+ (cs, n1, m') <- kindConstraints name m t
95 return (KindConstraint n1 Star (TypeOrigin t) : KindConstraint me Star (TypeOrigin a) : cs, me, m')
96 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
97 me <- fresh
98 me <- fresh
98− (cs, r, m') <- kindConstraintsForRow m row
99+ (cs, r, m') <- kindConstraintsForRow name m row
99 return (KindConstraint me Star (TypeOrigin o) : KindConstraint r Row (RowOrigin row) : cs, me, m')
100 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
101 me <- fresh
102 me <- fresh
102− (cs, ns, m') <- kindConstraintsAll m args
103+ (cs, ns, m') <- kindConstraintsAll name m args
103− (cs', retN, m'') <- kindConstraints m' ret
104+ (cs', retN, m'') <- kindConstraints name m' ret
104 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 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) =
106 case M.lookup v m of
107 case M.lookup v m of
107 Just u -> return ([], u, m)
108 Just u -> return ([], u, m)
108 Nothing -> throwError $ "Unbound type variable " ++ v
109 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
110 env <- getEnv
111 env <- getEnv
111 me <- fresh
112 me <- fresh
112− case M.lookup v m of
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
113− Nothing -> case M.lookup v (types env) of
119+ case M.lookup (qualify modulePath v) (types env) of
114− Nothing -> throwError $ "Unknown type constructor '" ++ v ++ "'"
120+ Nothing -> throwError $ "Unknown type constructor '" ++ show v ++ "'"
115− Just (kind, _) -> return ([KindConstraint me kind (TypeOrigin c)], me, m)
121+ 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
122+kindConstraints name m a@(TypeApp t1 t2) = do
118 me <- fresh
123 me <- fresh
119− (cs1, n1, m1) <- kindConstraints m t1
124+ (cs1, n1, m1) <- kindConstraints name m t1
120− (cs2, n2, m2) <- kindConstraints m1 t2
125+ (cs2, n2, m2) <- kindConstraints name m1 t2
121 return (KindConstraint n1 (FunKind (KUnknown n2) (KUnknown me)) (TypeOrigin a) : cs1 ++ cs2, me, m2)
126 return (KindConstraint n1 (FunKind (KUnknown n2) (KUnknown me)) (TypeOrigin a) : cs1 ++ cs2, me, m2)
122−kindConstraints m t = do
127+kindConstraints _ m t = do
123 me <- fresh
128 me <- fresh
124 return ([KindConstraint me Star (TypeOrigin t)], me, m)
129 return ([KindConstraint me Star (TypeOrigin t)], me, m)
125
130
126−kindConstraintsForRow :: M.Map String Int -> Row -> Check ([KindConstraint], Int, M.Map String Int)
131+kindConstraintsForRow :: Maybe (ProperName, Int) -> M.Map String Int -> Row -> Check ([KindConstraint], Int, M.Map String Int)
127−kindConstraintsForRow m r@(RowVar v) = do
132+kindConstraintsForRow _ m r@(RowVar v) = do
128 me <- case M.lookup v m of
133 me <- case M.lookup v m of
129 Just u -> return u
134 Just u -> return u
130 Nothing -> fresh
135 Nothing -> fresh
131 return ([KindConstraint me Row (RowOrigin r)], me, M.insert v me m)
136 return ([KindConstraint me Row (RowOrigin r)], me, M.insert v me m)
132−kindConstraintsForRow m r@REmpty = do
137+kindConstraintsForRow _ m r@REmpty = do
133 me <- fresh
138 me <- fresh
134 return ([KindConstraint me Row (RowOrigin r)], me, m)
139 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
136 me <- fresh
141 me <- fresh
137− (cs1, n1, m1) <- kindConstraints m ty
142+ (cs1, n1, m1) <- kindConstraints name m ty
138− (cs2, n2, m2) <- kindConstraintsForRow m1 row
143+ (cs2, n2, m2) <- kindConstraintsForRow name m1 row
139 return (KindConstraint me Row (RowOrigin r) : KindConstraint n1 Star (TypeOrigin ty) : KindConstraint n2 Row (RowOrigin r) : cs1 ++ cs2, me, m2)
144 return (KindConstraint me Row (RowOrigin r) : KindConstraint n1 Star (TypeOrigin ty) : KindConstraint n2 Row (RowOrigin r) : cs1 ++ cs2, me, m2)
140
145
141solveKindConstraints :: [KindConstraint] -> KindSolution -> Check KindSolution
146solveKindConstraints :: [KindConstraint] -> KindSolution -> Check KindSolution
src/Language/PureScript/TypeChecker/Monad.hs+27−13
@@ -33,32 +33,38 @@ data NameKind = Value | Extern deriving Show
33data TypeDeclarationKind = Data | ExternData | TypeSynonym deriving Show
33data TypeDeclarationKind = Data | ExternData | TypeSynonym deriving Show
34
34
35data Environment = Environment
35data Environment = Environment
36− { names :: M.Map Ident (PolyType, NameKind)
36+ { names :: M.Map (ModulePath, Ident) (PolyType, NameKind)
37− , types :: M.Map String (Kind, TypeDeclarationKind)
37+ , types :: M.Map (ModulePath, ProperName) (Kind, TypeDeclarationKind)
38− , dataConstructors :: M.Map String PolyType
38+ , dataConstructors :: M.Map (ModulePath, ProperName) PolyType
39− , typeSynonyms :: M.Map String ([String], Type)
39+ , typeSynonyms :: M.Map (ModulePath, ProperName) ([String], Type)
40− , members :: M.Map Ident String
40+ , members :: M.Map (ModulePath, Ident) String
41− }
41+ } deriving (Show)
42
42
43emptyEnvironment :: Environment
43emptyEnvironment :: Environment
44emptyEnvironment = Environment M.empty M.empty M.empty M.empty M.empty
44emptyEnvironment = Environment M.empty M.empty M.empty M.empty M.empty
45
45
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 }
46−newtype Check a = Check { unCheck :: StateT (Environment, Int) (Either String) a } deriving (Functor, Monad, Applicative, MonadPlus, MonadState (Environment, Int), MonadError String)
52+ deriving (Functor, Monad, Applicative, MonadPlus, MonadState CheckState, MonadError String)
47
53
48getEnv :: Check Environment
54getEnv :: Check Environment
49−getEnv = fmap fst get
55+getEnv = fmap checkEnv get
50
56
51putEnv :: Environment -> Check ()
57putEnv :: Environment -> Check ()
52−putEnv env = fmap (first (const env)) get >>= put
58+putEnv env = modify (\s -> s { checkEnv = env })
53
59
54fresh :: Check Int
60fresh :: Check Int
55fresh = do
61fresh = do
56− (env, n) <- get
62+ st <- get
57− put (env, n + 1)
63+ put $ st { checkNextVar = checkNextVar st + 1 }
58− return n
64+ return $ checkNextVar st
59
65
60check :: Check a -> Either String (a, Environment)
66check :: 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
62
68
63guardWith :: (MonadError e m) => e -> Bool -> m ()
69guardWith :: (MonadError e m) => e -> Bool -> m ()
64guardWith _ True = return ()
70guardWith _ True = return ()
@@ -66,3 +72,11 @@ guardWith e False = throwError e
66
72
67rethrow :: (MonadError e m) => (e -> e) -> m a -> m a
73rethrow :: (MonadError e m) => (e -> e) -> m a -> m a
68rethrow f = flip catchError $ \e -> throwError (f e)
74rethrow 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 (
21
21
22import Language.PureScript.Types
22import Language.PureScript.Types
23import Language.PureScript.Declarations
23import Language.PureScript.Declarations
24+import Language.PureScript.Names
24
25
25import Data.Maybe (fromMaybe)
26import Data.Maybe (fromMaybe)
26import Data.Data
27import Data.Data
@@ -30,12 +31,12 @@ import Control.Monad.Writer
30import Control.Monad.Error
31import Control.Monad.Error
31import qualified Data.Map as M
32import qualified Data.Map as M
32
33
33−buildTypeSubstitution :: String -> Int -> Type -> Either String (Maybe Type)
34+buildTypeSubstitution :: Qualified ProperName -> Int -> Type -> Either String (Maybe Type)
34buildTypeSubstitution name n = go n []
35buildTypeSubstitution name n = go n []
35 where
36 where
36 go :: Int -> [Type] -> Type -> Either String (Maybe Type)
37 go :: Int -> [Type] -> Type -> Either String (Maybe Type)
37 go 0 args (TypeConstructor ctor) | name == ctor = return (Just $ SaturatedTypeSynonym ctor args)
38 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
39 go n args (TypeApp f arg) = go (n - 1) (arg:args) f
40 go n args (TypeApp f arg) = go (n - 1) (arg:args) f
40 go _ _ _ = return Nothing
41 go _ _ _ = return Nothing
41
42
@@ -44,12 +45,12 @@ everywhereM' f x = do
44 y <- f x
45 y <- f x
45 gmapM (everywhereM' f) y
46 gmapM (everywhereM' f) y
46
47
47−saturateTypeSynonym :: (Data d) => String -> Int -> d -> Either String d
48+saturateTypeSynonym :: (Data d) => Qualified ProperName -> Int -> d -> Either String d
48saturateTypeSynonym name n = everywhereM' (mkM replace)
49saturateTypeSynonym name n = everywhereM' (mkM replace)
49 where
50 where
50 replace t = fmap (fromMaybe t) $ buildTypeSubstitution name n t
51 replace t = fmap (fromMaybe t) $ buildTypeSubstitution name n t
51
52
52−saturateAllTypeSynonyms :: (Data d) => [(String, Int)] -> d -> Either String d
53+saturateAllTypeSynonyms :: (Data d) => [(Qualified ProperName, Int)] -> d -> Either String d
53saturateAllTypeSynonyms syns d = foldM (\d (name, n) -> saturateTypeSynonym name n d) d syns
54saturateAllTypeSynonyms syns d = foldM (\d (name, n) -> saturateTypeSynonym name n d) d syns
54
55
55
56
src/Language/PureScript/TypeChecker/Types.hs+35−22
@@ -192,7 +192,7 @@ replaceVarsWithUnknowns idents = flip evalStateT M.empty . everywhereM (flip ext
192replaceAllTypeSynonyms :: (D.Data d) => d -> Check d
192replaceAllTypeSynonyms :: (D.Data d) => d -> Check d
193replaceAllTypeSynonyms d = do
193replaceAllTypeSynonyms d = do
194 env <- getEnv
194 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
196 either throwError return $ saturateAllTypeSynonyms syns d
196 either throwError return $ saturateAllTypeSynonyms syns d
197
197
198desaturateAllTypeSynonyms :: (D.Data d) => d -> d
198desaturateAllTypeSynonyms :: (D.Data d) => d -> d
@@ -306,19 +306,25 @@ typeConstraints m v@(App f xs) = do
306 let (cs2, ns) = (concatMap fst &&& map snd) all
306 let (cs2, ns) = (concatMap fst &&& map snd) all
307 me <- fresh
307 me <- fresh
308 return (TypeConstraint n1 (Function (map TUnknown ns) (TUnknown me)) (ValueOrigin v) : cs1 ++ cs2, me)
308 return (TypeConstraint n1 (Function (map TUnknown ns) (TUnknown me)) (ValueOrigin v) : cs1 ++ cs2, me)
309−typeConstraints m v@(Var var) =
309+typeConstraints m v@(Var var@(Qualified mp name)) = do
310− case M.lookup var m of
310+ case mp of
311− Nothing -> do
311+ ModulePath [] ->
312− env <- getEnv
313− case M.lookup var (names env) of
312+ case M.lookup name m of
314− Nothing -> throwError $ show var ++ " is undefined"
315− Just (PolyType idents ty, _) -> do
313+ Just u -> do
316 me <- fresh
314 me <- fresh
317− replaced <- replaceVarsWithUnknowns idents ty
318− return ([TypeConstraint me replaced (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"
319− Just u -> do
324+ Just (PolyType idents ty, _) -> do
320− me <- fresh
325+ me <- fresh
326+ replaced <- replaceVarsWithUnknowns idents ty
321− return ([TypeConstraint u (TUnknown me) (ValueOrigin v)], me)
327+ return ([TypeConstraint me replaced (ValueOrigin v)], me)
322typeConstraints m (Block ss) = do
328typeConstraints m (Block ss) = do
323 ret <- fresh
329 ret <- fresh
324 (cs, allCodePathsReturn, _) <- typeConstraintsForBlock m M.empty ret ss
330 (cs, allCodePathsReturn, _) <- typeConstraintsForBlock m M.empty ret ss
@@ -326,8 +332,9 @@ typeConstraints m (Block ss) = do
326 return (cs, ret)
332 return (cs, ret)
327typeConstraints m v@(Constructor c) = do
333typeConstraints m v@(Constructor c) = do
328 env <- getEnv
334 env <- getEnv
335+ modulePath <- checkModulePath `fmap` get
329− case M.lookup c (dataConstructors env) of
336+ case M.lookup (qualify modulePath c) (dataConstructors env) of
330− Nothing -> throwError $ "Constructor " ++ c ++ " is undefined"
337+ Nothing -> throwError $ "Constructor " ++ show c ++ " is undefined"
331 Just (PolyType idents ty) -> do
338 Just (PolyType idents ty) -> do
332 me <- fresh
339 me <- fresh
333 replaced <- replaceVarsWithUnknowns idents ty
340 replaced <- replaceVarsWithUnknowns idents ty
@@ -394,21 +401,23 @@ typeConstraintsForBinder val b@(VarBinder name) = do
394 return ([TypeConstraint me (TUnknown val) (BinderOrigin b)], M.singleton name me)
401 return ([TypeConstraint me (TUnknown val) (BinderOrigin b)], M.singleton name me)
395typeConstraintsForBinder val b@(NullaryBinder ctor) = do
402typeConstraintsForBinder val b@(NullaryBinder ctor) = do
396 env <- getEnv
403 env <- getEnv
404+ modulePath <- checkModulePath `fmap` get
397− case M.lookup ctor (dataConstructors env) of
405+ case M.lookup (qualify modulePath ctor) (dataConstructors env) of
398 Just (PolyType args ret) -> do
406 Just (PolyType args ret) -> do
399 ret' <- replaceVarsWithUnknowns args ret
407 ret' <- replaceVarsWithUnknowns args ret
400 return ([TypeConstraint val ret' (BinderOrigin b)], M.empty)
408 return ([TypeConstraint val ret' (BinderOrigin b)], M.empty)
401− _ -> throwError $ "Constructor " ++ ctor ++ " is not defined"
409+ _ -> throwError $ "Constructor " ++ show ctor ++ " is not defined"
402typeConstraintsForBinder val b@(UnaryBinder ctor binder) = do
410typeConstraintsForBinder val b@(UnaryBinder ctor binder) = do
403 env <- getEnv
411 env <- getEnv
412+ modulePath <- checkModulePath `fmap` get
404− case M.lookup ctor (dataConstructors env) of
413+ case M.lookup (qualify modulePath ctor) (dataConstructors env) of
405 Just (PolyType idents f@(Function [_] _)) -> do
414 Just (PolyType idents f@(Function [_] _)) -> do
406 obj <- fresh
415 obj <- fresh
407 (Function [ty] ret) <- replaceVarsWithUnknowns idents f
416 (Function [ty] ret) <- replaceVarsWithUnknowns idents f
408 (cs, m1) <- typeConstraintsForBinder obj binder
417 (cs, m1) <- typeConstraintsForBinder obj binder
409 return (TypeConstraint val ret (BinderOrigin b) : TypeConstraint obj ty (BinderOrigin b) : cs, m1)
418 return (TypeConstraint val ret (BinderOrigin b) : TypeConstraint obj ty (BinderOrigin b) : cs, m1)
410− Just _ -> throwError $ ctor ++ " is not a unary constructor"
419+ Just _ -> throwError $ show ctor ++ " is not a unary constructor"
411− _ -> throwError $ "Constructor " ++ ctor ++ " is not defined"
420+ _ -> throwError $ "Constructor " ++ show ctor ++ " is not defined"
412typeConstraintsForBinder val b@(ObjectBinder props) = do
421typeConstraintsForBinder val b@(ObjectBinder props) = do
413 row <- fresh
422 row <- fresh
414 rest <- fresh
423 rest <- fresh
@@ -573,7 +582,8 @@ unifyTypes o (SaturatedTypeSynonym name1 args1) (SaturatedTypeSynonym name2 args
573 fmap concat $ zipWithM (unifyTypes o) args1 args2
582 fmap concat $ zipWithM (unifyTypes o) args1 args2
574unifyTypes o (SaturatedTypeSynonym name args) ty = do
583unifyTypes o (SaturatedTypeSynonym name args) ty = do
575 env <- getEnv
584 env <- getEnv
585+ modulePath <- checkModulePath `fmap` get
576− case M.lookup name (typeSynonyms env) of
586+ case M.lookup (qualify modulePath name) (typeSynonyms env) of
577 Just (synArgs, body) -> do
587 Just (synArgs, body) -> do
578 let m = M.fromList $ zip synArgs args
588 let m = M.fromList $ zip synArgs args
579 let replaced = replaceTypeVars m body
589 let replaced = replaceTypeVars m body
@@ -591,7 +601,10 @@ unifyTypes o (Function args1 ret1) (Function args2 ret2) = do
591 cs2 <- unifyTypes o ret1 ret2
601 cs2 <- unifyTypes o ret1 ret2
592 return $ cs1 ++ cs2
602 return $ cs1 ++ cs2
593unifyTypes _ (TypeVar v1) (TypeVar v2) | v1 == v2 = return []
603unifyTypes _ (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 []
595unifyTypes o (TypeApp t1 t2) (TypeApp t3 t4) = do
608unifyTypes o (TypeApp t1 t2) (TypeApp t3 t4) = do
596 cs1 <- unifyTypes o t1 t3
609 cs1 <- unifyTypes o t1 t3
597 cs2 <- unifyTypes o t2 t4
610 cs2 <- unifyTypes o t2 t4
src/Language/PureScript/Types.hs+3−2
@@ -17,6 +17,7 @@
17module Language.PureScript.Types where
17module Language.PureScript.Types where
18
18
19import Data.Data
19import Data.Data
20+import Language.PureScript.Names
20
21
21data Type
22data Type
22 = TUnknown Int
23 = TUnknown Int
@@ -27,9 +28,9 @@ data Type
27 | Object Row
28 | Object Row
28 | Function [Type] Type
29 | Function [Type] Type
29 | TypeVar String
30 | TypeVar String
30− | TypeConstructor String
31+ | TypeConstructor (Qualified ProperName)
31 | TypeApp Type Type
32 | TypeApp Type Type
32− | SaturatedTypeSynonym String [Type] deriving (Show, Eq, Data, Typeable)
33+ | SaturatedTypeSynonym (Qualified ProperName) [Type] deriving (Show, Eq, Data, Typeable)
33
34
34data PolyType = PolyType [String] Type deriving (Show, Eq, Data, Typeable)
35data PolyType = PolyType [String] Type deriving (Show, Eq, Data, Typeable)
35
36
src/Language/PureScript/Values.hs+4−4
@@ -61,10 +61,10 @@ data Value
61 | ObjectUpdate Value [(String, Value)]
61 | ObjectUpdate Value [(String, Value)]
62 | Abs [Ident] Value
62 | Abs [Ident] Value
63 | App Value [Value]
63 | App Value [Value]
64− | Var Ident
64+ | Var (Qualified Ident)
65 | IfThenElse Value Value Value
65 | IfThenElse Value Value Value
66 | Block [Statement]
66 | Block [Statement]
67− | Constructor String
67+ | Constructor (Qualified ProperName)
68 | Case Value [(Binder, Value)]
68 | Case Value [(Binder, Value)]
69 | TypedValue Value PolyType deriving (Show, Data, Typeable)
69 | TypedValue Value PolyType deriving (Show, Data, Typeable)
70
70
@@ -89,8 +89,8 @@ data Binder
89 | StringBinder String
89 | StringBinder String
90 | NumberBinder (Either Integer Double)
90 | NumberBinder (Either Integer Double)
91 | VarBinder Ident
91 | VarBinder Ident
92− | NullaryBinder String
92+ | NullaryBinder (Qualified ProperName)
93− | UnaryBinder String Binder
93+ | UnaryBinder (Qualified ProperName) Binder
94 | ObjectBinder [(String, Binder)]
94 | ObjectBinder [(String, Binder)]
95 | ArrayBinder [Binder] (Maybe Binder)
95 | ArrayBinder [Binder] (Maybe Binder)
96 | NamedBinder Ident Binder
96 | NamedBinder Ident Binder
src/Main.hs+2−2
@@ -40,13 +40,13 @@ compile inputFiles outputFile externsFile = do
40 U.putStrLn typeError
40 U.putStrLn typeError
41 exitFailure
41 exitFailure
42 Right (_, env) -> do
42 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
44 case outputFile of
44 case outputFile of
45 Just path -> U.writeFile path js
45 Just path -> U.writeFile path js
46 Nothing -> U.putStrLn js
46 Nothing -> U.putStrLn js
47 case externsFile of
47 case externsFile of
48 Nothing -> return ()
48 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
50 exitSuccess
50 exitSuccess
51
51
52inputFiles :: Term [FilePath]
52inputFiles :: Term [FilePath]