ea3e968 · rowtype-yoga/purescript-native

git.iko.soy/rowtype-yoga/purescript-native

on golang help sign in

Still more work on mutually recursive functions, still need to fix examples

ea3e968Phil Freeman13 years ago

examples/passing/Import.purs+6−6

compare with golang

unifiedsplit

@@ -1,12 +1,12 @@

1−module Hello where

1+module M1 where

2 id :: forall a. a -> a

3 id :: forall a. a -> a

3 id = \x -> x

4 id = \x -> x

5− module Nested where

6+ foo = id

6− import Hello (id)

8− foo = id

8+module M2 where

10−import Hello.Nested

10+ import M1

12−main = \() -> foo 42

12+ main = \() -> foo 42

examples/passing/Module.purs+7−12

@@ -1,8 +1,8 @@

1−module Test where

1+module M1 where

3 data Foo = Foo String

5− foo :: Test.Foo -> String

5+ foo :: M1.Foo -> String

6 foo = \f -> case f of Foo s -> s ++ "foo"

8 bar :: Foo -> String

@@ -11,15 +11,10 @@ module Test where

11 incr :: Number -> Number

12 incr x = x + 1

14− module Inner where

14+module M2 where

16− inner = "Inner"

16+ baz :: M1.Foo -> String

17+ baz = M1.foo

18−baz :: Test.Foo -> String

19−baz = Test.foo

20−

21−innerCopy :: String

22−innerCopy = Test.Inner.inner

23−

24−match :: Test.Foo -> String

19+ match :: M1.Foo -> String

25−match = \f -> case f of Test.Foo s -> s ++ "foo"

20+ match = \f -> case f of M1.Foo s -> s ++ "foo"

examples/passing/MutRec.purs+5−3

@@ -1,4 +1,6 @@

1−f 0 = 0

1+module MutRec where

2−f x = g x + 1

3+ f 0 = 0

4+ f x = g x + 1

4−g x = f (x / 2)

6+ g x = f (x / 2)

src/Language/PureScript.hs+8−9

@@ -30,14 +30,13 @@ import Language.PureScript.TypeDeclarations as P

30import Language.PureScript.BindingGroups as P

32import Data.List (intercalate)

33−import Data.Maybe (mapMaybe)

34−import Control.Monad ((>=>))

33+import Control.Monad (forM_, (>=>))

36−compile :: [Declaration] -> Either String (String, String, Environment)

35+compile :: [Module] -> Either String (String, String, Environment)

37−compile decls = do

36+compile ms = do

38− bracketted <- rebracket decls

37+ bracketted <- rebracket ms

39− desugared <- desugarCases >=> desugarTypeDeclarations >=> (return . createBindingGroups) $ bracketted

38+ desugared <- desugarCasesModule >=> desugarTypeDeclarationsModule >=> (return . createBindingGroupsModule) $ bracketted

40− (_, env) <- runCheck (typeCheckAll desugared)

39+ (_, env) <- runCheck $ forM_ desugared $ \(Module moduleName decls) -> typeCheckAll (ModuleName moduleName) decls

41− let js = prettyPrintJS . map optimize . concat . mapMaybe (\decl -> declToJs Nothing global decl env) $ desugared

40+ let js = prettyPrintJS . map optimize . concatMap (flip moduleToJs env) $ desugared

42− let exts = intercalate "\n" . mapMaybe (externToPs 0 global env) $ desugared

41+ let exts = intercalate "\n" . map (flip moduleToPs env) $ desugared

43 return (js, exts, env)

42 return (js, exts, env)

src/Language/PureScript/BindingGroups.hs+6−6

@@ -13,7 +13,8 @@

13-----------------------------------------------------------------------------

15module Language.PureScript.BindingGroups (

16− createBindingGroups

16+ createBindingGroups,

17+ createBindingGroupsModule

17) where

18) where

19import Data.Graph

20import Data.Graph

@@ -24,6 +25,9 @@ import Language.PureScript.Names

24import Language.PureScript.Values

25import Language.PureScript.Values

25import Language.PureScript.Scope (usedNames)

26import Language.PureScript.Scope (usedNames)

28+createBindingGroupsModule :: [Module] -> [Module]

29+createBindingGroupsModule = map $ \(Module name ds) -> Module name (createBindingGroups ds)

30+

27createBindingGroups :: [Declaration] -> [Declaration]

31createBindingGroups :: [Declaration] -> [Declaration]

28createBindingGroups ds =

32createBindingGroups ds =

29 let

33 let

@@ -33,7 +37,7 @@ createBindingGroups ds =

33 verts = map (\d -> (d, getIdent d, usedNames d `intersect` allIdents)) values

37 verts = map (\d -> (d, getIdent d, usedNames d `intersect` allIdents)) values

34 sorted = map toBindingGroup $ stronglyConnComp verts

38 sorted = map toBindingGroup $ stronglyConnComp verts

35 in

39 in

36− map handleModuleDeclaration nonValues ++ sorted

40+ nonValues ++ sorted

38isValueDecl :: Declaration -> Bool

42isValueDecl :: Declaration -> Bool

39isValueDecl (ValueDeclaration _ _ _ _) = True

43isValueDecl (ValueDeclaration _ _ _ _) = True

@@ -52,7 +56,3 @@ fromValueDecl :: Declaration -> (Ident, Value)

52fromValueDecl (ValueDeclaration ident [] Nothing val) = (ident, val)

56fromValueDecl (ValueDeclaration ident [] Nothing val) = (ident, val)

53fromValueDecl (ValueDeclaration _ _ _ _) = error "Binders should have been desugared"

57fromValueDecl (ValueDeclaration _ _ _ _) = error "Binders should have been desugared"

54fromValueDecl _ = error "Expected ValueDeclaration"

58fromValueDecl _ = error "Expected ValueDeclaration"

55−

56−handleModuleDeclaration :: Declaration -> Declaration

57−handleModuleDeclaration (ModuleDeclaration name ds') = ModuleDeclaration name $ createBindingGroups ds'

58−handleModuleDeclaration other = other

src/Language/PureScript/CaseDeclarations.hs+8−6

@@ -13,11 +13,13 @@

13-----------------------------------------------------------------------------

15module Language.PureScript.CaseDeclarations (

16− desugarCases

16+ desugarCases,

17+ desugarCasesModule

17) where

18) where

19import Data.List (groupBy)

20import Data.List (groupBy)

20−import Control.Monad (join, unless)

21+import Control.Applicative ((<$>))

22+import Control.Monad (forM, join, unless)

21import Control.Monad.Error.Class

23import Control.Monad.Error.Class

23import Language.PureScript.Names

25import Language.PureScript.Names

@@ -25,6 +27,9 @@ import Language.PureScript.Values

25import Language.PureScript.Declarations

27import Language.PureScript.Declarations

26import Language.PureScript.Scope

28import Language.PureScript.Scope

30+desugarCasesModule :: [Module] -> Either String [Module]

31+desugarCasesModule ms = forM ms $ \(Module name ds) -> Module name <$> desugarCases ds

32+

28desugarCases :: [Declaration] -> Either String [Declaration]

33desugarCases :: [Declaration] -> Either String [Declaration]

29desugarCases = fmap join . mapM toDecls . groupBy inSameGroup

34desugarCases = fmap join . mapM toDecls . groupBy inSameGroup

@@ -39,9 +44,6 @@ toDecls ds@(ValueDeclaration ident bs _ _ : _) = do

39 unless (all ((== map length bs) . map length . fst) tuples) $

44 unless (all ((== map length bs) . map length . fst) tuples) $

40 throwError $ "Argument list lengths differ in declaration " ++ show ident

45 throwError $ "Argument list lengths differ in declaration " ++ show ident

41 return [makeCaseDeclaration ident tuples]

46 return [makeCaseDeclaration ident tuples]

42−toDecls [ModuleDeclaration name decls] = do

43− desugared <- desugarCases decls

44− return [ModuleDeclaration name desugared]

45toDecls ds = return ds

47toDecls ds = return ds

47toTuple :: Declaration -> ([[Binder]], (Maybe Guard, Value))

49toTuple :: Declaration -> ([[Binder]], (Maybe Guard, Value))

@@ -53,7 +55,7 @@ makeCaseDeclaration ident alternatives =

53 let

55 let

54 argPattern = map length . fst . head $ alternatives

56 argPattern = map length . fst . head $ alternatives

55 args = take (sum argPattern) $ unusedNames (ident, alternatives)

57 args = take (sum argPattern) $ unusedNames (ident, alternatives)

56− vars = map (\arg -> Var (Qualified global arg)) args

58+ vars = map (\arg -> Var (Qualified Nothing arg)) args

57 binders = [ (join bs, g, val) | (bs, (g, val)) <- alternatives ]

59 binders = [ (join bs, g, val) | (bs, (g, val)) <- alternatives ]

58 value = foldr (\args' ret -> Abs args' ret) (Case vars binders) (rearrange argPattern args)

60 value = foldr (\args' ret -> Abs args' ret) (Case vars binders) (rearrange argPattern args)

59 in

61 in

src/Language/PureScript/CodeGen/Externs.hs+24−16

@@ -13,29 +13,37 @@

13-----------------------------------------------------------------------------

15module Language.PureScript.CodeGen.Externs (

16− externToPs

16+ moduleToPs

17) where

19−import Data.Maybe (mapMaybe)

19+import Data.Maybe (maybeToList, mapMaybe)

20import qualified Data.Map as M

21import Language.PureScript.Declarations

22import Language.PureScript.TypeChecker.Monad

23import Language.PureScript.Pretty

24import Language.PureScript.Names

25+import Data.List (intercalate)

27+moduleToPs :: Module -> Environment -> String

28+moduleToPs (Module pname@(ProperName moduleName) decls) env =

29+ "module " ++ moduleName ++ " where\n" ++

30+ (intercalate "\n" . map (" " ++) . concatMap (declToPs (ModuleName pname) env) $ decls)

31+

26−externToPs :: Int -> ModulePath -> Environment -> Declaration -> Maybe String

32+declToPs :: ModuleName -> Environment -> Declaration -> [String]

27−externToPs indent path env (ValueDeclaration name _ _ _) = do

33+declToPs path env (ValueDeclaration name _ _ _) = maybeToList $ do

28 (ty, _) <- M.lookup (path, name) $ names env

34 (ty, _) <- M.lookup (path, name) $ names env

35+ return $ "foreign import " ++ show name ++ " :: " ++ prettyPrintType ty

36+declToPs path env (BindingGroupDeclaration vals) = do

37+ flip mapMaybe vals $ \(name, _) -> do

38+ (ty, _) <- M.lookup (path, name) $ names env

29− return $ replicate indent ' ' ++ "foreign import " ++ show name ++ " :: " ++ prettyPrintType ty

39+ return $ "foreign import " ++ show name ++ " :: " ++ prettyPrintType ty

30−externToPs indent path env (DataDeclaration name _ _) = do

40+declToPs path env (DataDeclaration name _ _) = maybeToList $ do

31 (kind, _) <- M.lookup (path, name) $ types env

41 (kind, _) <- M.lookup (path, name) $ types env

32− return $ replicate indent ' ' ++ "foreign import data " ++ show name ++ " :: " ++ prettyPrintKind kind

42+ return $ "foreign import data " ++ show name ++ " :: " ++ prettyPrintKind kind

33−externToPs indent _ _ (ExternMemberDeclaration member name ty) =

43+declToPs _ _ (ExternMemberDeclaration member name ty) =

34− return $ replicate indent ' ' ++ "foreign import member " ++ show member ++ " " ++ show name ++ " :: " ++ prettyPrintType ty

44+ return $ "foreign import member " ++ show member ++ " " ++ show name ++ " :: " ++ prettyPrintType ty

35−externToPs indent _ _ (ExternDataDeclaration name kind) =

45+declToPs _ _ (ExternDataDeclaration name kind) =

36− return $ replicate indent ' ' ++ "foreign import data " ++ show name ++ " :: " ++ prettyPrintKind kind

46+ return $ "foreign import data " ++ show name ++ " :: " ++ prettyPrintKind kind

37−externToPs indent _ _ (TypeSynonymDeclaration name args ty) =

47+declToPs _ _ (TypeSynonymDeclaration name args ty) =

38− return $ replicate indent ' ' ++ "type " ++ show name ++ " " ++ unwords args ++ " = " ++ prettyPrintType ty

48+ return $ "type " ++ show name ++ " " ++ unwords args ++ " = " ++ prettyPrintType ty

39−externToPs indent path env (ModuleDeclaration name decls) =

49+declToPs _ _ _ = []

40− return $ replicate indent ' ' ++ "module " ++ show name ++ " where\n" ++ unlines (mapMaybe (externToPs (indent + 2) (subModule path name) env) decls)

41−externToPs _ _ _ _ = Nothing

src/Language/PureScript/CodeGen/JS.hs+42−48

@@ -14,7 +14,8 @@

15module Language.PureScript.CodeGen.JS (

16 module AST,

17− declToJs

17+ declToJs,

18+ moduleToJs

18) where

19) where

20import Data.Maybe (mapMaybe)

21import Data.Maybe (mapMaybe)

@@ -31,52 +32,48 @@ import Language.PureScript.Pretty.Common

31import Language.PureScript.CodeGen.Monad

32import Language.PureScript.CodeGen.Monad

32import Language.PureScript.CodeGen.JS.AST as AST

33import Language.PureScript.CodeGen.JS.AST as AST

33import Language.PureScript.TypeChecker.Monad (NameKind(..))

34import Language.PureScript.TypeChecker.Monad (NameKind(..))

34−import Debug.Trace (trace)

36+moduleToJs :: Module -> Environment -> [JS]

37+moduleToJs (Module pname@(ProperName name) decls) env =

38+ [ JSVariableIntroduction (Ident name) Nothing

39+ , JSApp (JSFunction Nothing [Ident name]

40+ (JSBlock (concat $ mapMaybe (\decl -> declToJs (ModuleName pname) decl env) decls)))

41+ [JSAssignment (JSAssignVariable (Ident name))

42+ (JSBinary Or (JSVar (Ident name)) (JSObjectLiteral []))]

43+ ]

44+

36−declToJs :: Maybe Ident -> ModulePath -> Declaration -> Environment -> Maybe [JS]

45+declToJs :: ModuleName -> Declaration -> Environment -> Maybe [JS]

37−declToJs curMod mp (ValueDeclaration ident _ _ (Abs args ret)) e =

46+declToJs mp (ValueDeclaration ident _ _ (Abs args ret)) e =

38− Just $ JSFunction (Just ident) args (JSBlock [JSReturn (valueToJs mp e ret)]) :

47+ Just [ JSFunction (Just ident) args (JSBlock [JSReturn (valueToJs mp e ret)]),

39− maybe [] (return . setProperty (identToJs ident) (JSVar ident)) curMod

48+ setProperty (identToJs ident) (JSVar ident) mp ]

40−declToJs curMod mp (ValueDeclaration ident _ _ val) e =

49+declToJs mp (ValueDeclaration ident _ _ val) e =

41− Just $ JSVariableIntroduction ident (Just (valueToJs mp e val)) :

50+ Just [ JSVariableIntroduction ident (Just (valueToJs mp e val)),

42− maybe [] (return . setProperty (identToJs ident) (JSVar ident)) curMod

51+ setProperty (identToJs ident) (JSVar ident) mp ]

43−declToJs curMod mp (BindingGroupDeclaration vals) e = trace (show [ JSApp (JSFunction Nothing [] (JSBlock (concatMap (\(ident, val) ->

52+declToJs mp (BindingGroupDeclaration vals) e =

44− JSVariableIntroduction ident (Just (valueToJs mp e val)) :

45− maybe [] (return . setProperty (identToJs ident) (JSVar ident)) curMod

46− ) vals))) []

47− ]) $

48− Just [ JSApp (JSFunction Nothing [] (JSBlock (concatMap (\(ident, val) ->

53+ Just $ concatMap (\(ident, val) ->

49− JSVariableIntroduction ident (Just (valueToJs mp e val)) :

54+ [ JSVariableIntroduction ident (Just (valueToJs mp e val)),

50− maybe [] (return . setProperty (identToJs ident) (JSVar ident)) curMod

55+ setProperty (identToJs ident) (JSVar ident) mp ]

51− ) vals))) []

56+ ) vals

52− ]

53−declToJs curMod _ (ExternMemberDeclaration member ident _) _ =

57+declToJs mp (ExternMemberDeclaration member ident _) _ =

54− Just $ JSFunction (Just ident) [Ident "value"] (JSBlock [JSReturn (JSAccessor member (JSVar (Ident "value")))]) :

58+ Just [ JSFunction (Just ident) [Ident "value"] (JSBlock [JSReturn (JSAccessor member (JSVar (Ident "value")))]),

55− maybe [] (return . setProperty (show ident) (JSVar ident)) curMod

59+ setProperty (show ident) (JSVar ident) mp ]

56−declToJs curMod mp (DataDeclaration _ _ ctors) _ =

60+declToJs mp (DataDeclaration _ _ ctors) _ =

57 Just $ flip concatMap ctors $ \(pn@(ProperName ctor), maybeTy) ->

61 Just $ flip concatMap ctors $ \(pn@(ProperName ctor), maybeTy) ->

58 let

62 let

59 ctorJs =

63 ctorJs =

60 case maybeTy of

64 case maybeTy of

61− Nothing -> JSVariableIntroduction (Ident ctor) (Just (JSObjectLiteral [ ("ctor", JSStringLiteral (show (Qualified mp pn))) ]))

65+ Nothing -> JSVariableIntroduction (Ident ctor) (Just (JSObjectLiteral [ ("ctor", JSStringLiteral (show (Qualified (Just mp) pn))) ]))

62 Just _ -> JSFunction (Just (Ident ctor)) [Ident "value"]

66 Just _ -> JSFunction (Just (Ident ctor)) [Ident "value"]

63 (JSBlock [JSReturn

67 (JSBlock [JSReturn

64− (JSObjectLiteral [ ("ctor", JSStringLiteral (show (Qualified mp pn)))

68+ (JSObjectLiteral [ ("ctor", JSStringLiteral (show (Qualified (Just mp) pn)))

65 , ("value", JSVar (Ident "value")) ])])

69 , ("value", JSVar (Ident "value")) ])])

66− in ctorJs : maybe [] (return . setProperty ctor (JSVar (Ident ctor))) curMod

70+ in [ ctorJs, setProperty ctor (JSVar (Ident ctor)) mp ]

67−declToJs curMod mp (ModuleDeclaration pn@(ProperName name) decls) env =

68− Just $ [ JSVariableIntroduction (Ident name) Nothing

69− , JSApp (JSFunction Nothing [Ident name]

70− (JSBlock (concat $ mapMaybe (\decl -> declToJs (Just (Ident name)) (subModule mp pn) decl env) decls)))

71− [JSAssignment (JSAssignVariable (Ident name))

72− (JSBinary Or (JSVar (Ident name)) (JSObjectLiteral []))]] ++

73− maybe [] (return . setProperty name (JSVar (Ident name))) curMod

74−declToJs _ _ _ _ = Nothing

71+declToJs _ _ _ = Nothing

76−setProperty :: String -> JS -> Ident -> JS

73+setProperty :: String -> JS -> ModuleName -> JS

77−setProperty prop val curMod = JSAssignment (JSAssignProperty prop (JSAssignVariable curMod)) val

74+setProperty prop val (ModuleName (ProperName moduleName)) = JSAssignment (JSAssignProperty prop (JSAssignVariable (Ident moduleName))) val

79−valueToJs :: ModulePath -> Environment -> Value -> JS

76+valueToJs :: ModuleName -> Environment -> Value -> JS

80valueToJs _ _ (NumericLiteral n) = JSNumericLiteral n

77valueToJs _ _ (NumericLiteral n) = JSNumericLiteral n

81valueToJs _ _ (StringLiteral s) = JSStringLiteral s

78valueToJs _ _ (StringLiteral s) = JSStringLiteral s

82valueToJs _ _ (BooleanLiteral b) = JSBooleanLiteral b

79valueToJs _ _ (BooleanLiteral b) = JSBooleanLiteral b

@@ -94,19 +91,16 @@ valueToJs m e (Abs args val) = JSFunction Nothing args (JSBlock [JSReturn (value

94valueToJs m e (Unary op val) = JSUnary op (valueToJs m e val)

91valueToJs m e (Unary op val) = JSUnary op (valueToJs m e val)

95valueToJs m e (Binary op v1 v2) = JSBinary op (valueToJs m e v1) (valueToJs m e v2)

92valueToJs m e (Binary op v1 v2) = JSBinary op (valueToJs m e v1) (valueToJs m e v2)

96valueToJs m e (Var ident) = case M.lookup (qualify m ident) (names e) of

93valueToJs m e (Var ident) = case M.lookup (qualify m ident) (names e) of

97− Just (_, Alias aliasModule aliasIdent) -> qualifiedToJS identToJs (Qualified aliasModule aliasIdent)

94+ Just (_, Alias aliasModule aliasIdent) -> qualifiedToJS identToJs (Qualified (Just aliasModule) aliasIdent)

98 _ -> qualifiedToJS identToJs ident

95 _ -> qualifiedToJS identToJs ident

99valueToJs m e (TypedValue val _) = valueToJs m e val

96valueToJs m e (TypedValue val _) = valueToJs m e val

100valueToJs _ _ _ = error "Invalid argument to valueToJs"

97valueToJs _ _ _ = error "Invalid argument to valueToJs"

101

102qualifiedToJS :: (a -> String) -> Qualified a -> JS

99qualifiedToJS :: (a -> String) -> Qualified a -> JS

103−qualifiedToJS f (Qualified (ModulePath parts) a) =

100+qualifiedToJS f (Qualified (Just (ModuleName (ProperName m))) a) = JSAccessor (f a) (JSVar (Ident m))

104− delimited (f a : reverse (map show parts))

101+qualifiedToJS f (Qualified Nothing a) = JSVar (Ident (f a))

105− where delimited [part] = JSVar (Ident (part))

106− delimited (part:parts') = JSAccessor part (delimited parts')

107− delimited _ = error "Invalid argument to delimited"

108

102

109−bindersToJs :: ModulePath -> Environment -> [([Binder], Maybe Guard, Value)] -> [JS] -> Gen JS

103+bindersToJs :: ModuleName -> Environment -> [([Binder], Maybe Guard, Value)] -> [JS] -> Gen JS

110bindersToJs m e binders vals = do

104bindersToJs m e binders vals = do

111 setNextName $ firstUnusedName (binders, vals)

105 setNextName $ firstUnusedName (binders, vals)

112 valNames <- replicateM (length vals) fresh

106 valNames <- replicateM (length vals) fresh

@@ -122,7 +116,7 @@ bindersToJs m e binders vals = do

122 binderToJs m e v done'' b

116 binderToJs m e v done'' b

123 go _ _ _ _ = error "Invalid arguments to bindersToJs"

117 go _ _ _ _ = error "Invalid arguments to bindersToJs"

124

118

125−binderToJs :: ModulePath -> Environment -> String -> [JS] -> Binder -> Gen [JS]

119+binderToJs :: ModuleName -> Environment -> String -> [JS] -> Binder -> Gen [JS]

126binderToJs _ _ _ done NullBinder = return done

120binderToJs _ _ _ done NullBinder = return done

127binderToJs _ _ varName done (StringBinder str) =

121binderToJs _ _ varName done (StringBinder str) =

128 return [JSIfElse (JSBinary EqualTo (JSVar (Ident varName)) (JSStringLiteral str)) (JSBlock done) Nothing]

122 return [JSIfElse (JSBinary EqualTo (JSVar (Ident varName)) (JSStringLiteral str)) (JSBlock done) Nothing]

@@ -135,11 +129,11 @@ binderToJs _ _ varName done (BooleanBinder False) =

135binderToJs _ _ varName done (VarBinder ident) =

129binderToJs _ _ varName done (VarBinder ident) =

136 return (JSVariableIntroduction ident (Just (JSVar (Ident varName))) : done)

130 return (JSVariableIntroduction ident (Just (JSVar (Ident varName))) : done)

137binderToJs m _ varName done (NullaryBinder ctor) =

131binderToJs m _ varName done (NullaryBinder ctor) =

138− return [JSIfElse (JSBinary EqualTo (JSAccessor "ctor" (JSVar (Ident varName))) (JSStringLiteral (show (uncurry Qualified $ qualify m ctor)))) (JSBlock done) Nothing]

132+ return [JSIfElse (JSBinary EqualTo (JSAccessor "ctor" (JSVar (Ident varName))) (JSStringLiteral (show ((\(mp, nm) -> Qualified (Just mp) nm) $ qualify m ctor)))) (JSBlock done) Nothing]

139binderToJs m e varName done (UnaryBinder ctor b) = do

133binderToJs m e varName done (UnaryBinder ctor b) = do

140 value <- fresh

134 value <- fresh

141 js <- binderToJs m e value done b

135 js <- binderToJs m e value done b

142− 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]

136+ return [JSIfElse (JSBinary EqualTo (JSAccessor "ctor" (JSVar (Ident varName))) (JSStringLiteral (show ((\(mp, nm) -> Qualified (Just mp) nm) $ qualify m ctor)))) (JSBlock (JSVariableIntroduction (Ident value) (Just (JSAccessor "value" (JSVar (Ident varName)))) : js)) Nothing]

143binderToJs m e varName done (ObjectBinder bs) = go done bs

137binderToJs m e varName done (ObjectBinder bs) = go done bs

144 where

138 where

145 go :: [JS] -> [(String, Binder)] -> Gen [JS]

139 go :: [JS] -> [(String, Binder)] -> Gen [JS]

@@ -174,7 +168,7 @@ binderToJs m e varName done (NamedBinder ident binder) = do

174 js <- binderToJs m e varName done binder

168 js <- binderToJs m e varName done binder

175 return (JSVariableIntroduction ident (Just (JSVar (Ident varName))) : js)

169 return (JSVariableIntroduction ident (Just (JSVar (Ident varName))) : js)

176

170

177−statementToJs :: ModulePath -> Environment -> Statement -> JS

171+statementToJs :: ModuleName -> Environment -> Statement -> JS

178statementToJs m e (VariableIntroduction ident value) = JSVariableIntroduction ident (Just (valueToJs m e value))

172statementToJs m e (VariableIntroduction ident value) = JSVariableIntroduction ident (Just (valueToJs m e value))

179statementToJs m e (Assignment target value) = JSAssignment (JSAssignVariable target) (valueToJs m e value)

173statementToJs m e (Assignment target value) = JSAssignment (JSAssignVariable target) (valueToJs m e value)

180statementToJs m e (While cond sts) = JSWhile (valueToJs m e cond) (JSBlock (map (statementToJs m e) sts))

174statementToJs m e (While cond sts) = JSWhile (valueToJs m e cond) (JSBlock (map (statementToJs m e) sts))

src/Language/PureScript/Declarations.hs+3−2

@@ -29,6 +29,8 @@ data Associativity = Infixl | Infixr deriving (Show, D.Data, D.Typeable)

30data Fixity = Fixity Associativity Precedence deriving (Show, D.Data, D.Typeable)

32+data Module = Module ProperName [Declaration]

33+

32data Declaration

34data Declaration

33 = DataDeclaration ProperName [String] [(ProperName, Maybe PolyType)]

35 = DataDeclaration ProperName [String] [(ProperName, Maybe PolyType)]

34 | TypeSynonymDeclaration ProperName [String] PolyType

36 | TypeSynonymDeclaration ProperName [String] PolyType

@@ -39,6 +41,5 @@ data Declaration

39 | ExternMemberDeclaration String Ident PolyType

41 | ExternMemberDeclaration String Ident PolyType

40 | ExternDataDeclaration ProperName Kind

42 | ExternDataDeclaration ProperName Kind

41 | FixityDeclaration Fixity String

43 | FixityDeclaration Fixity String

42− | ModuleDeclaration ProperName [Declaration]

43− | ImportDeclaration ModulePath (Maybe [Ident])

44+ | ImportDeclaration ModuleName (Maybe [Ident])

44 deriving (Show, D.Data, D.Typeable)

45 deriving (Show, D.Data, D.Typeable)

src/Language/PureScript/Names.hs+9−19

@@ -17,7 +17,6 @@

17module Language.PureScript.Names where

19import Data.Data

20−import Data.List (inits, intercalate)

22data Ident = Ident String | Op String deriving (Eq, Ord, Data, Typeable)

21data Ident = Ident String | Op String deriving (Eq, Ord, Data, Typeable)

@@ -30,26 +29,17 @@ newtype ProperName = ProperName { runProperName :: String } deriving (Eq, Ord, D

30instance Show ProperName where

29instance Show ProperName where

31 show = runProperName

30 show = runProperName

33−data ModulePath = ModulePath [ProperName] deriving (Eq, Ord, Data, Typeable)

32+data ModuleName = ModuleName ProperName deriving (Eq, Ord, Data, Typeable)

35−instance Show ModulePath where

34+instance Show ModuleName where

36− show (ModulePath segments) = intercalate "." $ map show segments

35+ show (ModuleName name) = show name

38−subModule :: ModulePath -> ProperName -> ModulePath

39−subModule (ModulePath mp) name = ModulePath (mp ++ [name])

40−

41−global :: ModulePath

42−global = ModulePath []

43−

44−data Qualified a = Qualified ModulePath a deriving (Eq, Ord, Data, Typeable)

37+data Qualified a = Qualified (Maybe ModuleName) a deriving (Eq, Ord, Data, Typeable)

46instance (Show a) => Show (Qualified a) where

39instance (Show a) => Show (Qualified a) where

47− show (Qualified (ModulePath names) a) = intercalate "." (map show names ++ [show a])

40+ show (Qualified Nothing a) = show a

48−

41+ show (Qualified (Just (ModuleName name)) a) = show name ++ "." ++ show a

49−qualify :: ModulePath -> Qualified a -> (ModulePath, a)

50−qualify mp (Qualified (ModulePath []) a) = (mp, a)

51−qualify _ (Qualified mp a) = (mp, a)

53−nameResolution :: ModulePath -> Qualified a -> [(ModulePath, a)]

43+qualify :: ModuleName -> Qualified a -> (ModuleName, a)

54−nameResolution (ModulePath mp) (Qualified (ModulePath []) a) = [ (ModulePath mp', a) | mp' <- reverse $ inits mp ]

44+qualify m (Qualified Nothing a) = (m, a)

55−nameResolution _ (Qualified mp a) = [(mp, a)]

45+qualify _ (Qualified (Just m) a) = (m, a)

src/Language/PureScript/Operators.hs+12−15

@@ -33,12 +33,12 @@ import qualified Text.Parsec as P

33import qualified Text.Parsec.Pos as P

34import qualified Text.Parsec.Expr as P

36−rebracket :: [Declaration] -> Either String [Declaration]

36+rebracket :: [Module] -> Either String [Module]

37−rebracket ds = do

37+rebracket ms = forM ms $ \(Module name ds) -> do

38− m <- collectFixities ds

38+ m <- collectFixities (ModuleName name) ds

39 let opTable = customOperatorTable m

40 ds' <- G.everywhereM' (G.mkM (matchOperators opTable)) ds

41− return $ G.everywhere (G.mkT removeParens) ds'

41+ return $ Module name $ G.everywhere (G.mkT removeParens) ds'

43removeParens :: Value -> Value

44removeParens (Parens val) = val

@@ -85,22 +85,19 @@ matchOp op = do

85 ident <- parseOp

86 guard (ident == op)

88−collectFixities :: [Declaration] -> Either String (M.Map (Qualified Ident) Fixity)

88+collectFixities :: ModuleName -> [Declaration] -> Either String (M.Map (Qualified Ident) Fixity)

89−collectFixities = go M.empty global

89+collectFixities = go M.empty

90 where

91− go :: M.Map (Qualified Ident) Fixity -> ModulePath -> [Declaration] -> Either String (M.Map (Qualified Ident) Fixity)

91+ go :: M.Map (Qualified Ident) Fixity -> ModuleName -> [Declaration] -> Either String (M.Map (Qualified Ident) Fixity)

92 go m _ [] = return m

93− go m p (FixityDeclaration fixity name : rest) = do

93+ go m moduleName (FixityDeclaration fixity name : rest) = do

94− let qual = Qualified p (Op name)

94+ let qual = Qualified (Just moduleName) (Op name)

95 when (qual `M.member` m) (Left $ "redefined fixity for " ++ show name)

96− go (M.insert qual fixity m) p rest

96+ go (M.insert qual fixity m) moduleName rest

97− go m p (ModuleDeclaration name decls : rest) = do

98− m' <- go m (subModule p name) decls

99− go m' p rest

100− go m p (_:ds) = go m p ds

97+ go m moduleName (_:ds) = go m moduleName ds

101

102globalOp :: String -> Qualified Ident

99globalOp :: String -> Qualified Ident

103−globalOp = Qualified global . Op

100+globalOp = Qualified Nothing . Op

104

101

105builtIns :: [(Qualified Ident, Value -> Value -> Value, Precedence, Associativity)]

102builtIns :: [(Qualified Ident, Value -> Value -> Value, Precedence, Associativity)]

106builtIns = [ (globalOp "<", Binary LessThan, 3, Infixl)

103builtIns = [ (globalOp "<", Binary LessThan, 3, Infixl)

src/Language/PureScript/Parser/Common.hs+3−4

@@ -188,11 +188,10 @@ properName :: P.Parsec String u ProperName

188properName = lexeme $ ProperName <$> P.try ((:) <$> P.upper <*> many (PT.identLetter langDef) P.<?> "name")

189

190parseQualified :: P.Parsec String ParseState a -> P.Parsec String ParseState (Qualified a)

191−parseQualified parser = part global

191+parseQualified parser = qual

192 where

193− part path = (do name <- P.try (properName <* delimiter)

193+ qual = (Qualified <$> (Just . ModuleName <$> P.try (properName <* delimiter)) <*> parser)

194− part (subModule path name))

195− <|> (Qualified path <$> P.try parser)

194+ <|> (Qualified Nothing <$> P.try parser)

196 delimiter = indented *> dot

195 delimiter = indented *> dot

197

196

198integerOrFloat :: P.Parsec String u (Either Integer Double)

197integerOrFloat :: P.Parsec String u (Either Integer Double)

src/Language/PureScript/Parser/Declarations.hs+15−18

@@ -14,7 +14,8 @@

15module Language.PureScript.Parser.Declarations (

16 parseDeclaration,

17− parseDeclarations

17+ parseModule,

18+ parseModules

18) where

19) where

20import Control.Applicative

21import Control.Applicative

@@ -84,25 +85,13 @@ parseFixityDeclaration = do

84 name <- operator

85 name <- operator

85 return $ FixityDeclaration fixity name

86 return $ FixityDeclaration fixity name

87−parseModuleDeclaration :: P.Parsec String ParseState Declaration

88−parseModuleDeclaration = do

89− reserved "module"

90− indented

91− name <- properName

92− lexeme $ P.string "where"

93− decls <- mark (P.many (same *> parseDeclaration))

94− return $ ModuleDeclaration name decls

95−

96−parseModulePath :: P.Parsec String ParseState ModulePath

97−parseModulePath = ModulePath <$> properName `sepBy1` dot

98−

99parseImportDeclaration :: P.Parsec String ParseState Declaration

88parseImportDeclaration :: P.Parsec String ParseState Declaration

100parseImportDeclaration = do

89parseImportDeclaration = do

101 reserved "import"

90 reserved "import"

102 indented

91 indented

103− modulePath <- parseModulePath

92+ moduleName <- ModuleName <$> properName

104 idents <- P.optionMaybe $ parens $ commaSep1 parseIdent

93 idents <- P.optionMaybe $ parens $ commaSep1 parseIdent

105− return $ ImportDeclaration modulePath idents

94+ return $ ImportDeclaration moduleName idents

106

107parseDeclaration :: P.Parsec String ParseState Declaration

96parseDeclaration :: P.Parsec String ParseState Declaration

108parseDeclaration = P.choice

97parseDeclaration = P.choice

@@ -112,8 +101,16 @@ parseDeclaration = P.choice

112 , parseValueDeclaration

101 , parseValueDeclaration

113 , parseExternDeclaration

102 , parseExternDeclaration

114 , parseFixityDeclaration

103 , parseFixityDeclaration

115− , parseModuleDeclaration

116 , parseImportDeclaration ] P.<?> "declaration"

104 , parseImportDeclaration ] P.<?> "declaration"

117

105

106+parseModule :: P.Parsec String ParseState Module

107+parseModule = do

108+ reserved "module"

109+ indented

110+ name <- properName

111+ lexeme $ P.string "where"

112+ decls <- mark (P.many (same *> parseDeclaration))

113+ return $ Module name decls

114+

118−parseDeclarations :: P.Parsec String ParseState [Declaration]

115+parseModules :: P.Parsec String ParseState [Module]

119−parseDeclarations = whiteSpace *> mark (P.many (same *> parseDeclaration)) <* P.eof

116+parseModules = whiteSpace *> mark (P.many (same *> parseModule)) <* P.eof

src/Language/PureScript/Scope.hs+1−1

@@ -32,7 +32,7 @@ usedNames val = nub $ everything (++) (mkQ [] namesV `extQ` namesS `extQ` namesB

32 where

33 namesV :: Value -> [Ident]

34 namesV (Abs args _) = args

35− namesV (Var (Qualified (ModulePath []) name)) = [name]

35+ namesV (Var (Qualified Nothing name)) = [name]

36 namesV _ = []

37 namesS :: Statement -> [Ident]

38 namesS (VariableIntroduction name _) = [name]

src/Language/PureScript/TypeChecker.hs+57−69

@@ -35,114 +35,102 @@ import Language.PureScript.Declarations

35import Control.Monad.State

36import Control.Monad.Error

38−typeCheckAll :: [Declaration] -> Check ()

38+typeCheckAll :: ModuleName -> [Declaration] -> Check ()

39−typeCheckAll [] = return ()

39+typeCheckAll _ [] = return ()

40−typeCheckAll (DataDeclaration name args dctors : rest) = do

40+typeCheckAll moduleName (DataDeclaration name args dctors : rest) = do

41 rethrow (("Error in type constructor " ++ show name ++ ":\n") ++) $ do

42 env <- getEnv

43− modulePath <- checkModulePath `fmap` get

44− guardWith (show name ++ " is already defined") $ not $ M.member (modulePath, name) (types env)

43+ guardWith (show name ++ " is already defined") $ not $ M.member (moduleName, name) (types env)

45− ctorKind <- kindsOf (Just name) args (mapMaybe snd dctors)

44+ ctorKind <- kindsOf moduleName (Just name) args (mapMaybe snd dctors)

46− putEnv $ env { types = M.insert (modulePath, name) (ctorKind, Data) (types env) }

45+ putEnv $ env { types = M.insert (moduleName, name) (ctorKind, Data) (types env) }

47 forM_ dctors $ \(dctor, maybeTy) ->

46 forM_ dctors $ \(dctor, maybeTy) ->

48 rethrow (("Error in data constructor " ++ show name ++ ":\n") ++) $ do

47 rethrow (("Error in data constructor " ++ show name ++ ":\n") ++) $ do

49 env' <- getEnv

48 env' <- getEnv

50− guardWith (show dctor ++ " is already defined") $ not $ M.member (modulePath, dctor) (dataConstructors env')

49+ guardWith (show dctor ++ " is already defined") $ not $ M.member (moduleName, dctor) (dataConstructors env')

51− let retTy = foldl TypeApp (TypeConstructor (Qualified modulePath name)) (map TypeVar args)

50+ let retTy = foldl TypeApp (TypeConstructor (Qualified (Just moduleName) name)) (map TypeVar args)

52 let dctorTy = maybe retTy (\ty -> Function [ty] retTy) maybeTy

51 let dctorTy = maybe retTy (\ty -> Function [ty] retTy) maybeTy

53 let polyType = mkForAll args dctorTy

52 let polyType = mkForAll args dctorTy

54− putEnv $ env' { dataConstructors = M.insert (modulePath, dctor) polyType (dataConstructors env') }

53+ putEnv $ env' { dataConstructors = M.insert (moduleName, dctor) polyType (dataConstructors env') }

55− typeCheckAll rest

54+ typeCheckAll moduleName rest

56−typeCheckAll (TypeSynonymDeclaration name args ty : rest) = do

55+typeCheckAll moduleName (TypeSynonymDeclaration name args ty : rest) = do

57 rethrow (("Error in type synonym " ++ show name ++ ":\n") ++) $ do

56 rethrow (("Error in type synonym " ++ show name ++ ":\n") ++) $ do

58 env <- getEnv

57 env <- getEnv

59− modulePath <- checkModulePath `fmap` get

60− guardWith (show name ++ " is already defined") $ not $ M.member (modulePath, name) (types env)

58+ guardWith (show name ++ " is already defined") $ not $ M.member (moduleName, name) (types env)

61− kind <- kindsOf (Just name) args [ty]

59+ kind <- kindsOf moduleName (Just name) args [ty]

62− putEnv $ env { types = M.insert (modulePath, name) (kind, TypeSynonym) (types env)

60+ putEnv $ env { types = M.insert (moduleName, name) (kind, TypeSynonym) (types env)

63− , typeSynonyms = M.insert (modulePath, name) (args, ty) (typeSynonyms env) }

61+ , typeSynonyms = M.insert (moduleName, name) (args, ty) (typeSynonyms env) }

64− typeCheckAll rest

62+ typeCheckAll moduleName rest

65−typeCheckAll (TypeDeclaration _ _ : _) = error "Type declarations should have been removed"

63+typeCheckAll _ (TypeDeclaration _ _ : _) = error "Type declarations should have been removed"

66−typeCheckAll (ValueDeclaration name [] Nothing val : rest) = do

64+typeCheckAll moduleName (ValueDeclaration name [] Nothing val : rest) = do

67 rethrow (("Error in declaration " ++ show name ++ ":\n") ++) $ do

65 rethrow (("Error in declaration " ++ show name ++ ":\n") ++) $ do

68 env <- getEnv

66 env <- getEnv

69− modulePath <- checkModulePath `fmap` get

70− case M.lookup (modulePath, name) (names env) of

67+ case M.lookup (moduleName, name) (names env) of

71 Just _ -> throwError $ show name ++ " is already defined"

68 Just _ -> throwError $ show name ++ " is already defined"

72 Nothing -> do

69 Nothing -> do

73− [ty] <- typesOf [(name, val)]

70+ [ty] <- typesOf moduleName [(name, val)]

74− putEnv (env { names = M.insert (modulePath, name) (ty, Value) (names env) })

71+ putEnv (env { names = M.insert (moduleName, name) (ty, Value) (names env) })

75− typeCheckAll rest

72+ typeCheckAll moduleName rest

76−typeCheckAll (ValueDeclaration _ _ _ _ : _) = error "Binders were not desugared"

73+typeCheckAll _ (ValueDeclaration _ _ _ _ : _) = error "Binders were not desugared"

77−typeCheckAll (BindingGroupDeclaration vals : rest) = do

74+typeCheckAll moduleName (BindingGroupDeclaration vals : rest) = do

78 rethrow (("Error in binding group " ++ show (map fst vals) ++ ":\n") ++) $ do

75 rethrow (("Error in binding group " ++ show (map fst vals) ++ ":\n") ++) $ do

79− modulePath <- checkModulePath `fmap` get

80 forM_ (map fst vals) $ \name -> do

76 forM_ (map fst vals) $ \name -> do

81 env <- getEnv

77 env <- getEnv

82− case M.lookup (modulePath, name) (names env) of

78+ case M.lookup (moduleName, name) (names env) of

83 Just _ -> throwError $ show name ++ " is already defined"

79 Just _ -> throwError $ show name ++ " is already defined"

84 Nothing -> return ()

80 Nothing -> return ()

85− tys <- typesOf vals

81+ tys <- typesOf moduleName vals

86 forM (zip (map fst vals) tys) $ \(name, ty) ->

82 forM (zip (map fst vals) tys) $ \(name, ty) ->

87− modifyEnv $ \env -> env { names = M.insert (modulePath, name) (ty, Value) (names env) }

83+ modifyEnv $ \env -> env { names = M.insert (moduleName, name) (ty, Value) (names env) }

88− typeCheckAll rest

84+ typeCheckAll moduleName rest

89−typeCheckAll (ExternDataDeclaration name kind : rest) = do

85+typeCheckAll moduleName (ExternDataDeclaration name kind : rest) = do

90 env <- getEnv

86 env <- getEnv

91− modulePath <- checkModulePath `fmap` get

92− guardWith (show name ++ " is already defined") $ not $ M.member (modulePath, name) (types env)

87+ guardWith (show name ++ " is already defined") $ not $ M.member (moduleName, name) (types env)

93− putEnv $ env { types = M.insert (modulePath, name) (kind, TypeSynonym) (types env) }

88+ putEnv $ env { types = M.insert (moduleName, name) (kind, TypeSynonym) (types env) }

94− typeCheckAll rest

89+ typeCheckAll moduleName rest

95−typeCheckAll (ExternMemberDeclaration member name ty : rest) = do

90+typeCheckAll moduleName (ExternMemberDeclaration member name ty : rest) = do

96 rethrow (("Error in foreign import member declaration " ++ show name ++ ":\n") ++) $ do

91 rethrow (("Error in foreign import member declaration " ++ show name ++ ":\n") ++) $ do

97 env <- getEnv

92 env <- getEnv

98− modulePath <- checkModulePath `fmap` get

99− kind <- kindOf ty

93+ kind <- kindOf moduleName ty

100 guardWith "Expected kind *" $ kind == Star

94 guardWith "Expected kind *" $ kind == Star

101− case M.lookup (modulePath, name) (names env) of

95+ case M.lookup (moduleName, name) (names env) of

102 Just _ -> throwError $ show name ++ " is already defined"

96 Just _ -> throwError $ show name ++ " is already defined"

103 Nothing -> case ty of

97 Nothing -> case ty of

104 _ | isSingleArgumentFunction ty -> do

98 _ | isSingleArgumentFunction ty -> do

105− putEnv (env { names = M.insert (modulePath, name) (ty, Extern) (names env)

99+ putEnv (env { names = M.insert (moduleName, name) (ty, Extern) (names env)

106− , members = M.insert (modulePath, name) member (members env) })

100+ , members = M.insert (moduleName, name) member (members env) })

107 | otherwise -> throwError "Foreign member declarations must have function types, with an single argument."

101 | otherwise -> throwError "Foreign member declarations must have function types, with an single argument."

108− typeCheckAll rest

102+ typeCheckAll moduleName rest

109 where

103 where

110 isSingleArgumentFunction (Function [_] _) = True

104 isSingleArgumentFunction (Function [_] _) = True

111 isSingleArgumentFunction (ForAll _ t) = isSingleArgumentFunction t

105 isSingleArgumentFunction (ForAll _ t) = isSingleArgumentFunction t

112 isSingleArgumentFunction _ = False

106 isSingleArgumentFunction _ = False

113−typeCheckAll (ExternDeclaration name ty : rest) = do

107+typeCheckAll moduleName (ExternDeclaration name ty : rest) = do

114 rethrow (("Error in foreign import declaration " ++ show name ++ ":\n") ++) $ do

108 rethrow (("Error in foreign import declaration " ++ show name ++ ":\n") ++) $ do

115 env <- getEnv

109 env <- getEnv

116− modulePath <- checkModulePath `fmap` get

117− kind <- kindOf ty

110+ kind <- kindOf moduleName ty

118 guardWith "Expected kind *" $ kind == Star

111 guardWith "Expected kind *" $ kind == Star

119− case M.lookup (modulePath, name) (names env) of

112+ case M.lookup (moduleName, name) (names env) of

120 Just _ -> throwError $ show name ++ " is already defined"

113 Just _ -> throwError $ show name ++ " is already defined"

121− Nothing -> putEnv (env { names = M.insert (modulePath, name) (ty, Extern) (names env) })

114+ Nothing -> putEnv (env { names = M.insert (moduleName, name) (ty, Extern) (names env) })

122− typeCheckAll rest

115+ typeCheckAll moduleName rest

123−typeCheckAll (FixityDeclaration _ name : rest) = do

116+typeCheckAll moduleName (FixityDeclaration _ name : rest) = do

124− typeCheckAll rest

117+ typeCheckAll moduleName rest

125 env <- getEnv

118 env <- getEnv

126− modulePath <- checkModulePath `fmap` get

127− guardWith ("Fixity declaration with no binding: " ++ name) $ M.member (modulePath, Op name) $ names env

119+ guardWith ("Fixity declaration with no binding: " ++ name) $ M.member (moduleName, Op name) $ names env

128−typeCheckAll (ModuleDeclaration name decls : rest) = do

129− withModule name $ typeCheckAll decls

130− typeCheckAll rest

131−typeCheckAll (ImportDeclaration modulePath idents : rest) = do

120+typeCheckAll currentModule (ImportDeclaration moduleName idents : rest) = do

132 env <- getEnv

121 env <- getEnv

133− currentModule <- checkModulePath `fmap` get

134 rethrow errorMessage $ do

122 rethrow errorMessage $ do

135− guardWith ("Module " ++ show modulePath ++ " does not exist") $ moduleExists env

123+ guardWith ("Module " ++ show moduleName ++ " does not exist") $ moduleExists env

136 case idents of

124 case idents of

137− Nothing -> bindIdents (map snd $ filterModule env) currentModule env

125+ Nothing -> bindIdents (map snd $ filterModule env) env

138− Just idents' -> bindIdents idents' currentModule env

126+ Just idents' -> bindIdents idents' env

139− typeCheckAll rest

127+ typeCheckAll moduleName rest

140− where errorMessage = (("Error in import declaration " ++ show modulePath ++ ":\n") ++)

128+ where errorMessage = (("Error in import declaration " ++ show moduleName ++ ":\n") ++)

141− filterModule = filter ((== modulePath) . fst) . M.keys . names

129+ filterModule = filter ((== moduleName) . fst) . M.keys . names

142 moduleExists env = not $ null $ filterModule env

130 moduleExists env = not $ null $ filterModule env

143− bindIdents idents' currentModule env =

131+ bindIdents idents' env =

144 forM_ idents' $ \ident -> do

132 forM_ idents' $ \ident -> do

145 guardWith (show currentModule ++ "." ++ show ident ++ " is already defined") $ (currentModule, ident) `M.notMember` names env

133 guardWith (show currentModule ++ "." ++ show ident ++ " is already defined") $ (currentModule, ident) `M.notMember` names env

146− case (modulePath, ident) `M.lookup` names env of

134+ case (moduleName, ident) `M.lookup` names env of

147− Just (pt, _) -> modifyEnv (\e -> e { names = M.insert (currentModule, ident) (pt, Alias modulePath ident) (names e) })

135+ Just (pt, _) -> modifyEnv (\e -> e { names = M.insert (currentModule, ident) (pt, Alias moduleName ident) (names e) })

148− Nothing -> throwError (show modulePath ++ "." ++ show ident ++ " is undefined")

136+ Nothing -> throwError (show moduleName ++ "." ++ show ident ++ " is undefined")

src/Language/PureScript/TypeChecker/Kinds.hs+8−7

@@ -28,6 +28,7 @@ import Language.PureScript.Unknown

29import Control.Monad.State

30import Control.Monad.Error

31+import Control.Monad.Reader

32import Control.Applicative

33import Control.Applicative

@@ -53,11 +54,11 @@ instance Unifiable Kind where

53 unknowns (FunKind k1 k2) = unknowns k1 ++ unknowns k2

54 unknowns (FunKind k1 k2) = unknowns k1 ++ unknowns k2

54 unknowns _ = []

55 unknowns _ = []

56−kindOf :: Type -> Check Kind

57+kindOf :: ModuleName -> Type -> Check Kind

57−kindOf ty = fmap (\(k, _, _) -> k) . runSubst $ starIfUnknown <$> infer Nothing M.empty ty

58+kindOf moduleName ty = fmap (\(k, _, _) -> k) . runSubst (SubstContext moduleName) $ starIfUnknown <$> infer Nothing M.empty ty

59−kindsOf :: Maybe ProperName -> [String] -> [Type] -> Check Kind

60+kindsOf :: ModuleName -> Maybe ProperName -> [String] -> [Type] -> Check Kind

60−kindsOf name args ts = fmap (starIfUnknown . (\(k, _, _) -> k)) . runSubst $ do

61+kindsOf moduleName name args ts = fmap (starIfUnknown . (\(k, _, _) -> k)) . runSubst (SubstContext moduleName) $ do

61 tyCon <- fresh

62 tyCon <- fresh

62 kargs <- replicateM (length args) fresh

63 kargs <- replicateM (length args) fresh

63 ks <- inferAll (fmap (\pn -> (pn, tyCon)) name) (M.fromList (zip args kargs)) ts

64 ks <- inferAll (fmap (\pn -> (pn, tyCon)) name) (M.fromList (zip args kargs)) ts

@@ -92,11 +93,11 @@ infer _ m (TypeVar v) =

92 case M.lookup v m of

93 case M.lookup v m of

93 Just k -> return k

94 Just k -> return k

94 Nothing -> throwError $ "Unbound type variable " ++ v

95 Nothing -> throwError $ "Unbound type variable " ++ v

95−infer (Just (name, k)) _ (TypeConstructor (Qualified (ModulePath []) pn)) | name == pn = return k

96+infer (Just (name, k)) _ (TypeConstructor (Qualified Nothing pn)) | name == pn = return k

96infer _ _ (TypeConstructor v) = do

97infer _ _ (TypeConstructor v) = do

97 env <- liftCheck getEnv

98 env <- liftCheck getEnv

98− modulePath <- checkModulePath `fmap` get

99+ moduleName <- substCurrentModule `fmap` ask

99− case M.lookup (qualify modulePath v) (types env) of

100+ case M.lookup (qualify moduleName v) (types env) of

100 Nothing -> throwError $ "Unknown type constructor '" ++ show v ++ "'"

101 Nothing -> throwError $ "Unknown type constructor '" ++ show v ++ "'"

101 Just (kind, _) -> return kind

102 Just (kind, _) -> return kind

102infer name m (TypeApp t1 t2) = do

103infer name m (TypeApp t1 t2) = do

src/Language/PureScript/TypeChecker/Monad.hs+25−34

@@ -28,25 +28,26 @@ import Data.Monoid

28import Control.Applicative

29import Control.Monad.State

30import Control.Monad.Error

31+import Control.Monad.Reader

32import qualified Data.Map as M

33import qualified Data.Map as M

34−data NameKind = Value | Extern | Alias ModulePath Ident | LocalVariable deriving Show

35+data NameKind = Value | Extern | Alias ModuleName Ident | LocalVariable deriving Show

36data TypeDeclarationKind = Data | ExternData | TypeSynonym deriving Show

37data TypeDeclarationKind = Data | ExternData | TypeSynonym deriving Show

38data Environment = Environment

39data Environment = Environment

39− { names :: M.Map (ModulePath, Ident) (Type, NameKind)

40+ { names :: M.Map (ModuleName, Ident) (Type, NameKind)

40− , types :: M.Map (ModulePath, ProperName) (Kind, TypeDeclarationKind)

41+ , types :: M.Map (ModuleName, ProperName) (Kind, TypeDeclarationKind)

41− , dataConstructors :: M.Map (ModulePath, ProperName) Type

42+ , dataConstructors :: M.Map (ModuleName, ProperName) Type

42− , typeSynonyms :: M.Map (ModulePath, ProperName) ([String], Type)

43+ , typeSynonyms :: M.Map (ModuleName, ProperName) ([String], Type)

43− , members :: M.Map (ModulePath, Ident) String

44+ , members :: M.Map (ModuleName, Ident) String

44 } deriving (Show)

45 } deriving (Show)

46emptyEnvironment :: Environment

47emptyEnvironment :: Environment

47emptyEnvironment = Environment M.empty M.empty M.empty M.empty M.empty

48emptyEnvironment = Environment M.empty M.empty M.empty M.empty M.empty

49−bindNames :: (MonadState CheckState m) => M.Map (ModulePath, Ident) (Type, NameKind) -> m a -> m a

50+bindNames :: (MonadState CheckState m) => M.Map (ModuleName, Ident) (Type, NameKind) -> m a -> m a

50bindNames newNames action = do

51bindNames newNames action = do

51 orig <- get

52 orig <- get

52 modify $ \st -> st { checkEnv = (checkEnv st) { names = newNames `M.union` (names . checkEnv $ st) } }

53 modify $ \st -> st { checkEnv = (checkEnv st) { names = newNames `M.union` (names . checkEnv $ st) } }

@@ -54,17 +55,14 @@ bindNames newNames action = do

54 modify $ \st -> st { checkEnv = (checkEnv st) { names = names . checkEnv $ orig } }

55 modify $ \st -> st { checkEnv = (checkEnv st) { names = names . checkEnv $ orig } }

55 return a

56 return a

57−bindLocalVariables :: (Functor m, MonadState CheckState m) => [(Ident, Type)] -> m a -> m a

58+bindLocalVariables :: (Functor m, MonadState CheckState m) => ModuleName -> [(Ident, Type)] -> m a -> m a

58−bindLocalVariables bindings action = do

59+bindLocalVariables moduleName bindings action =

59− modulePath <- checkModulePath `fmap` get

60− bindNames (M.fromList $ flip map bindings $ \(name, ty) -> ((modulePath, name), (ty, LocalVariable))) action

60+ bindNames (M.fromList $ flip map bindings $ \(name, ty) -> ((moduleName, name), (ty, LocalVariable))) action

62−lookupVariable :: (Functor m, MonadState CheckState m, MonadError String m) => Qualified Ident -> m Type

62+lookupVariable :: (Functor m, MonadState CheckState m, MonadError String m) => ModuleName -> Qualified Ident -> m Type

63−lookupVariable var = do

63+lookupVariable currentModule (Qualified moduleName var) = do

64 env <- getEnv

65− modulePath <- checkModulePath <$> get

65+ case M.lookup (fromMaybe currentModule moduleName, var) (names env) of

66− let tries = map (First . flip M.lookup (names env)) (nameResolution modulePath var)

67− case getFirst (mconcat tries) of

68 Nothing -> throwError $ show var ++ " is undefined"

66 Nothing -> throwError $ show var ++ " is undefined"

69 Just (ty, _) -> return ty

67 Just (ty, _) -> return ty

@@ -73,7 +71,6 @@ data AnyUnifiable where

74data CheckState = CheckState { checkEnv :: Environment

72data CheckState = CheckState { checkEnv :: Environment

75 , checkNextVar :: Int

73 , checkNextVar :: Int

76− , checkModulePath :: ModulePath

77 }

74 }

79newtype Check a = Check { unCheck :: StateT CheckState (Either String) a }

76newtype Check a = Check { unCheck :: StateT CheckState (Either String) a }

@@ -90,7 +87,7 @@ modifyEnv f = modify (\s -> s { checkEnv = f (checkEnv s) })

91runCheck :: Check a -> Either String (a, Environment)

88runCheck :: Check a -> Either String (a, Environment)

92runCheck c = do

89runCheck c = do

93− (a, s) <- flip runStateT (CheckState emptyEnvironment 0 global) $ unCheck c

90+ (a, s) <- flip runStateT (CheckState emptyEnvironment 0) $ unCheck c

94 return (a, checkEnv s)

91 return (a, checkEnv s)

96guardWith :: (MonadError e m) => e -> Bool -> m ()

93guardWith :: (MonadError e m) => e -> Bool -> m ()

@@ -100,14 +97,6 @@ guardWith e False = throwError e

100rethrow :: (MonadError e m) => (e -> e) -> m a -> m a

97rethrow :: (MonadError e m) => (e -> e) -> m a -> m a

101rethrow f = flip catchError $ \e -> throwError (f e)

98rethrow f = flip catchError $ \e -> throwError (f e)

102

103−withModule :: ProperName -> Check a -> Check a

104−withModule name act = do

105− original <- checkModulePath `fmap` get

106− modify $ \s -> s { checkModulePath = subModule (checkModulePath s) name }

107− a <- act

108− modify $ \s -> s { checkModulePath = original }

109− return a

110−

111newtype Substitution = Substitution { runSubstitution :: forall t. (Unifiable t) => Unknown t -> t }

100newtype Substitution = Substitution { runSubstitution :: forall t. (Unifiable t) => Unknown t -> t }

112

101

113instance Monoid Substitution where

102instance Monoid Substitution where

@@ -117,21 +106,23 @@ instance Monoid Substitution where

117data SubstState = SubstState { substSubst :: Substitution

106data SubstState = SubstState { substSubst :: Substitution

118 , substFutureEscapeChecks :: [AnyUnifiable] }

107 , substFutureEscapeChecks :: [AnyUnifiable] }

119

108

109+newtype SubstContext = SubstContext { substCurrentModule :: ModuleName } deriving (Show)

110+

120−newtype Subst a = Subst { unSubst :: StateT SubstState Check a }

111+newtype Subst a = Subst { unSubst :: ReaderT SubstContext (StateT SubstState Check) a }

121− deriving (Functor, Monad, Applicative, MonadPlus)

112+ deriving (Functor, Monad, Applicative, MonadPlus, MonadReader SubstContext)

122

113

123instance MonadState CheckState Subst where

114instance MonadState CheckState Subst where

124− get = Subst . lift $ get

115+ get = Subst . lift . lift $ get

125− put = Subst . lift . put

116+ put = Subst . lift . lift . put

126

117

127deriving instance MonadError String Subst

118deriving instance MonadError String Subst

128

119

129liftCheck :: Check a -> Subst a

120liftCheck :: Check a -> Subst a

130−liftCheck = Subst . lift

121+liftCheck = Subst . lift . lift

131

122

132−runSubst :: (Unifiable a) => Subst a -> Check (a, Substitution, [AnyUnifiable])

123+runSubst :: (Unifiable a) => SubstContext -> Subst a -> Check (a, Substitution, [AnyUnifiable])

133−runSubst subst = do

124+runSubst context subst = do

134− (a, s) <- flip runStateT (SubstState mempty []) . unSubst $ subst

125+ (a, s) <- flip runStateT (SubstState mempty []) . flip runReaderT context . unSubst $ subst

135 return (apply (substSubst s) a, substSubst s, substFutureEscapeChecks s)

126 return (apply (substSubst s) a, substSubst s, substFutureEscapeChecks s)

136

127

137substituteWith :: (Typeable t) => (Unknown t -> t) -> Substitution

128substituteWith :: (Typeable t) => (Unknown t -> t) -> Substitution

src/Language/PureScript/TypeChecker/Types.hs+41−31

@@ -37,6 +37,7 @@ import Language.PureScript.Unknown

38import Control.Monad.State

39import Control.Monad.Error

40+import Control.Monad.Reader

41import Control.Applicative

42import Control.Applicative

42import Control.Arrow (Arrow(..))

43import Control.Arrow (Arrow(..))

@@ -132,28 +133,27 @@ unifyTypes t1 t2 = rethrow (\e -> "Error unifying type " ++ prettyPrintType t1 +

132 ret1 `unifyTypes` ret2

133 ret1 `unifyTypes` ret2

133 unifyTypes' (TypeVar v1) (TypeVar v2) | v1 == v2 = return ()

134 unifyTypes' (TypeVar v1) (TypeVar v2) | v1 == v2 = return ()

134 unifyTypes' (TypeConstructor c1) (TypeConstructor c2) = do

135 unifyTypes' (TypeConstructor c1) (TypeConstructor c2) = do

135− modulePath <- checkModulePath `fmap` get

136+ moduleName <- substCurrentModule `fmap` ask

136− guardWith ("Cannot unify " ++ show c1 ++ " with " ++ show c2 ++ ".") (qualify modulePath c1 == qualify modulePath c2)

137+ guardWith ("Cannot unify " ++ show c1 ++ " with " ++ show c2 ++ ".") (qualify moduleName c1 == qualify moduleName c2)

137 unifyTypes' (TypeApp t3 t4) (TypeApp t5 t6) = do

138 unifyTypes' (TypeApp t3 t4) (TypeApp t5 t6) = do

138 t3 `unifyTypes` t5

139 t3 `unifyTypes` t5

139 t4 `unifyTypes` t6

140 t4 `unifyTypes` t6

140 unifyTypes' (Skolem s1) (Skolem s2) | s1 == s2 = return ()

141 unifyTypes' (Skolem s1) (Skolem s2) | s1 == s2 = return ()

141 unifyTypes' t3 t4 = throwError $ "Cannot unify " ++ prettyPrintType t3 ++ " with " ++ prettyPrintType t4 ++ "."

142 unifyTypes' t3 t4 = throwError $ "Cannot unify " ++ prettyPrintType t3 ++ " with " ++ prettyPrintType t4 ++ "."

142

143

143−typesOf :: [(Ident, Value)] -> Check [Type]

144+typesOf :: ModuleName -> [(Ident, Value)] -> Check [Type]

144−typesOf vals = do

145+typesOf moduleName vals = do

145− (tys, sub, checks) <- runSubst $ do

146+ (tys, sub, checks) <- runSubst (SubstContext moduleName) $ do

146− modulePath <- checkModulePath <$> get

147 let es = map isTyped vals

148 typed = lefts es

149 untyped = rights es

150 typedDict = map (\(ident, ty, _) -> (ident, ty)) typed

151 untypedNames <- replicateM (length untyped) fresh

152 let untypedDict = zip (map fst untyped) untypedNames

153− dict = M.fromList (map (\(ident, ty) -> ((modulePath, ident), (ty, LocalVariable))) $ typedDict ++ untypedDict)

153+ dict = M.fromList (map (\(ident, ty) -> ((moduleName, ident), (ty, LocalVariable))) $ typedDict ++ untypedDict)

154 tys <- forM es $ \e -> case e of

155 Left (_, ty, val) -> do

156− kind <- liftCheck $ kindOf ty

156+ kind <- liftCheck $ kindOf moduleName ty

157 guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star

158 ty' <- replaceAllTypeSynonyms ty

159 bindNames dict $ check val ty'

@@ -241,7 +241,7 @@ replaceVarWithUnknown ident ty = do

241replaceAllTypeSynonyms :: (Functor m, MonadState CheckState m, MonadError String m) => (D.Data d) => d -> m d

242replaceAllTypeSynonyms d = do

243 env <- getEnv

244− let syns = map (\((path, name), (args, _)) -> (Qualified path name, length args)) . M.toList $ typeSynonyms env

244+ let syns = map (\((path, name), (args, _)) -> (Qualified (Just path) name, length args)) . M.toList $ typeSynonyms env

245 either throwError return $ saturateAllTypeSynonyms syns d

246

247desaturateAllTypeSynonyms :: (D.Data d) => d -> d

@@ -253,8 +253,8 @@ desaturateAllTypeSynonyms = everywhere (mkT replaceSaturatedTypeSynonym)

253expandTypeSynonym :: Qualified ProperName -> [Type] -> Subst Type

254expandTypeSynonym name args = do

255 env <- getEnv

256− modulePath <- checkModulePath `fmap` get

256+ moduleName <- substCurrentModule `fmap` ask

257− case M.lookup (qualify modulePath name) (typeSynonyms env) of

257+ case M.lookup (qualify moduleName name) (typeSynonyms env) of

258 Just (synArgs, body) -> return $ replaceAllTypeVars (zip synArgs args) body

259 Nothing -> error "Type synonym was not defined"

260

@@ -312,7 +312,8 @@ infer' (Accessor prop val) = do

312 Just ty -> return ty

313infer' (Abs args ret) = do

314 ts <- replicateM (length args) fresh

315+ moduleName <- substCurrentModule <$> ask

315− bindLocalVariables (zip args ts) $ do

316+ bindLocalVariables moduleName (zip args ts) $ do

316 body <- infer' ret

317 body <- infer' ret

317 return $ Function ts body

318 return $ Function ts body

318infer' app@(App _ _) = do

319infer' app@(App _ _) = do

@@ -322,7 +323,8 @@ infer' app@(App _ _) = do

322 checkFunctionApplications ft argss ret

323 checkFunctionApplications ft argss ret

323 return ret

324 return ret

324infer' (Var var) = do

325infer' (Var var) = do

326+ moduleName <- substCurrentModule <$> ask

325− ty <- lookupVariable var

327+ ty <- lookupVariable moduleName var

326 replaceAllTypeSynonyms ty

328 replaceAllTypeSynonyms ty

327infer' (Block ss) = do

329infer' (Block ss) = do

328 ret <- fresh

330 ret <- fresh

@@ -331,8 +333,8 @@ infer' (Block ss) = do

331 return ret

333 return ret

332infer' (Constructor c) = do

334infer' (Constructor c) = do

333 env <- getEnv

335 env <- getEnv

334− modulePath <- checkModulePath `fmap` get

336+ moduleName <- substCurrentModule `fmap` ask

335− case M.lookup (qualify modulePath c) (dataConstructors env) of

337+ case M.lookup (qualify moduleName c) (dataConstructors env) of

336 Nothing -> throwError $ "Constructor " ++ show c ++ " is undefined"

338 Nothing -> throwError $ "Constructor " ++ show c ++ " is undefined"

337 Just ty -> replaceAllTypeSynonyms ty

339 Just ty -> replaceAllTypeSynonyms ty

338infer' (Case vals binders) = do

340infer' (Case vals binders) = do

@@ -347,7 +349,8 @@ infer' (IfThenElse cond th el) = do

347 t2 ~~ t3

349 t2 ~~ t3

348 return t2

350 return t2

349infer' (TypedValue val ty) = do

351infer' (TypedValue val ty) = do

352+ moduleName <- substCurrentModule <$> ask

350− kind <- liftCheck $ kindOf ty

353+ kind <- liftCheck $ kindOf moduleName ty

351 guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star

354 guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star

352 ty' <- replaceAllTypeSynonyms ty

355 ty' <- replaceAllTypeSynonyms ty

353 check val ty'

356 check val ty'

@@ -444,16 +447,16 @@ inferBinder val (BooleanBinder _) = val ~~ Boolean >> return M.empty

444inferBinder val (VarBinder name) = return $ M.singleton name val

447inferBinder val (VarBinder name) = return $ M.singleton name val

445inferBinder val (NullaryBinder ctor) = do

448inferBinder val (NullaryBinder ctor) = do

446 env <- getEnv

449 env <- getEnv

447− modulePath <- checkModulePath <$> get

450+ moduleName <- substCurrentModule <$> ask

448− case M.lookup (qualify modulePath ctor) (dataConstructors env) of

451+ case M.lookup (qualify moduleName ctor) (dataConstructors env) of

449 Just ty -> do

452 Just ty -> do

450 ty `subsumes` val

453 ty `subsumes` val

451 return M.empty

454 return M.empty

452 _ -> throwError $ "Constructor " ++ show ctor ++ " is not defined"

455 _ -> throwError $ "Constructor " ++ show ctor ++ " is not defined"

453inferBinder val (UnaryBinder ctor binder) = do

456inferBinder val (UnaryBinder ctor binder) = do

454 env <- getEnv

457 env <- getEnv

455− modulePath <- checkModulePath <$> get

458+ moduleName <- substCurrentModule <$> ask

456− case M.lookup (qualify modulePath ctor) (dataConstructors env) of

459+ case M.lookup (qualify moduleName ctor) (dataConstructors env) of

457 Just ty -> do

460 Just ty -> do

458 fn <- replaceAllVarsWithUnknowns ty

461 fn <- replaceAllVarsWithUnknowns ty

459 case fn of

462 case fn of

@@ -494,8 +497,9 @@ inferBinder val (NamedBinder name binder) = do

494checkBinders :: [Type] -> Type -> [([Binder], Maybe Guard, Value)] -> Subst ()

497checkBinders :: [Type] -> Type -> [([Binder], Maybe Guard, Value)] -> Subst ()

495checkBinders _ _ [] = return ()

498checkBinders _ _ [] = return ()

496checkBinders nvals ret ((binders, grd, val):bs) = do

499checkBinders nvals ret ((binders, grd, val):bs) = do

500+ moduleName <- substCurrentModule <$> ask

497 m1 <- M.unions <$> zipWithM inferBinder nvals binders

501 m1 <- M.unions <$> zipWithM inferBinder nvals binders

498− bindLocalVariables (M.toList m1) $ do

502+ bindLocalVariables moduleName (M.toList m1) $ do

499 check val ret

503 check val ret

500 case grd of

504 case grd of

501 Nothing -> return ()

505 Nothing -> return ()

@@ -505,8 +509,8 @@ checkBinders nvals ret ((binders, grd, val):bs) = do

505assignVariable :: Ident -> Subst ()

509assignVariable :: Ident -> Subst ()

506assignVariable name = do

510assignVariable name = do

507 env <- checkEnv <$> get

511 env <- checkEnv <$> get

508− modulePath <- checkModulePath <$> get

512+ moduleName <- substCurrentModule <$> ask

509− case M.lookup (modulePath, name) (names env) of

513+ case M.lookup (moduleName, name) (names env) of

510 Just (_, LocalVariable) -> throwError $ "Variable with name " ++ show name ++ " already exists."

514 Just (_, LocalVariable) -> throwError $ "Variable with name " ++ show name ++ " already exists."

511 _ -> return ()

515 _ -> return ()

512

516

@@ -529,16 +533,18 @@ checkStatement mass ret (If ifst) = do

529 allCodePathsReturn <- checkIfStatement mass ret ifst

533 allCodePathsReturn <- checkIfStatement mass ret ifst

530 return (allCodePathsReturn, mass)

534 return (allCodePathsReturn, mass)

531checkStatement mass ret (For ident start end inner) = do

535checkStatement mass ret (For ident start end inner) = do

536+ moduleName <- substCurrentModule <$> ask

532 assignVariable ident

537 assignVariable ident

533 check start Number

538 check start Number

534 check end Number

539 check end Number

535− (allCodePathsReturn, _) <- bindLocalVariables [(ident, Number)] $ checkBlock mass ret inner

540+ (allCodePathsReturn, _) <- bindLocalVariables moduleName [(ident, Number)] $ checkBlock mass ret inner

536 return (allCodePathsReturn, mass)

541 return (allCodePathsReturn, mass)

537checkStatement mass ret (ForEach ident vals inner) = do

542checkStatement mass ret (ForEach ident vals inner) = do

543+ moduleName <- substCurrentModule <$> ask

538 assignVariable ident

544 assignVariable ident

539 val <- fresh

545 val <- fresh

540 check vals (Array val)

546 check vals (Array val)

541− (allCodePathsReturn, _) <- bindLocalVariables [(ident, val)] $ checkBlock mass ret inner

547+ (allCodePathsReturn, _) <- bindLocalVariables moduleName [(ident, val)] $ checkBlock mass ret inner

542 guardWith "Cannot return from within a foreach block" $ not allCodePathsReturn

548 guardWith "Cannot return from within a foreach block" $ not allCodePathsReturn

543 return (False, mass)

549 return (False, mass)

544checkStatement mass _ (ValueStatement val) = do

550checkStatement mass _ (ValueStatement val) = do

@@ -566,8 +572,9 @@ checkElseStatement mass ret (ElseIf ifst) = checkIfStatement mass ret ifst

566checkBlock :: M.Map Ident Type -> Type -> [Statement] -> Subst (Bool, M.Map Ident Type)

572checkBlock :: M.Map Ident Type -> Type -> [Statement] -> Subst (Bool, M.Map Ident Type)

567checkBlock mass _ [] = return (False, mass)

573checkBlock mass _ [] = return (False, mass)

568checkBlock mass ret (s:ss) = do

574checkBlock mass ret (s:ss) = do

575+ moduleName <- substCurrentModule <$> ask

569 (b1, mass1) <- checkStatement mass ret s

576 (b1, mass1) <- checkStatement mass ret s

570− bindLocalVariables (M.toList mass1) $ case (b1, ss) of

577+ bindLocalVariables moduleName (M.toList mass1) $ case (b1, ss) of

571 (True, []) -> return (True, mass1)

578 (True, []) -> return (True, mass1)

572 (True, _) -> throwError "Unreachable code"

579 (True, _) -> throwError "Unreachable code"

573 (False, ss') -> checkBlock mass1 ret ss'

580 (False, ss') -> checkBlock mass1 ret ss'

@@ -606,18 +613,21 @@ check' (Binary op left right) ty = checkBinary op left right ty

606check' (ArrayLiteral vals) (Array ty) = forM_ vals (\val -> check val ty)

613check' (ArrayLiteral vals) (Array ty) = forM_ vals (\val -> check val ty)

607check' (Indexer index vals) ty = check index Number >> check vals (Array ty)

614check' (Indexer index vals) ty = check index Number >> check vals (Array ty)

608check' (Abs args ret) (Function argTys retTy) = do

615check' (Abs args ret) (Function argTys retTy) = do

616+ moduleName <- substCurrentModule <$> ask

609 guardWith "Incorrect number of function arguments" (length args == length argTys)

617 guardWith "Incorrect number of function arguments" (length args == length argTys)

610− bindLocalVariables (zip args argTys) $ check ret retTy

618+ bindLocalVariables moduleName (zip args argTys) $ check ret retTy

611check' app@(App _ _) ret = do

619check' app@(App _ _) ret = do

612 let (f, argss) = unfoldApplication app

620 let (f, argss) = unfoldApplication app

613 ft <- infer f

621 ft <- infer f

614 checkFunctionApplications ft argss ret

622 checkFunctionApplications ft argss ret

615check' (Var var) ty = do

623check' (Var var) ty = do

624+ moduleName <- substCurrentModule <$> ask

616− ty1 <- lookupVariable var

625+ ty1 <- lookupVariable moduleName var

617 repl <- replaceAllTypeSynonyms ty1

626 repl <- replaceAllTypeSynonyms ty1

618 repl `subsumes` ty

627 repl `subsumes` ty

619check' (TypedValue val ty1) ty2 = do

628check' (TypedValue val ty1) ty2 = do

629+ moduleName <- substCurrentModule <$> ask

620− kind <- liftCheck $ kindOf ty1

630+ kind <- liftCheck $ kindOf moduleName ty1

621 guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star

631 guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star

622 ty1 `subsumes` ty2

632 ty1 `subsumes` ty2

623 check val ty1

633 check val ty1

@@ -647,8 +657,8 @@ check' (Block ss) ret = do

647 guardWith "Block is missing a return statement" allCodePathsReturn

657 guardWith "Block is missing a return statement" allCodePathsReturn

648check' (Constructor c) ty = do

658check' (Constructor c) ty = do

649 env <- getEnv

659 env <- getEnv

650− modulePath <- checkModulePath <$> get

660+ moduleName <- substCurrentModule <$> ask

651− case M.lookup (qualify modulePath c) (dataConstructors env) of

661+ case M.lookup (qualify moduleName c) (dataConstructors env) of

652 Nothing -> throwError $ "Constructor " ++ show c ++ " is undefined"

662 Nothing -> throwError $ "Constructor " ++ show c ++ " is undefined"

653 Just ty1 -> do

663 Just ty1 -> do

654 repl <- replaceAllTypeSynonyms ty1

664 repl <- replaceAllTypeSynonyms ty1

src/Language/PureScript/TypeDeclarations.hs+6−3

@@ -13,20 +13,23 @@

13-----------------------------------------------------------------------------

15module Language.PureScript.TypeDeclarations (

16− desugarTypeDeclarations

16+ desugarTypeDeclarations,

17+ desugarTypeDeclarationsModule

17) where

18) where

19import Control.Applicative

20import Control.Applicative

20import Control.Monad.Error.Class

21import Control.Monad.Error.Class

22+import Control.Monad (forM)

22import Language.PureScript.Declarations

24import Language.PureScript.Declarations

23import Language.PureScript.Values

25import Language.PureScript.Values

27+desugarTypeDeclarationsModule :: [Module] -> Either String [Module]

28+desugarTypeDeclarationsModule ms = forM ms $ \(Module name ds) -> Module name <$> desugarTypeDeclarations ds

29+

25desugarTypeDeclarations :: [Declaration] -> Either String [Declaration]

30desugarTypeDeclarations :: [Declaration] -> Either String [Declaration]

26desugarTypeDeclarations (TypeDeclaration name ty : ValueDeclaration name' [] Nothing val : rest) | name == name' =

31desugarTypeDeclarations (TypeDeclaration name ty : ValueDeclaration name' [] Nothing val : rest) | name == name' =

27 desugarTypeDeclarations (ValueDeclaration name [] Nothing (TypedValue val ty) : rest)

32 desugarTypeDeclarations (ValueDeclaration name [] Nothing (TypedValue val ty) : rest)

28desugarTypeDeclarations (TypeDeclaration name _ : _) = throwError $ "Orphan type declaration for " ++ show name

33desugarTypeDeclarations (TypeDeclaration name _ : _) = throwError $ "Orphan type declaration for " ++ show name

29−desugarTypeDeclarations (ModuleDeclaration name ds:ds') = (:) <$> (ModuleDeclaration name <$> desugarTypeDeclarations ds)

30− <*> desugarTypeDeclarations ds'

31desugarTypeDeclarations (d:ds) = (:) d <$> desugarTypeDeclarations ds

34desugarTypeDeclarations (d:ds) = (:) d <$> desugarTypeDeclarations ds

32desugarTypeDeclarations [] = return []

35desugarTypeDeclarations [] = return []

src/Main.hs+5−5

@@ -23,15 +23,15 @@ import qualified System.IO.UTF8 as U

24compile :: [FilePath] -> Maybe FilePath -> Maybe FilePath -> IO ()

25compile input output externs = do

26− asts <- fmap (fmap concat . sequence) $ forM input $ \inputFile -> do

26+ modules <- fmap (fmap concat . sequence) $ forM input $ \inputFile -> do

27 text <- U.readFile inputFile

28− return $ P.runIndentParser P.parseDeclarations text

28+ return $ P.runIndentParser P.parseModules text

29− case asts of

29+ case modules of

30 Left err -> do

31 U.print err

32 exitFailure

33− Right decls ->

33+ Right ms ->

34− case P.compile decls of

34+ case P.compile ms of

35 Left err -> do

36 U.putStrLn err

37 exitFailure

tests/Main.hs+4−4

@@ -27,12 +27,12 @@ import qualified Data.Map as M

28compile :: FilePath -> IO (Either String P.Environment)

29compile inputFile = do

30− ast <- P.runIndentParser P.parseDeclarations <$> U.readFile inputFile

30+ modules <- P.runIndentParser P.parseModules <$> U.readFile inputFile

31− case ast of

31+ case modules of

32 Left parseError -> do

33 return (Left $ show parseError)

34− Right decls -> do

34+ Right ms -> do

35− case P.compile decls of

35+ case P.compile ms of

36 Left typeError -> do

37 return (Left typeError)

38 Right (_, _, env) -> do