ea3e968 · rowtype-yoga/purescript-native

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

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

commitea3e96895cc0b7e47518f0e962a5ceccb824b9bb authorPhil Freeman <paf31@cantab.net> dateSun 29 Dec 2013, 17:36 (13 years ago) parent24872f8

21 files changed+295−318

compare with golang

unifiedsplit

examples/passing/Import.purs+6−6

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

1−module Hello where

1+module M1 where

23 id :: forall a. a -> a

34 id = \x -> x

5− module Nested where

6− import Hello (id)

6+ foo = id

8− foo = id

8+module M2 where

10−import Hello.Nested

10+ import M1

1111

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

33 data Foo = Foo String

5− foo :: Test.Foo -> String

5+ foo :: M1.Foo -> String

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

88 bar :: Foo -> String

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

1111 incr :: Number -> Number

1212 incr x = x + 1

1313

14− module Inner where

14+module M2 where

1515

16− inner = "Inner"

16+ baz :: M1.Foo -> String

17+ baz = M1.foo

1718

18−baz :: Test.Foo -> String

19−baz = Test.foo

20−

21−innerCopy :: String

22−innerCopy = Test.Inner.inner

23−

24−match :: Test.Foo -> String

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

19+ match :: M1.Foo -> String

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

2−f x = g x + 1

1+module MutRec where

4−g x = f (x / 2)

3+ f 0 = 0

4+ f x = g x + 1

6+ g x = f (x / 2)

src/Language/PureScript.hs+8−9

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

3030import Language.PureScript.BindingGroups as P

3131

3232import Data.List (intercalate)

33−import Data.Maybe (mapMaybe)

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

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

3534

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

37−compile decls = do

38− bracketted <- rebracket decls

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

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

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

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

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

36+compile ms = do

37+ bracketted <- rebracket ms

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

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

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

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

4342 return (js, exts, env)

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

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

1313-----------------------------------------------------------------------------

1414

1515module Language.PureScript.BindingGroups (

16− createBindingGroups

16+ createBindingGroups,

17+ createBindingGroupsModule

1718) where

1819

1920import Data.Graph

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

2425import Language.PureScript.Values

2526import Language.PureScript.Scope (usedNames)

2627

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

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

30+

2731createBindingGroups :: [Declaration] -> [Declaration]

2832createBindingGroups ds =

2933 let

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

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

3438 sorted = map toBindingGroup $ stronglyConnComp verts

3539 in

36− map handleModuleDeclaration nonValues ++ sorted

40+ nonValues ++ sorted

3741

3842isValueDecl :: Declaration -> Bool

3943isValueDecl (ValueDeclaration _ _ _ _) = True

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

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

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

5458fromValueDecl _ = 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 @@

1313-----------------------------------------------------------------------------

1414

1515module Language.PureScript.CaseDeclarations (

16− desugarCases

16+ desugarCases,

17+ desugarCasesModule

1718) where

1819

1920import Data.List (groupBy)

20−import Control.Monad (join, unless)

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

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

2123import Control.Monad.Error.Class

2224

2325import Language.PureScript.Names

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

2527import Language.PureScript.Declarations

2628import Language.PureScript.Scope

2729

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

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

32+

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

2934desugarCases = fmap join . mapM toDecls . groupBy inSameGroup

3035

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

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

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

4146 return [makeCaseDeclaration ident tuples]

42−toDecls [ModuleDeclaration name decls] = do

43− desugared <- desugarCases decls

44− return [ModuleDeclaration name desugared]

4547toDecls ds = return ds

4648

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

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

5355 let

5456 argPattern = map length . fst . head $ alternatives

5557 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

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

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

5961 in

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

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

1313-----------------------------------------------------------------------------

1414

1515module Language.PureScript.CodeGen.Externs (

16− externToPs

16+ moduleToPs

1717) where

1818

19−import Data.Maybe (mapMaybe)

19+import Data.Maybe (maybeToList, mapMaybe)

2020import qualified Data.Map as M

2121import Language.PureScript.Declarations

2222import Language.PureScript.TypeChecker.Monad

2323import Language.PureScript.Pretty

2424import Language.PureScript.Names

25+import Data.List (intercalate)

2526

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

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

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+

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

41−externToPs _ _ _ _ = Nothing

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

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

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

45+declToPs _ _ (ExternDataDeclaration name kind) =

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

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

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

49+declToPs _ _ _ = []

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

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

1414

1515module Language.PureScript.CodeGen.JS (

1616 module AST,

17− declToJs

17+ declToJs,

18+ moduleToJs

1819) where

1920

2021import Data.Maybe (mapMaybe)

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

3132import Language.PureScript.CodeGen.Monad

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

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

34−import Debug.Trace (trace)

3535

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

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

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

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

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

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

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

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

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) ->

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

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

51− ) vals))) []

52− ]

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

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

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

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

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+

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

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

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

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

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

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

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

52+declToJs mp (BindingGroupDeclaration vals) e =

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

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

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

56+ ) vals

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

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

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

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

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

5862 let

5963 ctorJs =

6064 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))) ]))

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

6367 (JSBlock [JSReturn

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

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

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

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

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

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

71+declToJs _ _ _ = Nothing

7572

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

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

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

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

7875

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

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

8077valueToJs _ _ (NumericLiteral n) = JSNumericLiteral n

8178valueToJs _ _ (StringLiteral s) = JSStringLiteral s

8279valueToJs _ _ (BooleanLiteral b) = JSBooleanLiteral b

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

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

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

9693valueToJs 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)

9895 _ -> qualifiedToJS identToJs ident

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

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

10198

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

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

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

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

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

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

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

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

108102

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

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

110104bindersToJs m e binders vals = do

111105 setNextName $ firstUnusedName (binders, vals)

112106 valNames <- replicateM (length vals) fresh

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

122116 binderToJs m e v done'' b

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

124118

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

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

126120binderToJs _ _ _ done NullBinder = return done

127121binderToJs _ _ varName done (StringBinder str) =

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

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

135129binderToJs _ _ varName done (VarBinder ident) =

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

137131binderToJs 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]

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

140134 value <- fresh

141135 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]

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

144138 where

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

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

174168 js <- binderToJs m e varName done binder

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

176170

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

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

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

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

180174statementToJs 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)

2929

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

3131

32+data Module = Module ProperName [Declaration]

33+

3234data Declaration

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

3436 | TypeSynonymDeclaration ProperName [String] PolyType

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

3941 | ExternMemberDeclaration String Ident PolyType

4042 | ExternDataDeclaration ProperName Kind

4143 | FixityDeclaration Fixity String

42− | ModuleDeclaration ProperName [Declaration]

43− | ImportDeclaration ModulePath (Maybe [Ident])

44+ | ImportDeclaration ModuleName (Maybe [Ident])

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

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

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

1717module Language.PureScript.Names where

1818

1919import Data.Data

20−import Data.List (inits, intercalate)

2120

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

2322

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

3029instance Show ProperName where

3130 show = runProperName

3231

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

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

3433

35−instance Show ModulePath where

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

34+instance Show ModuleName where

35+ show (ModuleName name) = show name

3736

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)

4538

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

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

48−

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

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

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

40+ show (Qualified Nothing a) = show a

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

5242

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

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

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

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

44+qualify m (Qualified Nothing a) = (m, 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

3333import qualified Text.Parsec.Pos as P

3434import qualified Text.Parsec.Expr as P

3535

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

37−rebracket ds = do

38− m <- collectFixities ds

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

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

38+ m <- collectFixities (ModuleName name) ds

3939 let opTable = customOperatorTable m

4040 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'

4242

4343removeParens :: Value -> Value

4444removeParens (Parens val) = val

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

8585 ident <- parseOp

8686 guard (ident == op)

8787

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

89−collectFixities = go M.empty global

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

89+collectFixities = go M.empty

9090 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)

9292 go m _ [] = return m

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

94− let qual = Qualified p (Op name)

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

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

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

96− go (M.insert qual fixity m) p 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

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

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

10198

10299globalOp :: String -> Qualified Ident

103−globalOp = Qualified global . Op

100+globalOp = Qualified Nothing . Op

104101

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

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

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

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

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

189189

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

191−parseQualified parser = part global

191+parseQualified parser = qual

192192 where

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

194− part (subModule path name))

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

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

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

196195 delimiter = indented *> dot

197196

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

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

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

1414

1515module Language.PureScript.Parser.Declarations (

1616 parseDeclaration,

17− parseDeclarations

17+ parseModule,

18+ parseModules

1819) where

1920

2021import Control.Applicative

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

8485 name <- operator

8586 return $ FixityDeclaration fixity name

8687

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−

9988parseImportDeclaration :: P.Parsec String ParseState Declaration

10089parseImportDeclaration = do

10190 reserved "import"

10291 indented

103− modulePath <- parseModulePath

92+ moduleName <- ModuleName <$> properName

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

105− return $ ImportDeclaration modulePath idents

94+ return $ ImportDeclaration moduleName idents

10695

10796parseDeclaration :: P.Parsec String ParseState Declaration

10897parseDeclaration = P.choice

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

112101 , parseValueDeclaration

113102 , parseExternDeclaration

114103 , parseFixityDeclaration

115− , parseModuleDeclaration

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

117105

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

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

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+

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

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

3232 where

3333 namesV :: Value -> [Ident]

3434 namesV (Abs args _) = args

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

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

3636 namesV _ = []

3737 namesS :: Statement -> [Ident]

3838 namesS (VariableIntroduction name _) = [name]

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

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

3535import Control.Monad.State

3636import Control.Monad.Error

3737

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

39−typeCheckAll [] = return ()

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

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

39+typeCheckAll _ [] = return ()

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

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

4242 env <- getEnv

43− modulePath <- checkModulePath `fmap` get

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

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

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

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

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

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

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

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

4948 env' <- getEnv

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

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

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

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

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

5352 let polyType = mkForAll args dctorTy

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

55− typeCheckAll rest

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

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

54+ typeCheckAll moduleName rest

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

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

5857 env <- getEnv

59− modulePath <- checkModulePath `fmap` get

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

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

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

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

64− typeCheckAll rest

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

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

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

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

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

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

62+ typeCheckAll moduleName rest

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

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

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

6866 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

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

7269 Nothing -> do

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

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

75− typeCheckAll rest

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

77−typeCheckAll (BindingGroupDeclaration vals : rest) = do

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

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

72+ typeCheckAll moduleName rest

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

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

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

79− modulePath <- checkModulePath `fmap` get

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

8177 env <- getEnv

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

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

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

8480 Nothing -> return ()

85− tys <- typesOf vals

81+ tys <- typesOf moduleName vals

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

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

88− typeCheckAll rest

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

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

84+ typeCheckAll moduleName rest

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

9086 env <- getEnv

91− modulePath <- checkModulePath `fmap` get

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

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

94− typeCheckAll rest

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

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

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

89+ typeCheckAll moduleName rest

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

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

9792 env <- getEnv

98− modulePath <- checkModulePath `fmap` get

99− kind <- kindOf ty

93+ kind <- kindOf moduleName ty

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

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

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

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

10397 Nothing -> case ty of

10498 _ | isSingleArgumentFunction ty -> do

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

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

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

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

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

108− typeCheckAll rest

102+ typeCheckAll moduleName rest

109103 where

110104 isSingleArgumentFunction (Function [_] _) = True

111105 isSingleArgumentFunction (ForAll _ t) = isSingleArgumentFunction t

112106 isSingleArgumentFunction _ = False

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

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

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

115109 env <- getEnv

116− modulePath <- checkModulePath `fmap` get

117− kind <- kindOf ty

110+ kind <- kindOf moduleName ty

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

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

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

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

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

122− typeCheckAll rest

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

124− typeCheckAll rest

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

115+ typeCheckAll moduleName rest

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

117+ typeCheckAll moduleName rest

125118 env <- getEnv

126− modulePath <- checkModulePath `fmap` get

127− guardWith ("Fixity declaration with no binding: " ++ name) $ M.member (modulePath, 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

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

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

132121 env <- getEnv

133− currentModule <- checkModulePath `fmap` get

134122 rethrow errorMessage $ do

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

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

136124 case idents of

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

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

139− typeCheckAll rest

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

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

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

126+ Just idents' -> bindIdents idents' env

127+ typeCheckAll moduleName rest

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

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

142130 moduleExists env = not $ null $ filterModule env

143− bindIdents idents' currentModule env =

131+ bindIdents idents' env =

144132 forM_ idents' $ \ident -> do

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

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

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

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

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

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

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

2828

2929import Control.Monad.State

3030import Control.Monad.Error

31+import Control.Monad.Reader

3132

3233import Control.Applicative

3334

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

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

5455 unknowns _ = []

5556

56−kindOf :: Type -> Check Kind

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

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

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

5859

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

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

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

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

6162 tyCon <- fresh

6263 kargs <- replicateM (length args) fresh

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

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

9293 case M.lookup v m of

9394 Just k -> return k

9495 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

9697infer _ _ (TypeConstructor v) = do

9798 env <- liftCheck getEnv

98− modulePath <- checkModulePath `fmap` get

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

99+ moduleName <- substCurrentModule `fmap` ask

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

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

101102 Just (kind, _) -> return kind

102103infer name m (TypeApp t1 t2) = do

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

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

2828import Control.Applicative

2929import Control.Monad.State

3030import Control.Monad.Error

31+import Control.Monad.Reader

3132

3233import qualified Data.Map as M

3334

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

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

3536

3637data TypeDeclarationKind = Data | ExternData | TypeSynonym deriving Show

3738

3839data Environment = Environment

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

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

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

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

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

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

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

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

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

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

4445 } deriving (Show)

4546

4647emptyEnvironment :: Environment

4748emptyEnvironment = Environment M.empty M.empty M.empty M.empty M.empty

4849

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

5051bindNames newNames action = do

5152 orig <- get

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

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

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

5556 return a

5657

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

58−bindLocalVariables bindings action = do

59− modulePath <- checkModulePath `fmap` get

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

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

59+bindLocalVariables moduleName bindings action =

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

6161

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

63−lookupVariable var = do

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

63+lookupVariable currentModule (Qualified moduleName var) = do

6464 env <- getEnv

65− modulePath <- checkModulePath <$> get

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

67− case getFirst (mconcat tries) of

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

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

6967 Just (ty, _) -> return ty

7068

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

7371

7472data CheckState = CheckState { checkEnv :: Environment

7573 , checkNextVar :: Int

76− , checkModulePath :: ModulePath

7774 }

7875

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

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

9087

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

9289runCheck c = do

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

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

9491 return (a, checkEnv s)

9592

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

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

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

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

10299

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−

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

112101

113102instance Monoid Substitution where

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

117106data SubstState = SubstState { substSubst :: Substitution

118107 , substFutureEscapeChecks :: [AnyUnifiable] }

119108

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

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

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

110+

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

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

122113

123114instance MonadState CheckState Subst where

124− get = Subst . lift $ get

125− put = Subst . lift . put

115+ get = Subst . lift . lift $ get

116+ put = Subst . lift . lift . put

126117

127118deriving instance MonadError String Subst

128119

129120liftCheck :: Check a -> Subst a

130−liftCheck = Subst . lift

121+liftCheck = Subst . lift . lift

131122

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

133−runSubst subst = do

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

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

124+runSubst context subst = do

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

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

136127

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

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

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

3737

3838import Control.Monad.State

3939import Control.Monad.Error

40+import Control.Monad.Reader

4041

4142import Control.Applicative

4243import Control.Arrow (Arrow(..))

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

132133 ret1 `unifyTypes` ret2

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

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

135− modulePath <- checkModulePath `fmap` get

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

136+ moduleName <- substCurrentModule `fmap` ask

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

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

138139 t3 `unifyTypes` t5

139140 t4 `unifyTypes` t6

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

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

142143

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

144−typesOf vals = do

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

146− modulePath <- checkModulePath <$> get

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

145+typesOf moduleName vals = do

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

147147 let es = map isTyped vals

148148 typed = lefts es

149149 untyped = rights es

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

151151 untypedNames <- replicateM (length untyped) fresh

152152 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)

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

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

156− kind <- liftCheck $ kindOf ty

156+ kind <- liftCheck $ kindOf moduleName ty

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

158158 ty' <- replaceAllTypeSynonyms ty

159159 bindNames dict $ check val ty'

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

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

242242replaceAllTypeSynonyms d = do

243243 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

245245 either throwError return $ saturateAllTypeSynonyms syns d

246246

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

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

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

254254expandTypeSynonym name args = do

255255 env <- getEnv

256− modulePath <- checkModulePath `fmap` get

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

256+ moduleName <- substCurrentModule `fmap` ask

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

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

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

260260

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

312312 Just ty -> return ty

313313infer' (Abs args ret) = do

314314 ts <- replicateM (length args) fresh

315− bindLocalVariables (zip args ts) $ do

315+ moduleName <- substCurrentModule <$> ask

316+ bindLocalVariables moduleName (zip args ts) $ do

316317 body <- infer' ret

317318 return $ Function ts body

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

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

322323 checkFunctionApplications ft argss ret

323324 return ret

324325infer' (Var var) = do

325− ty <- lookupVariable var

326+ moduleName <- substCurrentModule <$> ask

327+ ty <- lookupVariable moduleName var

326328 replaceAllTypeSynonyms ty

327329infer' (Block ss) = do

328330 ret <- fresh

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

331333 return ret

332334infer' (Constructor c) = do

333335 env <- getEnv

334− modulePath <- checkModulePath `fmap` get

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

336+ moduleName <- substCurrentModule `fmap` ask

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

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

337339 Just ty -> replaceAllTypeSynonyms ty

338340infer' (Case vals binders) = do

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

347349 t2 ~~ t3

348350 return t2

349351infer' (TypedValue val ty) = do

350− kind <- liftCheck $ kindOf ty

352+ moduleName <- substCurrentModule <$> ask

353+ kind <- liftCheck $ kindOf moduleName ty

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

352355 ty' <- replaceAllTypeSynonyms ty

353356 check val ty'

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

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

445448inferBinder val (NullaryBinder ctor) = do

446449 env <- getEnv

447− modulePath <- checkModulePath <$> get

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

450+ moduleName <- substCurrentModule <$> ask

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

449452 Just ty -> do

450453 ty `subsumes` val

451454 return M.empty

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

453456inferBinder val (UnaryBinder ctor binder) = do

454457 env <- getEnv

455− modulePath <- checkModulePath <$> get

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

458+ moduleName <- substCurrentModule <$> ask

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

457460 Just ty -> do

458461 fn <- replaceAllVarsWithUnknowns ty

459462 case fn of

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

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

495498checkBinders _ _ [] = return ()

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

500+ moduleName <- substCurrentModule <$> ask

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

498− bindLocalVariables (M.toList m1) $ do

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

499503 check val ret

500504 case grd of

501505 Nothing -> return ()

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

505509assignVariable :: Ident -> Subst ()

506510assignVariable name = do

507511 env <- checkEnv <$> get

508− modulePath <- checkModulePath <$> get

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

512+ moduleName <- substCurrentModule <$> ask

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

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

511515 _ -> return ()

512516

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

529533 allCodePathsReturn <- checkIfStatement mass ret ifst

530534 return (allCodePathsReturn, mass)

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

536+ moduleName <- substCurrentModule <$> ask

532537 assignVariable ident

533538 check start Number

534539 check end Number

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

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

536541 return (allCodePathsReturn, mass)

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

543+ moduleName <- substCurrentModule <$> ask

538544 assignVariable ident

539545 val <- fresh

540546 check vals (Array val)

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

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

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

543549 return (False, mass)

544550checkStatement mass _ (ValueStatement val) = do

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

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

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

568574checkBlock mass ret (s:ss) = do

575+ moduleName <- substCurrentModule <$> ask

569576 (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

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

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

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

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

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

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

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

616+ moduleName <- substCurrentModule <$> ask

609617 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

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

612620 let (f, argss) = unfoldApplication app

613621 ft <- infer f

614622 checkFunctionApplications ft argss ret

615623check' (Var var) ty = do

616− ty1 <- lookupVariable var

624+ moduleName <- substCurrentModule <$> ask

625+ ty1 <- lookupVariable moduleName var

617626 repl <- replaceAllTypeSynonyms ty1

618627 repl `subsumes` ty

619628check' (TypedValue val ty1) ty2 = do

620− kind <- liftCheck $ kindOf ty1

629+ moduleName <- substCurrentModule <$> ask

630+ kind <- liftCheck $ kindOf moduleName ty1

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

622632 ty1 `subsumes` ty2

623633 check val ty1

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

647657 guardWith "Block is missing a return statement" allCodePathsReturn

648658check' (Constructor c) ty = do

649659 env <- getEnv

650− modulePath <- checkModulePath <$> get

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

660+ moduleName <- substCurrentModule <$> ask

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

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

653663 Just ty1 -> do

654664 repl <- replaceAllTypeSynonyms ty1

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

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

1313-----------------------------------------------------------------------------

1414

1515module Language.PureScript.TypeDeclarations (

16− desugarTypeDeclarations

16+ desugarTypeDeclarations,

17+ desugarTypeDeclarationsModule

1718) where

1819

1920import Control.Applicative

2021import Control.Monad.Error.Class

22+import Control.Monad (forM)

2123

2224import Language.PureScript.Declarations

2325import Language.PureScript.Values

2426

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

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

29+

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

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

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

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

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

30− <*> desugarTypeDeclarations ds'

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

3235desugarTypeDeclarations [] = return []

src/Main.hs+5−5

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

2323

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

2525compile input output externs = do

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

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

2727 text <- U.readFile inputFile

28− return $ P.runIndentParser P.parseDeclarations text

29− case asts of

28+ return $ P.runIndentParser P.parseModules text

29+ case modules of

3030 Left err -> do

3131 U.print err

3232 exitFailure

33− Right decls ->

34− case P.compile decls of

33+ Right ms ->

34+ case P.compile ms of

3535 Left err -> do

3636 U.putStrLn err

3737 exitFailure

tests/Main.hs+4−4

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

2727

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

2929compile inputFile = do

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

31− case ast of

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

31+ case modules of

3232 Left parseError -> do

3333 return (Left $ show parseError)

34− Right decls -> do

35− case P.compile decls of

34+ Right ms -> do

35+ case P.compile ms of

3636 Left typeError -> do

3737 return (Left typeError)

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