packages feed

purescript 0.2.2 → 0.2.3

raw patch · 20 files changed

+645/−370 lines, 20 files

Files

purescript.cabal view
@@ -1,5 +1,5 @@ name: purescript-version: 0.2.2+version: 0.2.3 cabal-version: >=1.8 build-type: Simple license: MIT@@ -17,10 +17,11 @@     build-depends: base >=4 && <5, cmdtheline -any, containers -any,                    directory -any, filepath -any, mtl -any, parsec -any, syb -any,                    transformers -any, utf8-string -any-    exposed-modules: Language.PureScript.Scope Data.Generics.Extras-                     Language.PureScript Language.PureScript.CodeGen-                     Language.PureScript.CodeGen.Externs Language.PureScript.CodeGen.JS-                     Language.PureScript.CodeGen.JS.AST+    exposed-modules: Language.PureScript.TypeDeclarations+                     Language.PureScript.BindingGroups Language.PureScript.Scope+                     Data.Generics.Extras Language.PureScript+                     Language.PureScript.CodeGen Language.PureScript.CodeGen.Externs+                     Language.PureScript.CodeGen.JS Language.PureScript.CodeGen.JS.AST                      Language.PureScript.CodeGen.Monad Language.PureScript.Declarations                      Language.PureScript.Kinds Language.PureScript.Names                      Language.PureScript.Operators Language.PureScript.Optimize
src/Language/PureScript.hs view
@@ -26,15 +26,17 @@ import Language.PureScript.Optimize as P import Language.PureScript.Operators as P import Language.PureScript.CaseDeclarations as P+import Language.PureScript.TypeDeclarations as P+import Language.PureScript.BindingGroups as P  import Data.List (intercalate)-import Data.Maybe (mapMaybe)+import Control.Monad (forM_, (>=>)) -compile :: [Declaration] -> Either String (String, String, Environment)-compile decls = do-  bracketted <- rebracket decls-  desugared <- desugarCases bracketted-  (_, env) <- runCheck (typeCheckAll desugared)-  let js = prettyPrintJS . map optimize . concat . mapMaybe (\decl -> declToJs Nothing global decl env) $ desugared-  let exts = intercalate "\n" . mapMaybe (externToPs 0 global env) $ desugared+compile :: [Module] -> Either String (String, String, Environment)+compile ms = do+  bracketted <- rebracket ms+  desugared <- desugarCasesModule >=> desugarTypeDeclarationsModule >=> (return . createBindingGroupsModule) $ bracketted+  (_, env) <- runCheck $ forM_ desugared $ \(Module moduleName decls) -> typeCheckAll (ModuleName moduleName) decls+  let js = prettyPrintJS . map optimize . concatMap (flip moduleToJs env) $ desugared+  let exts = intercalate "\n" . map (flip moduleToPs env) $ desugared   return (js, exts, env)
+ src/Language/PureScript/BindingGroups.hs view
@@ -0,0 +1,98 @@+-----------------------------------------------------------------------------+--+-- Module      :  Language.PureScript.BindingGroups+-- Copyright   :  (c) Phil Freeman 2013+-- License     :  MIT+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>+-- Stability   :  experimental+-- Portability :+--+-- |+--+-----------------------------------------------------------------------------++module Language.PureScript.BindingGroups (+    createBindingGroups,+    createBindingGroupsModule+) where++import Data.Data+import Data.Graph+import Data.Generics+import Data.List (nub, intersect)++import Language.PureScript.Declarations+import Language.PureScript.Names+import Language.PureScript.Values+import Language.PureScript.Types++createBindingGroupsModule :: [Module] -> [Module]+createBindingGroupsModule = map $ \(Module name ds) -> Module name (createBindingGroups ds)++createBindingGroups :: [Declaration] -> [Declaration]+createBindingGroups ds =+  let+    values = filter isValueDecl ds+    dataDecls = filter isDataDecl ds+    nonValues = filter (\d -> not (isValueDecl d) && not (isDataDecl d)) ds+    allProperNames = map getProperName dataDecls+    dataVerts = map (\d -> (d, getProperName d, usedProperNames d `intersect` allProperNames)) dataDecls+    dataBindingGroupDecls = map toDataBindingGroup $ stronglyConnComp dataVerts+    allIdents = map getIdent values+    valueVerts = map (\d -> (d, getIdent d, usedIdents d `intersect` allIdents)) values+    bindingGroupDecls = map toBindingGroup $ stronglyConnComp valueVerts+  in+    dataBindingGroupDecls ++ nonValues ++ bindingGroupDecls++usedIdents :: (Data d) => d -> [Ident]+usedIdents = nub . everything (++) (mkQ [] namesV `extQ` namesS)+  where+  namesV :: Value -> [Ident]+  namesV (Var (Qualified Nothing name)) = [name]+  namesV _ = []+  namesS :: Statement -> [Ident]+  namesS (VariableIntroduction name _) = [name]+  namesS _ = []++usedProperNames :: (Data d) => d -> [ProperName]+usedProperNames = nub . everything (++) (mkQ [] names)+  where+  names :: Type -> [ProperName]+  names (TypeConstructor (Qualified Nothing name)) = [name]+  names _ = []++isValueDecl :: Declaration -> Bool+isValueDecl (ValueDeclaration _ _ _ _) = True+isValueDecl _ = False++isDataDecl :: Declaration -> Bool+isDataDecl (DataDeclaration _ _ _) = True+isDataDecl _ = False++getIdent :: Declaration -> Ident+getIdent (ValueDeclaration ident _ _ _) = ident+getIdent _ = error "Expected ValueDeclaration"++getProperName :: Declaration -> ProperName+getProperName (DataDeclaration pn _ _) = pn+getProperName _ = error "Expected DataDeclaration"++toBindingGroup :: SCC Declaration -> Declaration+toBindingGroup (AcyclicSCC d) = d+toBindingGroup (CyclicSCC [d]) = d+toBindingGroup (CyclicSCC ds') = BindingGroupDeclaration $ map fromValueDecl ds'++toDataBindingGroup :: SCC Declaration -> Declaration+toDataBindingGroup (AcyclicSCC d) = d+toDataBindingGroup (CyclicSCC [d]) = d+toDataBindingGroup (CyclicSCC ds') = DataBindingGroupDeclaration $ map fromDataDecl ds'++fromValueDecl :: Declaration -> (Ident, Value)+fromValueDecl (ValueDeclaration ident [] Nothing val) = (ident, val)+fromValueDecl (ValueDeclaration _ _ _ _) = error "Binders should have been desugared"+fromValueDecl _ = error "Expected ValueDeclaration"++fromDataDecl :: Declaration -> (ProperName, [String], [(ProperName, Maybe PolyType)])+fromDataDecl (DataDeclaration pn args ctors) = (pn, args, ctors)+fromDataDecl _ = error "Expected DataDeclaration"
src/Language/PureScript/CaseDeclarations.hs view
@@ -13,11 +13,13 @@ -----------------------------------------------------------------------------  module Language.PureScript.CaseDeclarations (-    desugarCases+    desugarCases,+    desugarCasesModule ) where  import Data.List (groupBy)-import Control.Monad (join, unless)+import Control.Applicative ((<$>))+import Control.Monad (forM, join, unless) import Control.Monad.Error.Class  import Language.PureScript.Names@@ -25,6 +27,9 @@ import Language.PureScript.Declarations import Language.PureScript.Scope +desugarCasesModule :: [Module] -> Either String [Module]+desugarCasesModule ms = forM ms $ \(Module name ds) -> Module name <$> desugarCases ds+ desugarCases :: [Declaration] -> Either String [Declaration] desugarCases = fmap join . mapM toDecls . groupBy inSameGroup @@ -39,9 +44,6 @@   unless (all ((== map length bs) . map length . fst) tuples) $       throwError $ "Argument list lengths differ in declaration " ++ show ident   return [makeCaseDeclaration ident tuples]-toDecls [ModuleDeclaration name decls] = do-  desugared <- desugarCases decls-  return [ModuleDeclaration name desugared] toDecls ds = return ds  toTuple :: Declaration -> ([[Binder]], (Maybe Guard, Value))@@ -53,7 +55,7 @@   let     argPattern = map length . fst . head $ alternatives     args = take (sum argPattern) $ unusedNames (ident, alternatives)-    vars = map (\arg -> Var (Qualified global arg)) args+    vars = map (\arg -> Var (Qualified Nothing arg)) args     binders = [ (join bs, g, val) | (bs, (g, val)) <- alternatives ]     value = foldr (\args' ret -> Abs args' ret) (Case vars binders) (rearrange argPattern args)   in
src/Language/PureScript/CodeGen/Externs.hs view
@@ -13,29 +13,37 @@ -----------------------------------------------------------------------------  module Language.PureScript.CodeGen.Externs (-    externToPs+    moduleToPs ) where -import Data.Maybe (mapMaybe)+import Data.Maybe (maybeToList, mapMaybe) import qualified Data.Map as M import Language.PureScript.Declarations import Language.PureScript.TypeChecker.Monad import Language.PureScript.Pretty import Language.PureScript.Names+import Data.List (intercalate) -externToPs :: Int -> ModulePath -> Environment -> Declaration -> Maybe String-externToPs indent path env (ValueDeclaration name _ _ _) = do+moduleToPs :: Module -> Environment -> String+moduleToPs (Module pname@(ProperName moduleName) decls) env =+  "module " ++ moduleName ++ " where\n" +++  (intercalate "\n" . map ("  " ++) . concatMap (declToPs (ModuleName pname) env) $ decls)++declToPs :: ModuleName -> Environment -> Declaration -> [String]+declToPs path env (ValueDeclaration name _ _ _) = maybeToList $ do   (ty, _) <- M.lookup (path, name) $ names env-  return $ replicate indent ' ' ++ "foreign import " ++ show name ++ " :: " ++ prettyPrintType ty-externToPs indent path env (DataDeclaration name _ _) = do+  return $ "foreign import " ++ show name ++ " :: " ++ prettyPrintType ty+declToPs path env (BindingGroupDeclaration vals) = do+  flip mapMaybe vals $ \(name, _) -> do+    (ty, _) <- M.lookup (path, name) $ names env+    return $ "foreign import " ++ show name ++ " :: " ++ prettyPrintType ty+declToPs path env (DataDeclaration name _ _) = maybeToList $ do   (kind, _) <- M.lookup (path, name) $ types env-  return $ replicate indent ' ' ++ "foreign import data " ++ show name ++ " :: " ++ prettyPrintKind kind-externToPs indent _ _ (ExternMemberDeclaration member name ty) =-  return $ replicate indent ' ' ++ "foreign import member " ++ show member ++ " " ++ show name ++ " :: " ++ prettyPrintType ty-externToPs indent _ _ (ExternDataDeclaration name kind) =-  return $ replicate indent ' ' ++ "foreign import data " ++ show name ++ " :: " ++ prettyPrintKind kind-externToPs indent _ _ (TypeSynonymDeclaration name args ty) =-  return $ replicate indent ' ' ++ "type " ++ show name ++ " " ++ unwords args ++ " = " ++ prettyPrintType ty-externToPs indent path env (ModuleDeclaration name decls) =-  return $ replicate indent ' ' ++ "module " ++ show name ++ " where\n" ++ unlines (mapMaybe (externToPs (indent + 2) (subModule path name) env) decls)-externToPs _ _ _ _ = Nothing+  return $ "foreign import data " ++ show name ++ " :: " ++ prettyPrintKind kind+declToPs _ _ (ExternMemberDeclaration member name ty) =+  return $ "foreign import member " ++ show member ++ " " ++ show name ++ " :: " ++ prettyPrintType ty+declToPs _ _ (ExternDataDeclaration name kind) =+  return $ "foreign import data " ++ show name ++ " :: " ++ prettyPrintKind kind+declToPs _ _ (TypeSynonymDeclaration name args ty) =+  return $ "type " ++ show name ++ " " ++ unwords args ++ " = " ++ prettyPrintType ty+declToPs _ _ _ = []
src/Language/PureScript/CodeGen/JS.hs view
@@ -14,7 +14,8 @@  module Language.PureScript.CodeGen.JS (     module AST,-    declToJs+    declToJs,+    moduleToJs ) where  import Data.Maybe (mapMaybe)@@ -32,40 +33,47 @@ import Language.PureScript.CodeGen.JS.AST as AST import Language.PureScript.TypeChecker.Monad (NameKind(..)) -declToJs :: Maybe Ident -> ModulePath -> Declaration -> Environment -> Maybe [JS]-declToJs curMod mp (ValueDeclaration ident _ _ (Abs args ret)) e =-  Just $ JSFunction (Just ident) args (JSBlock [JSReturn (valueToJs mp e ret)]) :-         maybe [] (return . setProperty (identToJs ident) (JSVar ident)) curMod-declToJs curMod mp (ValueDeclaration ident _ _ val) e =-  Just $ JSVariableIntroduction ident (Just (valueToJs mp e val)) :-         maybe [] (return . setProperty (identToJs ident) (JSVar ident)) curMod-declToJs curMod _ (ExternMemberDeclaration member ident _) _ =-  Just $ JSFunction (Just ident) [Ident "value"] (JSBlock [JSReturn (JSAccessor member (JSVar (Ident "value")))]) :-         maybe [] (return . setProperty (show ident) (JSVar ident)) curMod-declToJs curMod mp (DataDeclaration _ _ ctors) _ =+moduleToJs :: Module -> Environment -> [JS]+moduleToJs (Module pname@(ProperName name) decls) env =+  [ JSVariableIntroduction (Ident name) Nothing+  , JSApp (JSFunction Nothing [Ident name]+                      (JSBlock (concat $ mapMaybe (\decl -> declToJs (ModuleName pname) decl env) decls)))+          [JSAssignment (JSAssignVariable (Ident name))+                         (JSBinary Or (JSVar (Ident name)) (JSObjectLiteral []))]+  ]++declToJs :: ModuleName -> Declaration -> Environment -> Maybe [JS]+declToJs mp (ValueDeclaration ident _ _ (Abs args ret)) e =+  Just [ JSFunction (Just ident) args (JSBlock [JSReturn (valueToJs mp e ret)]),+         setProperty (identToJs ident) (JSVar ident) mp ]+declToJs mp (ValueDeclaration ident _ _ val) e =+  Just [ JSVariableIntroduction ident (Just (valueToJs mp e val)),+         setProperty (identToJs ident) (JSVar ident) mp ]+declToJs mp (BindingGroupDeclaration vals) e =+  Just $ concatMap (\(ident, val) ->+           [ JSVariableIntroduction ident (Just (valueToJs mp e val)),+             setProperty (identToJs ident) (JSVar ident) mp ]+         ) vals+declToJs mp (ExternMemberDeclaration member ident _) _ =+  Just [ JSFunction (Just ident) [Ident "value"] (JSBlock [JSReturn (JSAccessor member (JSVar (Ident "value")))]),+         setProperty (show ident) (JSVar ident) mp ]+declToJs mp (DataDeclaration _ _ ctors) _ =   Just $ flip concatMap ctors $ \(pn@(ProperName ctor), maybeTy) ->     let       ctorJs =         case maybeTy of-          Nothing -> JSVariableIntroduction (Ident ctor) (Just (JSObjectLiteral [ ("ctor", JSStringLiteral (show (Qualified mp pn))) ]))+          Nothing -> JSVariableIntroduction (Ident ctor) (Just (JSObjectLiteral [ ("ctor", JSStringLiteral (show (Qualified (Just mp) pn))) ]))           Just _ -> JSFunction (Just (Ident ctor)) [Ident "value"]                       (JSBlock [JSReturn-                        (JSObjectLiteral [ ("ctor", JSStringLiteral (show (Qualified mp pn)))+                        (JSObjectLiteral [ ("ctor", JSStringLiteral (show (Qualified (Just mp) pn)))                                          , ("value", JSVar (Ident "value")) ])])-    in ctorJs : maybe [] (return . setProperty ctor (JSVar (Ident ctor))) curMod-declToJs curMod mp (ModuleDeclaration pn@(ProperName name) decls) env =-  Just $ [ JSVariableIntroduction (Ident name) Nothing-         , JSApp (JSFunction Nothing [Ident name]-                             (JSBlock (concat $ mapMaybe (\decl -> declToJs (Just (Ident name)) (subModule mp pn) decl env) decls)))-                 [JSAssignment (JSAssignVariable (Ident name))-                               (JSBinary Or (JSVar (Ident name)) (JSObjectLiteral []))]] ++-         maybe [] (return . setProperty name (JSVar (Ident name))) curMod-declToJs _ _ _ _ = Nothing+    in [ ctorJs, setProperty ctor (JSVar (Ident ctor)) mp ]+declToJs _ _ _ = Nothing -setProperty :: String -> JS -> Ident -> JS-setProperty prop val curMod = JSAssignment (JSAssignProperty prop (JSAssignVariable curMod)) val+setProperty :: String -> JS -> ModuleName -> JS+setProperty prop val (ModuleName (ProperName moduleName)) = JSAssignment (JSAssignProperty prop (JSAssignVariable (Ident moduleName))) val -valueToJs :: ModulePath -> Environment -> Value -> JS+valueToJs :: ModuleName -> Environment -> Value -> JS valueToJs _ _ (NumericLiteral n) = JSNumericLiteral n valueToJs _ _ (StringLiteral s) = JSStringLiteral s valueToJs _ _ (BooleanLiteral b) = JSBooleanLiteral b@@ -82,20 +90,27 @@ valueToJs m e (Abs args val) = JSFunction Nothing args (JSBlock [JSReturn (valueToJs m e val)]) valueToJs m e (Unary op val) = JSUnary op (valueToJs m e val) valueToJs m e (Binary op v1 v2) = JSBinary op (valueToJs m e v1) (valueToJs m e v2)-valueToJs m e (Var ident) = case M.lookup (qualify m ident) (names e) of-  Just (_, Alias aliasModule aliasIdent) -> qualifiedToJS identToJs (Qualified aliasModule aliasIdent)-  _ -> qualifiedToJS identToJs ident+valueToJs m e (Var ident) = varToJs m e ident valueToJs m e (TypedValue val _) = valueToJs m e val valueToJs _ _ _ = error "Invalid argument to valueToJs" +varToJs :: ModuleName -> Environment -> Qualified Ident -> JS+varToJs m e qual@(Qualified _ ident) = case M.lookup (qualify m qual) (names e) of+  Just (_, ty) | isExtern ty -> JSVar ident+  Just (_, Alias aliasModule aliasIdent) -> qualifiedToJS identToJs (Qualified (Just aliasModule) aliasIdent)+  _ -> qualifiedToJS identToJs qual+  where+  isExtern Extern = True+  isExtern (Alias m' ident') = case M.lookup (m', ident') (names e) of+    Just (_, ty') -> isExtern ty'+    Nothing -> error "Undefined alias in varToJs"+  isExtern _ = False+ qualifiedToJS :: (a -> String) -> Qualified a -> JS-qualifiedToJS f (Qualified (ModulePath parts) a) =-  delimited (f a : reverse (map show parts))- where delimited [part]       = JSVar (Ident (part))-       delimited (part:parts') = JSAccessor part (delimited parts')-       delimited _            = error "Invalid argument to delimited"+qualifiedToJS f (Qualified (Just (ModuleName (ProperName m))) a) = JSAccessor (f a) (JSVar (Ident m))+qualifiedToJS f (Qualified Nothing a) = JSVar (Ident (f a)) -bindersToJs :: ModulePath -> Environment -> [([Binder], Maybe Guard, Value)] -> [JS] -> Gen JS+bindersToJs :: ModuleName -> Environment -> [([Binder], Maybe Guard, Value)] -> [JS] -> Gen JS bindersToJs m e binders vals = do   setNextName $ firstUnusedName (binders, vals)   valNames <- replicateM (length vals) fresh@@ -111,7 +126,7 @@       binderToJs m e v done'' b     go _ _ _ _ = error "Invalid arguments to bindersToJs" -binderToJs :: ModulePath -> Environment -> String -> [JS] -> Binder -> Gen [JS]+binderToJs :: ModuleName -> Environment -> String -> [JS] -> Binder -> Gen [JS] binderToJs _ _ _ done NullBinder = return done binderToJs _ _ varName done (StringBinder str) =   return [JSIfElse (JSBinary EqualTo (JSVar (Ident varName)) (JSStringLiteral str)) (JSBlock done) Nothing]@@ -124,11 +139,11 @@ binderToJs _ _ varName done (VarBinder ident) =   return (JSVariableIntroduction ident (Just (JSVar (Ident varName))) : done) binderToJs m _ varName done (NullaryBinder ctor) =-  return [JSIfElse (JSBinary EqualTo (JSAccessor "ctor" (JSVar (Ident varName))) (JSStringLiteral (show (uncurry Qualified $ qualify m ctor)))) (JSBlock done) Nothing]+  return [JSIfElse (JSBinary EqualTo (JSAccessor "ctor" (JSVar (Ident varName))) (JSStringLiteral (show ((\(mp, nm) -> Qualified (Just mp) nm) $ qualify m ctor)))) (JSBlock done) Nothing] binderToJs m e varName done (UnaryBinder ctor b) = do   value <- fresh   js <- binderToJs m e value done b-  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]+  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] binderToJs m e varName done (ObjectBinder bs) = go done bs   where   go :: [JS] -> [(String, Binder)] -> Gen [JS]@@ -163,7 +178,7 @@   js <- binderToJs m e varName done binder   return (JSVariableIntroduction ident (Just (JSVar (Ident varName))) : js) -statementToJs :: ModulePath -> Environment -> Statement -> JS+statementToJs :: ModuleName -> Environment -> Statement -> JS statementToJs m e (VariableIntroduction ident value) = JSVariableIntroduction ident (Just (valueToJs m e value)) statementToJs m e (Assignment target value) = JSAssignment (JSAssignVariable target) (valueToJs m e value) statementToJs m e (While cond sts) = JSWhile (valueToJs m e cond) (JSBlock (map (statementToJs m e) sts))
src/Language/PureScript/Declarations.hs view
@@ -29,15 +29,18 @@  data Fixity = Fixity Associativity Precedence deriving (Show, D.Data, D.Typeable) +data Module = Module ProperName [Declaration] deriving (Show, D.Data, D.Typeable)+ data Declaration   = DataDeclaration ProperName [String] [(ProperName, Maybe PolyType)]+  | DataBindingGroupDeclaration [(ProperName, [String], [(ProperName, Maybe PolyType)])]   | TypeSynonymDeclaration ProperName [String] PolyType   | TypeDeclaration Ident PolyType   | ValueDeclaration Ident [[Binder]] (Maybe Guard) Value+  | BindingGroupDeclaration [(Ident, Value)]   | ExternDeclaration Ident PolyType   | ExternMemberDeclaration String Ident PolyType   | ExternDataDeclaration ProperName Kind   | FixityDeclaration Fixity String-  | ModuleDeclaration ProperName [Declaration]-  | ImportDeclaration ModulePath (Maybe [Ident])+  | ImportDeclaration ModuleName (Maybe [Either Ident ProperName])   deriving (Show, D.Data, D.Typeable)
src/Language/PureScript/Names.hs view
@@ -17,7 +17,6 @@ module Language.PureScript.Names where  import Data.Data-import Data.List (inits, intercalate)  data Ident = Ident String | Op String deriving (Eq, Ord, Data, Typeable) @@ -30,26 +29,17 @@ instance Show ProperName where   show = runProperName -data ModulePath = ModulePath [ProperName] deriving (Eq, Ord, Data, Typeable)--instance Show ModulePath where-  show (ModulePath segments) = intercalate "." $ map show segments--subModule :: ModulePath -> ProperName -> ModulePath-subModule (ModulePath mp) name = ModulePath (mp ++ [name])+data ModuleName = ModuleName ProperName deriving (Eq, Ord, Data, Typeable) -global :: ModulePath-global = ModulePath []+instance Show ModuleName where+  show (ModuleName name) = show name -data Qualified a = Qualified ModulePath a deriving (Eq, Ord, Data, Typeable)+data Qualified a = Qualified (Maybe ModuleName) a deriving (Eq, Ord, Data, Typeable)  instance (Show a) => Show (Qualified a) where-  show (Qualified (ModulePath names) a) = intercalate "." (map show names ++ [show a])--qualify :: ModulePath -> Qualified a -> (ModulePath, a)-qualify mp (Qualified (ModulePath []) a) = (mp, a)-qualify _ (Qualified mp a) = (mp, a)+  show (Qualified Nothing a) = show a+  show (Qualified (Just (ModuleName name)) a) = show name ++ "." ++ show a -nameResolution :: ModulePath -> Qualified a -> [(ModulePath, a)]-nameResolution (ModulePath mp) (Qualified (ModulePath []) a) = [ (ModulePath mp', a) | mp' <- reverse $ inits mp ]-nameResolution _ (Qualified mp a) = [(mp, a)]+qualify :: ModuleName -> Qualified a -> (ModuleName, a)+qualify m (Qualified Nothing a) = (m, a)+qualify _ (Qualified (Just m) a) = (m, a)
src/Language/PureScript/Operators.hs view
@@ -33,12 +33,12 @@ import qualified Text.Parsec.Pos as P import qualified Text.Parsec.Expr as P -rebracket :: [Declaration] -> Either String [Declaration]-rebracket ds = do-  m <- collectFixities ds+rebracket :: [Module] -> Either String [Module]+rebracket ms = forM ms $ \(Module name ds) -> do+  m <- collectFixities (ModuleName name) ds   let opTable = customOperatorTable m-  ds' <- G.everywhereM' (G.mkM (matchOperators opTable)) ds-  return $ G.everywhere (G.mkT removeParens) ds'+  ds' <- G.everywhereM' (G.mkM (matchOperators (ModuleName name) opTable)) ds+  return $ Module name $ G.everywhere (G.mkT removeParens) ds'  removeParens :: Value -> Value removeParens (Parens val) = val@@ -56,8 +56,8 @@  type Chain = [Either Value (Qualified Ident)] -matchOperators :: [[(Qualified Ident, Value -> Value -> Value, Associativity)]] -> Value -> Either String Value-matchOperators ops val = G.everywhereM' (G.mkM parseChains) val+matchOperators :: ModuleName -> [[(Qualified Ident, Value -> Value -> Value, Associativity)]] -> Value -> Either String Value+matchOperators moduleName ops val = G.everywhereM' (G.mkM parseChains) val   where   parseChains :: Value -> Either String Value   parseChains b@(BinaryNoParens _ _ _) = bracketChain (extendChain b)@@ -67,7 +67,7 @@   extendChain other = [Left other]   bracketChain :: Chain -> Either String Value   bracketChain = either (Left . show) Right . P.parse (P.buildExpressionParser opTable parseValue <* P.eof) "operator expression"-  opTable = map (map (\(name, f, a) -> P.Infix (P.try (matchOp name) >> return f) (toAssoc a))) ops+  opTable = map (map (\(name, f, a) -> P.Infix (P.try (matchOp moduleName name) >> return f) (toAssoc a))) ops     ++ [[P.Infix (P.try (parseOp >>= \ident -> return (\t1 t2 -> App (App (Var ident) [t1]) [t2]))) P.AssocLeft]]  toAssoc :: Associativity -> P.Assoc@@ -80,27 +80,24 @@ parseOp :: P.Parsec Chain () (Qualified Ident) parseOp = P.token show (const (P.initialPos "")) (either (const Nothing) Just) P.<?> "operator" -matchOp :: Qualified Ident -> P.Parsec Chain () ()-matchOp op = do+matchOp :: ModuleName -> Qualified Ident -> P.Parsec Chain () ()+matchOp moduleName op = do   ident <- parseOp-  guard (ident == op)+  guard (qualify moduleName ident == qualify moduleName op) -collectFixities :: [Declaration] -> Either String (M.Map (Qualified Ident) Fixity)-collectFixities = go M.empty global+collectFixities :: ModuleName -> [Declaration] -> Either String (M.Map (Qualified Ident) Fixity)+collectFixities = go M.empty   where-  go :: M.Map (Qualified Ident) Fixity -> ModulePath -> [Declaration] -> Either String (M.Map (Qualified Ident) Fixity)+  go :: M.Map (Qualified Ident) Fixity -> ModuleName -> [Declaration] -> Either String (M.Map (Qualified Ident) Fixity)   go m _ [] = return m-  go m p (FixityDeclaration fixity name : rest) = do-    let qual = Qualified p (Op name)+  go m moduleName (FixityDeclaration fixity name : rest) = do+    let qual = Qualified (Just moduleName) (Op name)     when (qual `M.member` m) (Left $ "redefined fixity for " ++ show name)-    go (M.insert qual fixity m) p rest-  go m p (ModuleDeclaration name decls : rest) = do-    m' <- go m (subModule p name) decls-    go m' p rest-  go m p (_:ds) = go m p ds+    go (M.insert qual fixity m) moduleName rest+  go m moduleName (_:ds) = go m moduleName ds  globalOp :: String -> Qualified Ident-globalOp = Qualified global . Op+globalOp = Qualified Nothing . Op  builtIns :: [(Qualified Ident, Value -> Value -> Value, Precedence, Associativity)] builtIns = [ (globalOp "<", Binary LessThan, 3, Infixl)
src/Language/PureScript/Parser/Common.hs view
@@ -188,11 +188,10 @@ properName = lexeme $ ProperName <$> P.try ((:) <$> P.upper <*> many (PT.identLetter langDef) P.<?> "name")  parseQualified :: P.Parsec String ParseState a -> P.Parsec String ParseState (Qualified a)-parseQualified parser = part global+parseQualified parser = qual   where-  part path = (do name <- P.try (properName <* delimiter)-                  part (subModule path name))-              <|> (Qualified path <$> P.try parser)+  qual = (Qualified <$> (Just . ModuleName <$> P.try (properName <* delimiter)) <*> parser)+     <|> (Qualified Nothing <$> P.try parser)   delimiter = indented *> dot  integerOrFloat :: P.Parsec String u (Either Integer Double)
src/Language/PureScript/Parser/Declarations.hs view
@@ -14,7 +14,8 @@  module Language.PureScript.Parser.Declarations (     parseDeclaration,-    parseDeclarations+    parseModule,+    parseModules ) where  import Control.Applicative@@ -84,25 +85,13 @@   name <- operator   return $ FixityDeclaration fixity name -parseModuleDeclaration :: P.Parsec String ParseState Declaration-parseModuleDeclaration = do-  reserved "module"-  indented-  name <- properName-  lexeme $ P.string "where"-  decls <- mark (P.many (same *> parseDeclaration))-  return $ ModuleDeclaration name decls--parseModulePath :: P.Parsec String ParseState ModulePath-parseModulePath = ModulePath <$> properName `sepBy1` dot- parseImportDeclaration :: P.Parsec String ParseState Declaration parseImportDeclaration = do   reserved "import"   indented-  modulePath <- parseModulePath-  idents <- P.optionMaybe $ parens $ commaSep1 parseIdent-  return $ ImportDeclaration modulePath idents+  moduleName <- ModuleName <$> properName+  idents <- P.optionMaybe $ parens $ commaSep1 (Left <$> parseIdent <|> Right <$> properName)+  return $ ImportDeclaration moduleName idents  parseDeclaration :: P.Parsec String ParseState Declaration parseDeclaration = P.choice@@ -112,8 +101,16 @@                    , parseValueDeclaration                    , parseExternDeclaration                    , parseFixityDeclaration-                   , parseModuleDeclaration                    , parseImportDeclaration ] P.<?> "declaration" -parseDeclarations :: P.Parsec String ParseState [Declaration]-parseDeclarations = whiteSpace *> mark (P.many (same *> parseDeclaration)) <* P.eof+parseModule :: P.Parsec String ParseState Module+parseModule = do+  reserved "module"+  indented+  name <- properName+  lexeme $ P.string "where"+  decls <- mark (P.many (same *> parseDeclaration))+  return $ Module name decls++parseModules :: P.Parsec String ParseState [Module]+parseModules = whiteSpace *> mark (P.many (same *> parseModule)) <* P.eof
src/Language/PureScript/Scope.hs view
@@ -32,7 +32,7 @@   where   namesV :: Value -> [Ident]   namesV (Abs args _) = args-  namesV (Var (Qualified (ModulePath []) name)) = [name]+  namesV (Var (Qualified Nothing name)) = [name]   namesV _ = []   namesS :: Statement -> [Ident]   namesS (VariableIntroduction name _) = [name]
src/Language/PureScript/TypeChecker.hs view
@@ -26,114 +26,173 @@  import Data.Maybe import qualified Data.Map as M+import Control.Monad.State+import Control.Monad.Error+import Data.Either (rights, lefts) -import Language.PureScript.Values import Language.PureScript.Types import Language.PureScript.Names import Language.PureScript.Kinds import Language.PureScript.Declarations -import Control.Monad.State-import Control.Monad.Error+addDataType :: ModuleName -> ProperName -> [String] -> [(ProperName, Maybe Type)] -> Kind -> Check ()+addDataType moduleName name args dctors ctorKind = do+  env <- getEnv+  putEnv $ env { types = M.insert (moduleName, name) (ctorKind, Data) (types env) }+  forM_ dctors $ \(dctor, maybeTy) ->+    rethrow (("Error in data constructor " ++ show name ++ ":\n") ++) $+      addDataConstructor moduleName name args dctor maybeTy -typeCheckAll :: [Declaration] -> Check ()-typeCheckAll [] = return ()-typeCheckAll (DataDeclaration name args dctors : rest) = do+addDataConstructor :: ModuleName -> ProperName -> [String] -> ProperName -> Maybe Type -> Check ()+addDataConstructor moduleName name args dctor maybeTy = do+  env <- getEnv+  dataConstructorIsNotDefined moduleName dctor+  let retTy = foldl TypeApp (TypeConstructor (Qualified (Just moduleName) name)) (map TypeVar args)+  let dctorTy = maybe retTy (\ty -> Function [ty] retTy) maybeTy+  let polyType = mkForAll args dctorTy+  putEnv $ env { dataConstructors = M.insert (moduleName, dctor) polyType (dataConstructors env) }++addTypeSynonym :: ModuleName -> ProperName -> [String] -> Type -> Kind -> Check ()+addTypeSynonym moduleName name args ty kind = do+  env <- getEnv+  putEnv $ env { types = M.insert (moduleName, name) (kind, TypeSynonym) (types env)+               , typeSynonyms = M.insert (moduleName, name) (args, ty) (typeSynonyms env) }++typeIsNotDefined :: ModuleName -> ProperName -> Check ()+typeIsNotDefined moduleName name = do+  env <- getEnv+  guardWith (show name ++ " is already defined") $+    not $ M.member (moduleName, name) (types env)++dataConstructorIsNotDefined :: ModuleName -> ProperName -> Check ()+dataConstructorIsNotDefined moduleName dctor = do+  env <- getEnv+  guardWith (show dctor ++ " is already defined") $+    not $ M.member (moduleName, dctor) (dataConstructors env)++valueIsNotDefined :: ModuleName -> Ident -> Check ()+valueIsNotDefined moduleName name = do+  env <- getEnv+  case M.lookup (moduleName, name) (names env) of+    Just _ -> throwError $ show name ++ " is already defined"+    Nothing -> return ()++addValue :: ModuleName -> Ident -> Type -> Check ()+addValue moduleName name ty = do+  env <- getEnv+  putEnv (env { names = M.insert (moduleName, name) (ty, Value) (names env) })++typeCheckAll :: ModuleName -> [Declaration] -> Check ()+typeCheckAll _ [] = return ()+typeCheckAll moduleName (DataDeclaration name args dctors : rest) = do   rethrow (("Error in type constructor " ++ show name ++ ":\n") ++) $ do-    env <- getEnv-    modulePath <- checkModulePath `fmap` get-    guardWith (show name ++ " is already defined") $ not $ M.member (modulePath, name) (types env)-    ctorKind <- kindsOf (Just name) args (mapMaybe snd dctors)-    putEnv $ env { types = M.insert (modulePath, name) (ctorKind, Data) (types env) }-    forM_ dctors $ \(dctor, maybeTy) ->-      rethrow (("Error in data constructor " ++ show name ++ ":\n") ++) $ do-        env' <- getEnv-        guardWith (show dctor ++ " is already defined") $ not $ M.member (modulePath, dctor) (dataConstructors env')-        let retTy = foldl TypeApp (TypeConstructor (Qualified modulePath name)) (map TypeVar args)-        let dctorTy = maybe retTy (\ty -> Function [ty] retTy) maybeTy-        let polyType = mkForAll args dctorTy-        putEnv $ env' { dataConstructors = M.insert (modulePath, dctor) polyType (dataConstructors env') }-  typeCheckAll rest-typeCheckAll (TypeSynonymDeclaration name args ty : rest) = do+    typeIsNotDefined moduleName name+    ctorKind <- kindsOf moduleName name args (mapMaybe snd dctors)+    addDataType moduleName name args dctors ctorKind+  typeCheckAll moduleName rest+typeCheckAll moduleName (DataBindingGroupDeclaration tys : rest) = do+  rethrow (("Error in data binding group " ++ show (map (\(name, _, _) -> name) tys) ++ ":\n") ++) $ do+    forM_ tys $ \(name, _, _) ->+      typeIsNotDefined moduleName name+    ks <- kindsOfAll moduleName (map (\(name, args, dctors) -> (name, args, mapMaybe snd dctors)) tys)+    forM (zip tys ks) $ \((name, args, dctors), ctorKind) ->+      addDataType moduleName name args dctors ctorKind+  typeCheckAll moduleName rest+typeCheckAll moduleName (TypeSynonymDeclaration name args ty : rest) = do   rethrow (("Error in type synonym " ++ show name ++ ":\n") ++) $ do-    env <- getEnv-    modulePath <- checkModulePath `fmap` get-    guardWith (show name ++ " is already defined") $ not $ M.member (modulePath, name) (types env)-    kind <- kindsOf (Just name) args [ty]-    putEnv $ env { types = M.insert (modulePath, name) (kind, TypeSynonym) (types env)-                 , typeSynonyms = M.insert (modulePath, name) (args, ty) (typeSynonyms env) }-  typeCheckAll rest-typeCheckAll (TypeDeclaration name ty : ValueDeclaration name' [] Nothing val : rest) | name == name' =-  typeCheckAll (ValueDeclaration name [] Nothing (TypedValue val ty) : rest)-typeCheckAll (TypeDeclaration name _ : _) = throwError $ "Orphan type declaration for " ++ show name-typeCheckAll (ValueDeclaration name [] Nothing val : rest) = do+    typeIsNotDefined moduleName name+    kind <- kindsOf moduleName name args [ty]+    addTypeSynonym moduleName name args ty kind+  typeCheckAll moduleName rest+typeCheckAll _ (TypeDeclaration _ _ : _) = error "Type declarations should have been removed"+typeCheckAll moduleName (ValueDeclaration name [] Nothing val : rest) = do   rethrow (("Error in declaration " ++ show name ++ ":\n") ++) $ do-    env <- getEnv-    modulePath <- checkModulePath `fmap` get-    case M.lookup (modulePath, name) (names env) of-      Just _ -> throwError $ show name ++ " is already defined"-      Nothing -> do-        ty <- typeOf (Just name) val-        putEnv (env { names = M.insert (modulePath, name) (ty, Value) (names env) })-  typeCheckAll rest-typeCheckAll (ValueDeclaration _ _ _ _ : _) = error "Binders were not desugared"-typeCheckAll (ExternDataDeclaration name kind : rest) = do+    valueIsNotDefined moduleName name+    [ty] <- typesOf moduleName [(name, val)]+    addValue moduleName name ty+  typeCheckAll moduleName rest+typeCheckAll _ (ValueDeclaration _ _ _ _ : _) = error "Binders were not desugared"+typeCheckAll moduleName (BindingGroupDeclaration vals : rest) = do+  rethrow (("Error in binding group " ++ show (map fst vals) ++ ":\n") ++) $ do+    forM_ (map fst vals) $ \name ->+      valueIsNotDefined moduleName name+    tys <- typesOf moduleName vals+    forM (zip (map fst vals) tys) $ \(name, ty) ->+      addValue moduleName name ty+  typeCheckAll moduleName rest+typeCheckAll moduleName (ExternDataDeclaration name kind : rest) = do   env <- getEnv-  modulePath <- checkModulePath `fmap` get-  guardWith (show name ++ " is already defined") $ not $ M.member (modulePath, name) (types env)-  putEnv $ env { types = M.insert (modulePath, name) (kind, TypeSynonym) (types env) }-  typeCheckAll rest-typeCheckAll (ExternMemberDeclaration member name ty : rest) = do+  guardWith (show name ++ " is already defined") $ not $ M.member (moduleName, name) (types env)+  putEnv $ env { types = M.insert (moduleName, name) (kind, TypeSynonym) (types env) }+  typeCheckAll moduleName rest+typeCheckAll moduleName (ExternMemberDeclaration member name ty : rest) = do   rethrow (("Error in foreign import member declaration " ++ show name ++ ":\n") ++) $ do     env <- getEnv-    modulePath <- checkModulePath `fmap` get-    kind <- kindOf ty+    kind <- kindOf moduleName ty     guardWith "Expected kind *" $ kind == Star-    case M.lookup (modulePath, name) (names env) of+    case M.lookup (moduleName, name) (names env) of       Just _ -> throwError $ show name ++ " is already defined"       Nothing -> case ty of         _ | isSingleArgumentFunction ty -> do-          putEnv (env { names = M.insert (modulePath, name) (ty, Extern) (names env)-                      , members = M.insert (modulePath, name) member (members env) })+          putEnv (env { names = M.insert (moduleName, name) (ty, Extern) (names env)+                      , members = M.insert (moduleName, name) member (members env) })           | otherwise -> throwError "Foreign member declarations must have function types, with an single argument."-  typeCheckAll rest+  typeCheckAll moduleName rest   where     isSingleArgumentFunction (Function [_] _) = True     isSingleArgumentFunction (ForAll _ t) = isSingleArgumentFunction t     isSingleArgumentFunction _ = False-typeCheckAll (ExternDeclaration name ty : rest) = do+typeCheckAll moduleName (ExternDeclaration name ty : rest) = do   rethrow (("Error in foreign import declaration " ++ show name ++ ":\n") ++) $ do     env <- getEnv-    modulePath <- checkModulePath `fmap` get-    kind <- kindOf ty+    kind <- kindOf moduleName ty     guardWith "Expected kind *" $ kind == Star-    case M.lookup (modulePath, name) (names env) of+    case M.lookup (moduleName, name) (names env) of       Just _ -> throwError $ show name ++ " is already defined"-      Nothing -> putEnv (env { names = M.insert (modulePath, name) (ty, Extern) (names env) })-  typeCheckAll rest-typeCheckAll (FixityDeclaration _ name : rest) = do-  typeCheckAll rest+      Nothing -> putEnv (env { names = M.insert (moduleName, name) (ty, Extern) (names env) })+  typeCheckAll moduleName rest+typeCheckAll moduleName (FixityDeclaration _ name : rest) = do+  typeCheckAll moduleName rest   env <- getEnv-  modulePath <- checkModulePath `fmap` get-  guardWith ("Fixity declaration with no binding: " ++ name) $ M.member (modulePath, Op name) $ names env-typeCheckAll (ModuleDeclaration name decls : rest) = do-  withModule name $ typeCheckAll decls-  typeCheckAll rest-typeCheckAll (ImportDeclaration modulePath idents : rest) = do+  guardWith ("Fixity declaration with no binding: " ++ name) $ M.member (moduleName, Op name) $ names env+typeCheckAll currentModule (ImportDeclaration moduleName idents : rest) = do   env <- getEnv-  currentModule <- checkModulePath `fmap` get   rethrow errorMessage $ do-    guardWith ("Module " ++ show modulePath ++ " does not exist") $ moduleExists env+    guardWith ("Module " ++ show moduleName ++ " does not exist") $ moduleExists env     case idents of-      Nothing     -> bindIdents (map snd $ filterModule env) currentModule env-      Just idents' -> bindIdents idents' currentModule env-  typeCheckAll rest- where errorMessage = (("Error in import declaration " ++ show modulePath ++ ":\n") ++)-       filterModule = filter ((== modulePath) . fst) . M.keys . names-       moduleExists env = not $ null $ filterModule env-       bindIdents idents' currentModule env =+      Nothing -> do+        shadowIdents (map snd $ filterModule (names env)) env+        shadowTypes (map snd $ filterModule (types env)) env+      Just idents' -> do+        shadowIdents (lefts idents') env+        shadowTypes (rights idents') env+  typeCheckAll currentModule rest+ where errorMessage = (("Error in import declaration " ++ show moduleName ++ ":\n") ++)+       filterModule = filter ((== moduleName) . fst) . M.keys+       moduleExists env = not (null (filterModule (names env))) || not (null (filterModule (types env)))+       shadowIdents idents' env =          forM_ idents' $ \ident -> do            guardWith (show currentModule ++ "." ++ show ident ++ " is already defined") $ (currentModule, ident) `M.notMember` names env-           case (modulePath, ident) `M.lookup` names env of-             Just (pt, _) -> modifyEnv (\e -> e { names = M.insert (currentModule, ident) (pt, Alias modulePath ident) (names e) })-             Nothing -> throwError (show modulePath ++ "." ++ show ident ++ " is undefined")+           case (moduleName, ident) `M.lookup` names env of+             Just (pt, _) -> modifyEnv (\e -> e { names = M.insert (currentModule, ident) (pt, Alias moduleName ident) (names e) })+             Nothing -> throwError (show moduleName ++ "." ++ show ident ++ " is undefined")+       shadowTypes pns env =+         forM_ pns $ \pn -> do+           guardWith (show currentModule ++ "." ++ show pn ++ " is already defined") $ (currentModule, pn) `M.notMember` types env+           case (moduleName, pn) `M.lookup` types env of+             Nothing -> throwError (show moduleName ++ "." ++ show pn ++ " is undefined")+             Just (k, _) -> do+               modifyEnv (\e -> e { types = M.insert (currentModule, pn) (k, DataAlias moduleName pn) (types e) })+               let keys = map (snd . fst) . filter (\(_, fn) -> fn `constructs` pn) . M.toList . dataConstructors $ env+               forM_ keys $ \dctor -> do+                 guardWith (show currentModule ++ "." ++ show dctor ++ " is already defined") $ (currentModule, dctor) `M.notMember` dataConstructors env+                 case (moduleName, dctor) `M.lookup` dataConstructors env of+                   Just ctorTy -> modifyEnv (\e -> e { dataConstructors = M.insert (currentModule, dctor) ctorTy (dataConstructors e) })+                   Nothing -> throwError (show moduleName ++ "." ++ show dctor ++ " is undefined")+       constructs (TypeConstructor (Qualified (Just mn) pn')) pn+         = mn == moduleName && pn' == pn+       constructs (ForAll _ ty) pn = ty `constructs` pn+       constructs (Function _ ty) pn = ty `constructs` pn+       constructs (TypeApp ty _) pn = ty `constructs` pn+       constructs fn _ = error $ "Invalid arguments to construct" ++ show fn+
src/Language/PureScript/TypeChecker/Kinds.hs view
@@ -15,8 +15,9 @@ {-# LANGUAGE DeriveDataTypeable #-}  module Language.PureScript.TypeChecker.Kinds (+    kindOf,     kindsOf,-    kindOf+    kindsOfAll ) where  import Language.PureScript.Types@@ -28,6 +29,7 @@  import Control.Monad.State import Control.Monad.Error+import Control.Monad.Reader  import Control.Applicative @@ -53,14 +55,31 @@   unknowns (FunKind k1 k2) = unknowns k1 ++ unknowns k2   unknowns _ = [] -kindOf :: Type -> Check Kind-kindOf ty = fmap (\(k, _, _) -> k) . runSubst $ starIfUnknown <$> infer Nothing M.empty ty+kindOf :: ModuleName -> Type -> Check Kind+kindOf moduleName ty = fmap (\(k, _, _) -> k) . runSubst (SubstContext moduleName) $ starIfUnknown <$> infer ty -kindsOf :: Maybe ProperName -> [String] -> [Type] -> Check Kind-kindsOf name args ts = fmap (starIfUnknown . (\(k, _, _) -> k)) . runSubst $ do+kindsOf :: ModuleName -> ProperName -> [String] -> [PolyType] -> Check Kind+kindsOf moduleName name args ts = fmap (starIfUnknown . (\(k, _, _) -> k)) . runSubst (SubstContext moduleName) $ do   tyCon <- fresh   kargs <- replicateM (length args) fresh-  ks <- inferAll (fmap (\pn -> (pn, tyCon)) name) (M.fromList (zip args kargs)) ts+  let dict = (name, tyCon) : zip (map ProperName args) kargs+  bindLocalTypeVariables moduleName dict $+    solveTypes ts kargs tyCon++kindsOfAll :: ModuleName -> [(ProperName, [String], [PolyType])] -> Check [Kind]+kindsOfAll moduleName tys = fmap (map starIfUnknown . (\(ks, _, _) -> ks)) . runSubst (SubstContext moduleName) $ do+  tyCons <- replicateM (length tys) fresh+  let dict = zipWith (\(name, _, _) tyCon -> (name, tyCon)) tys tyCons+  bindLocalTypeVariables moduleName dict $+    zipWithM (\tyCon (_, args, ts) -> do+      kargs <- replicateM (length args) fresh+      let argDict = zip (map ProperName args) kargs+      bindLocalTypeVariables moduleName argDict $+        solveTypes ts kargs tyCon) tyCons tys++solveTypes :: [Type] -> [Kind] -> Kind -> Subst Kind+solveTypes ts kargs tyCon = do+  ks <- mapM infer ts   tyCon ~~ foldr FunKind Star kargs   forM_ ks $ \k -> k ~~ Star   return tyCon@@ -70,56 +89,51 @@ starIfUnknown (FunKind k1 k2) = FunKind (starIfUnknown k1) (starIfUnknown k2) starIfUnknown k = k -inferAll :: Maybe (ProperName, Kind) -> M.Map String Kind -> [Type] -> Subst [Kind]-inferAll name m = mapM (infer name m)--infer :: Maybe (ProperName, Kind) -> M.Map String Kind -> Type -> Subst Kind-infer name m (Array t) = do-  k <- infer name m t+infer :: Type -> Subst Kind+infer (Array t) = do+  k <- infer t   k ~~ Star   return Star-infer name m (Object row) = do-  k <- inferRow name m row+infer (Object row) = do+  k <- inferRow row   k ~~ Row   return Star-infer name m (Function args ret) = do-  ks <- inferAll name m args-  k <- infer name m ret+infer (Function args ret) = do+  ks <- mapM infer args+  k <- infer ret   k ~~ Star   forM ks (~~ Star)   return Star-infer _ m (TypeVar v) =-  case M.lookup v m of-    Just k -> return k-    Nothing -> throwError $ "Unbound type variable " ++ v-infer (Just (name, k)) _ (TypeConstructor (Qualified (ModulePath []) pn)) | name == pn = return k-infer _ _ (TypeConstructor v) = do+infer (TypeVar v) = do+  moduleName <- substCurrentModule <$> ask+  lookupTypeVariable moduleName (Qualified Nothing (ProperName v))+infer (TypeConstructor v) = do   env <- liftCheck getEnv-  modulePath <- checkModulePath `fmap` get-  case M.lookup (qualify modulePath v) (types env) of+  moduleName <- substCurrentModule `fmap` ask+  case M.lookup (qualify moduleName v) (types env) of     Nothing -> throwError $ "Unknown type constructor '" ++ show v ++ "'"     Just (kind, _) -> return kind-infer name m (TypeApp t1 t2) = do+infer (TypeApp t1 t2) = do   k0 <- fresh-  k1 <- infer name m t1-  k2 <- infer name m t2+  k1 <- infer t1+  k2 <- infer t2   k1 ~~ FunKind k2 k0   return k0-infer name m (ForAll ident ty) = do+infer (ForAll ident ty) = do   k <- fresh-  infer name (M.insert ident k m) ty-infer _ _ _ = return Star+  moduleName <- substCurrentModule <$> ask+  bindLocalTypeVariables moduleName [(ProperName ident, k)] $ infer ty+infer _ = return Star -inferRow :: Maybe (ProperName, Kind) -> M.Map String Kind -> Row -> Subst Kind-inferRow _ m (RowVar v) = do-  case M.lookup v m of-    Just k -> return k-    Nothing -> throwError $ "Unbound row variable " ++ v-inferRow _ _ REmpty = return Row-inferRow name m (RCons _ ty row) = do-  k1 <- infer name m ty-  k2 <- inferRow name m row+inferRow :: Row -> Subst Kind+inferRow (RowVar v) = do+  moduleName <- substCurrentModule <$> ask+  lookupTypeVariable moduleName (Qualified Nothing (ProperName v))+inferRow REmpty = return Row+inferRow (RCons _ ty row) = do+  k1 <- infer ty+  k2 <- inferRow row   k1 ~~ Star   k2 ~~ Row   return Row-inferRow _ _ _ = error "Invalid row in inferRow"+inferRow _ = error "Invalid row in inferRow"
src/Language/PureScript/TypeChecker/Monad.hs view
@@ -28,52 +28,77 @@ import Control.Applicative import Control.Monad.State import Control.Monad.Error+import Control.Monad.Reader  import qualified Data.Map as M -data NameKind = Value | Extern | Alias ModulePath Ident | LocalVariable deriving Show+data NameKind+  = Value+  | Extern+  | Alias ModuleName Ident+  | LocalVariable deriving Show -data TypeDeclarationKind = Data | ExternData | TypeSynonym deriving Show+data TypeDeclarationKind+  = Data+  | ExternData+  | TypeSynonym+  | DataAlias ModuleName ProperName+  | LocalTypeVariable deriving Show  data Environment = Environment-  { names :: M.Map (ModulePath, Ident) (Type, NameKind)-  , types :: M.Map (ModulePath, ProperName) (Kind, TypeDeclarationKind)-  , dataConstructors :: M.Map (ModulePath, ProperName) Type-  , typeSynonyms :: M.Map (ModulePath, ProperName) ([String], Type)-  , members :: M.Map (ModulePath, Ident) String+  { names :: M.Map (ModuleName, Ident) (Type, NameKind)+  , types :: M.Map (ModuleName, ProperName) (Kind, TypeDeclarationKind)+  , dataConstructors :: M.Map (ModuleName, ProperName) Type+  , typeSynonyms :: M.Map (ModuleName, ProperName) ([String], Type)+  , members :: M.Map (ModuleName, Ident) String   } deriving (Show)  emptyEnvironment :: Environment emptyEnvironment = Environment M.empty M.empty M.empty M.empty M.empty -bindNames :: (MonadState CheckState m) => M.Map (ModulePath, Ident) (Type, NameKind) -> m a -> m a+bindNames :: (MonadState CheckState m) => M.Map (ModuleName, Ident) (Type, NameKind) -> m a -> m a bindNames newNames action = do-  orig <-  get+  orig <- get   modify $ \st -> st { checkEnv = (checkEnv st) { names = newNames `M.union` (names . checkEnv $ st) } }   a <- action   modify $ \st -> st { checkEnv = (checkEnv st) { names = names . checkEnv $ orig } }   return a -bindLocalVariables :: (Functor m, MonadState CheckState m) => [(Ident, Type)] -> m a -> m a-bindLocalVariables bindings action = do-  modulePath <- checkModulePath `fmap` get-  bindNames (M.fromList $ flip map bindings $ \(name, ty) -> ((modulePath, name), (ty, LocalVariable))) action+bindTypes :: (MonadState CheckState m) => M.Map (ModuleName, ProperName) (Kind, TypeDeclarationKind) -> m a -> m a+bindTypes newNames action = do+  orig <- get+  modify $ \st -> st { checkEnv = (checkEnv st) { types = newNames `M.union` (types . checkEnv $ st) } }+  a <- action+  modify $ \st -> st { checkEnv = (checkEnv st) { types = types . checkEnv $ orig } }+  return a -lookupVariable :: (Functor m, MonadState CheckState m, MonadError String m) => Qualified Ident -> m Type-lookupVariable var = do+bindLocalVariables :: (Functor m, MonadState CheckState m) => ModuleName -> [(Ident, Type)] -> m a -> m a+bindLocalVariables moduleName bindings action =+  bindNames (M.fromList $ flip map bindings $ \(name, ty) -> ((moduleName, name), (ty, LocalVariable))) action++bindLocalTypeVariables :: (Functor m, MonadState CheckState m) => ModuleName -> [(ProperName, Kind)] -> m a -> m a+bindLocalTypeVariables moduleName bindings action =+  bindTypes (M.fromList $ flip map bindings $ \(name, k) -> ((moduleName, name), (k, LocalTypeVariable))) action++lookupVariable :: (Functor m, MonadState CheckState m, MonadError String m) => ModuleName -> Qualified Ident -> m Type+lookupVariable currentModule (Qualified moduleName var) = do   env <- getEnv-  modulePath <- checkModulePath <$> get-  let tries = map (First . flip M.lookup (names env)) (nameResolution modulePath var)-  case getFirst (mconcat tries) of+  case M.lookup (fromMaybe currentModule moduleName, var) (names env) of     Nothing -> throwError $ show var ++ " is undefined"     Just (ty, _) -> return ty +lookupTypeVariable :: (Functor m, MonadState CheckState m, MonadError String m) => ModuleName -> Qualified ProperName -> m Kind+lookupTypeVariable currentModule (Qualified moduleName name) = do+  env <- getEnv+  case M.lookup (fromMaybe currentModule moduleName, name) (types env) of+    Nothing -> throwError $ "Type variable " ++ show name ++ " is undefined"+    Just (k, _) -> return k+ data AnyUnifiable where   AnyUnifiable :: forall t. (Unifiable t) => t -> AnyUnifiable  data CheckState = CheckState { checkEnv :: Environment                              , checkNextVar :: Int-                             , checkModulePath :: ModulePath                              }  newtype Check a = Check { unCheck :: StateT CheckState (Either String) a }@@ -90,7 +115,7 @@  runCheck :: Check a -> Either String (a, Environment) runCheck c = do-  (a, s) <- flip runStateT (CheckState emptyEnvironment 0 global) $ unCheck c+  (a, s) <- flip runStateT (CheckState emptyEnvironment 0) $ unCheck c   return (a, checkEnv s)  guardWith :: (MonadError e m) => e -> Bool -> m ()@@ -100,14 +125,6 @@ rethrow :: (MonadError e m) => (e -> e) -> m a -> m a rethrow f = flip catchError $ \e -> throwError (f e) -withModule :: ProperName -> Check a -> Check a-withModule name act = do-  original <- checkModulePath `fmap` get-  modify $ \s -> s { checkModulePath = subModule (checkModulePath s) name }-  a <- act-  modify $ \s -> s { checkModulePath = original }-  return a- newtype Substitution = Substitution { runSubstitution :: forall t. (Unifiable t) => Unknown t -> t }  instance Monoid Substitution where@@ -117,21 +134,23 @@ data SubstState = SubstState { substSubst :: Substitution                              , substFutureEscapeChecks :: [AnyUnifiable] } -newtype Subst a = Subst { unSubst :: StateT SubstState Check a }-  deriving (Functor, Monad, Applicative, MonadPlus)+newtype SubstContext = SubstContext { substCurrentModule :: ModuleName } deriving (Show) +newtype Subst a = Subst { unSubst :: ReaderT SubstContext (StateT SubstState Check) a }+  deriving (Functor, Monad, Applicative, MonadPlus, MonadReader SubstContext)+ instance MonadState CheckState Subst where-  get = Subst . lift $ get-  put = Subst . lift . put+  get = Subst . lift . lift $ get+  put = Subst . lift . lift . put  deriving instance MonadError String Subst  liftCheck :: Check a -> Subst a-liftCheck = Subst . lift+liftCheck = Subst . lift . lift -runSubst :: (Unifiable a) => Subst a -> Check (a, Substitution, [AnyUnifiable])-runSubst subst = do-  (a, s) <- flip runStateT (SubstState mempty []) . unSubst $ subst+runSubst :: (Unifiable a) => SubstContext -> Subst a -> Check (a, Substitution, [AnyUnifiable])+runSubst context subst = do+  (a, s) <- flip runStateT (SubstState mempty []) . flip runReaderT context . unSubst $ subst   return (apply (substSubst s) a, substSubst s, substFutureEscapeChecks s)  substituteWith :: (Typeable t) => (Unknown t -> t) -> Substitution@@ -162,6 +181,13 @@   isUnknown :: t -> Maybe (Unknown t)   apply :: Substitution -> t -> t   unknowns :: t -> [Int]++instance (Unifiable a) => Unifiable [a] where+  unknown _ = error "not supported"+  (~~) = zipWithM_ (~~)+  isUnknown _ = error "not supported"+  apply s = map (apply s)+  unknowns = concatMap unknowns  occursCheck :: (Unifiable t) => Unknown s -> t -> Subst () occursCheck (Unknown u) t =
src/Language/PureScript/TypeChecker/Synonyms.hs view
@@ -27,22 +27,22 @@ import Control.Monad.Writer import Control.Monad.Error -buildTypeSubstitution :: Qualified ProperName -> Int -> Type -> Either String (Maybe Type)-buildTypeSubstitution name n = go n []+buildTypeSubstitution :: ModuleName -> Qualified ProperName -> Int -> Type -> Either String (Maybe Type)+buildTypeSubstitution moduleName name n = go n []   where   go :: Int -> [Type] -> Type -> Either String (Maybe Type)-  go 0 args (TypeConstructor ctor) | name == ctor = return (Just $ SaturatedTypeSynonym ctor args)+  go 0 args (TypeConstructor ctor) | qualify moduleName name == qualify moduleName ctor = return (Just $ SaturatedTypeSynonym ctor args)   go m _ (TypeConstructor ctor) | m > 0 && name == ctor = throwError $ "Partially applied type synonym " ++ show name   go m args (TypeApp f arg) = go (m - 1) (arg:args) f   go _ _ _ = return Nothing -saturateTypeSynonym :: (Data d) => Qualified ProperName -> Int -> d -> Either String d-saturateTypeSynonym name n = everywhereM' (mkM replace)+saturateTypeSynonym :: (Data d) => ModuleName -> Qualified ProperName -> Int -> d -> Either String d+saturateTypeSynonym moduleName name n = everywhereM' (mkM replace)   where-  replace t = fmap (fromMaybe t) $ buildTypeSubstitution name n t+  replace t = fmap (fromMaybe t) $ buildTypeSubstitution moduleName name n t -saturateAllTypeSynonyms :: (Data d) => [(Qualified ProperName, Int)] -> d -> Either String d-saturateAllTypeSynonyms syns d = foldM (\result (name, n) -> saturateTypeSynonym name n result) d syns+saturateAllTypeSynonyms :: (Data d) => ModuleName -> [(Qualified ProperName, Int)] -> d -> Either String d+saturateAllTypeSynonyms moduleName syns d = foldM (\result (name, n) -> saturateTypeSynonym moduleName name n result) d syns
src/Language/PureScript/TypeChecker/Types.hs view
@@ -15,11 +15,12 @@ {-# LANGUAGE DeriveDataTypeable, FlexibleContexts #-}  module Language.PureScript.TypeChecker.Types (-    typeOf+    typesOf ) where  import Data.List import Data.Maybe (fromMaybe)+import Data.Either (lefts, rights) import qualified Data.Data as D import Data.Generics        (mkT, something, everywhere, everywhereBut, mkQ, extQ)@@ -36,6 +37,7 @@  import Control.Monad.State import Control.Monad.Error+import Control.Monad.Reader  import Control.Applicative import Control.Arrow (Arrow(..))@@ -131,42 +133,58 @@     ret1 `unifyTypes` ret2   unifyTypes' (TypeVar v1) (TypeVar v2) | v1 == v2 = return ()   unifyTypes' (TypeConstructor c1) (TypeConstructor c2) = do-    modulePath <- checkModulePath `fmap` get-    guardWith ("Cannot unify " ++ show c1 ++ " with " ++ show c2 ++ ".") (qualify modulePath c1 == qualify modulePath c2)+    env <- getEnv+    moduleName <- substCurrentModule `fmap` ask+    guardWith ("Cannot unify " ++ show c1 ++ " with " ++ show c2 ++ ".") (typeConstructorsAreEqual env moduleName c1 c2)   unifyTypes' (TypeApp t3 t4) (TypeApp t5 t6) = do     t3 `unifyTypes` t5     t4 `unifyTypes` t6   unifyTypes' (Skolem s1) (Skolem s2) | s1 == s2 = return ()   unifyTypes' t3 t4 = throwError $ "Cannot unify " ++ prettyPrintType t3 ++ " with " ++ prettyPrintType t4 ++ "." -isFunction :: Value -> Bool-isFunction (Abs _ _) = True-isFunction (TypedValue untyped _) = isFunction untyped-isFunction _ = False+typeConstructorsAreEqual :: Environment -> ModuleName -> Qualified ProperName -> Qualified ProperName -> Bool+typeConstructorsAreEqual env moduleName c1 c2 =+  let+    c1' = qualify moduleName c1+    c2' = qualify moduleName c2+  in+    canonicalize env c1' == canonicalize env c2'+  where+  canonicalize :: Environment -> (ModuleName, ProperName) -> (ModuleName, ProperName)+  canonicalize _ key = case key `M.lookup` types env of+    Just (_, DataAlias mn' pn') -> (mn', pn')+    _ -> key -typeOf :: Maybe Ident -> Value -> Check Type-typeOf name val = do-  (ty, sub, checks) <- runSubst $ case name of-        Just ident | isFunction val ->-          case val of-            TypedValue value ty -> do-              kind <- liftCheck $ kindOf ty-              guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star-              ty' <- replaceAllTypeSynonyms ty-              modulePath <- checkModulePath <$> get-              bindNames (M.singleton (modulePath, ident) (ty, LocalVariable)) $ check value ty'-              return ty'-            _ -> do-              me <- fresh-              modulePath <- checkModulePath <$> get-              ty <- bindNames (M.singleton (modulePath, ident) (me, LocalVariable)) $ infer val-              ty ~~ me-              return ty-        _ -> infer val-  escapeCheck checks ty sub-  skolemEscapeCheck ty-  return $ varIfUnknown $ desaturateAllTypeSynonyms $ setifyAll ty+typesOf :: ModuleName -> [(Ident, Value)] -> Check [Type]+typesOf moduleName vals = do+  (tys, sub, checks) <- runSubst (SubstContext moduleName) $ do+    let es = map isTyped vals+        typed = lefts es+        untyped = rights es+        typedDict = map (\(ident, ty, _) -> (ident, ty)) typed+    untypedNames <- replicateM (length untyped) fresh+    let untypedDict = zip (map fst untyped) untypedNames+        dict = M.fromList (map (\(ident, ty) -> ((moduleName, ident), (ty, LocalVariable))) $ typedDict ++ untypedDict)+    tys <- forM es $ \e -> case e of+      Left (_, ty, val) -> do+        kind <- liftCheck $ kindOf moduleName ty+        guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star+        ty' <- replaceAllTypeSynonyms ty+        bindNames dict $ check val ty'+        return ty'+      Right (ident, val) -> do+        ty <- bindNames dict $ infer val+        ty ~~ fromMaybe (error "name not found in dictionary") (lookup ident untypedDict)+        return ty+    return tys+  forM tys $ flip (escapeCheck checks) sub+  forM tys $ skolemEscapeCheck+  return $ map (varIfUnknown . desaturateAllTypeSynonyms . setifyAll) tys +isTyped :: (Ident, Value) -> Either (Ident, Type, Value) (Ident, Value)+isTyped (name, TypedValue value ty) = Left (name, ty, value)+isTyped (name, value) = Right (name, value)+ escapeCheck :: [AnyUnifiable] -> Type -> Substitution -> Check () escapeCheck checks ty sub =   let@@ -234,11 +252,12 @@   ru <- fresh   return $ replaceRowVars ident ru . replaceTypeVars ident tu $ ty -replaceAllTypeSynonyms :: (Functor m, MonadState CheckState m, MonadError String m) => (D.Data d) => d -> m d+replaceAllTypeSynonyms :: (Functor m, MonadState CheckState m, MonadReader SubstContext m, MonadError String m) => (D.Data d) => d -> m d replaceAllTypeSynonyms d = do   env <- getEnv-  let syns = map (\((path, name), (args, _)) -> (Qualified path name, length args)) . M.toList $ typeSynonyms env-  either throwError return $ saturateAllTypeSynonyms syns d+  moduleName <- substCurrentModule <$> ask+  let syns = map (\((path, name), (args, _)) -> (Qualified (Just path) name, length args)) . M.toList $ typeSynonyms env+  either throwError return $ saturateAllTypeSynonyms moduleName syns d  desaturateAllTypeSynonyms :: (D.Data d) => d -> d desaturateAllTypeSynonyms = everywhere (mkT replaceSaturatedTypeSynonym)@@ -249,8 +268,8 @@ expandTypeSynonym :: Qualified ProperName -> [Type] -> Subst Type expandTypeSynonym name args = do   env <- getEnv-  modulePath <- checkModulePath `fmap` get-  case M.lookup (qualify modulePath name) (typeSynonyms env) of+  moduleName <- substCurrentModule `fmap` ask+  case M.lookup (qualify moduleName name) (typeSynonyms env) of     Just (synArgs, body) -> return $ replaceAllTypeVars (zip synArgs args) body     Nothing -> error "Type synonym was not defined" @@ -308,7 +327,8 @@     Just ty -> return ty infer' (Abs args ret) = do   ts <- replicateM (length args) fresh-  bindLocalVariables (zip args ts) $ do+  moduleName <- substCurrentModule <$> ask+  bindLocalVariables moduleName (zip args ts) $ do     body <- infer' ret     return $ Function ts body infer' app@(App _ _) = do@@ -318,7 +338,8 @@   checkFunctionApplications ft argss ret   return ret infer' (Var var) = do-  ty <- lookupVariable var+  moduleName <- substCurrentModule <$> ask+  ty <- lookupVariable moduleName var   replaceAllTypeSynonyms ty infer' (Block ss) = do   ret <- fresh@@ -327,8 +348,8 @@   return ret infer' (Constructor c) = do   env <- getEnv-  modulePath <- checkModulePath `fmap` get-  case M.lookup (qualify modulePath c) (dataConstructors env) of+  moduleName <- substCurrentModule `fmap` ask+  case M.lookup (qualify moduleName c) (dataConstructors env) of     Nothing -> throwError $ "Constructor " ++ show c ++ " is undefined"     Just ty -> replaceAllTypeSynonyms ty infer' (Case vals binders) = do@@ -343,7 +364,8 @@   t2 ~~ t3   return t2 infer' (TypedValue val ty) = do-  kind <- liftCheck $ kindOf ty+  moduleName <- substCurrentModule <$> ask+  kind <- liftCheck $ kindOf moduleName ty   guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star   ty' <- replaceAllTypeSynonyms ty   check val ty'@@ -440,16 +462,16 @@ inferBinder val (VarBinder name) = return $ M.singleton name val inferBinder val (NullaryBinder ctor) = do   env <- getEnv-  modulePath <- checkModulePath <$> get-  case M.lookup (qualify modulePath ctor) (dataConstructors env) of+  moduleName <- substCurrentModule <$> ask+  case M.lookup (qualify moduleName ctor) (dataConstructors env) of     Just ty -> do       ty `subsumes` val       return M.empty     _ -> throwError $ "Constructor " ++ show ctor ++ " is not defined" inferBinder val (UnaryBinder ctor binder) = do   env <- getEnv-  modulePath <- checkModulePath <$> get-  case M.lookup (qualify modulePath ctor) (dataConstructors env) of+  moduleName <- substCurrentModule <$> ask+  case M.lookup (qualify moduleName ctor) (dataConstructors env) of     Just ty -> do       fn <- replaceAllVarsWithUnknowns ty       case fn of@@ -490,8 +512,9 @@ checkBinders :: [Type] -> Type -> [([Binder], Maybe Guard, Value)] -> Subst () checkBinders _ _ [] = return () checkBinders nvals ret ((binders, grd, val):bs) = do+  moduleName <- substCurrentModule <$> ask   m1 <- M.unions <$> zipWithM inferBinder nvals binders-  bindLocalVariables (M.toList m1) $ do+  bindLocalVariables moduleName (M.toList m1) $ do     check val ret     case grd of       Nothing -> return ()@@ -501,8 +524,8 @@ assignVariable :: Ident -> Subst () assignVariable name = do   env <- checkEnv <$> get-  modulePath <- checkModulePath <$> get-  case M.lookup (modulePath, name) (names env) of+  moduleName <- substCurrentModule <$> ask+  case M.lookup (moduleName, name) (names env) of     Just (_, LocalVariable) -> throwError $ "Variable with name " ++ show name ++ " already exists."     _ -> return () @@ -525,16 +548,18 @@   allCodePathsReturn <- checkIfStatement mass ret ifst   return (allCodePathsReturn, mass) checkStatement mass ret (For ident start end inner) = do+  moduleName <- substCurrentModule <$> ask   assignVariable ident   check start Number   check end Number-  (allCodePathsReturn, _) <- bindLocalVariables [(ident, Number)] $ checkBlock mass ret inner+  (allCodePathsReturn, _) <- bindLocalVariables moduleName [(ident, Number)] $ checkBlock mass ret inner   return (allCodePathsReturn, mass) checkStatement mass ret (ForEach ident vals inner) = do+  moduleName <- substCurrentModule <$> ask   assignVariable ident   val <- fresh   check vals (Array val)-  (allCodePathsReturn, _) <- bindLocalVariables [(ident, val)] $ checkBlock mass ret inner+  (allCodePathsReturn, _) <- bindLocalVariables moduleName [(ident, val)] $ checkBlock mass ret inner   guardWith "Cannot return from within a foreach block" $ not allCodePathsReturn   return (False, mass) checkStatement mass _ (ValueStatement val) = do@@ -562,8 +587,9 @@ checkBlock :: M.Map Ident Type -> Type -> [Statement] -> Subst (Bool, M.Map Ident Type) checkBlock mass _ [] = return (False, mass) checkBlock mass ret (s:ss) = do+  moduleName <- substCurrentModule <$> ask   (b1, mass1) <- checkStatement mass ret s-  bindLocalVariables (M.toList mass1) $ case (b1, ss) of+  bindLocalVariables moduleName (M.toList mass1) $ case (b1, ss) of     (True, []) -> return (True, mass1)     (True, _) -> throwError "Unreachable code"     (False, ss') -> checkBlock mass1 ret ss'@@ -602,18 +628,21 @@ check' (ArrayLiteral vals) (Array ty) = forM_ vals (\val -> check val ty) check' (Indexer index vals) ty = check index Number >> check vals (Array ty) check' (Abs args ret) (Function argTys retTy) = do+  moduleName <- substCurrentModule <$> ask   guardWith "Incorrect number of function arguments" (length args == length argTys)-  bindLocalVariables (zip args argTys) $ check ret retTy+  bindLocalVariables moduleName (zip args argTys) $ check ret retTy check' app@(App _ _) ret = do   let (f, argss) = unfoldApplication app   ft <- infer f   checkFunctionApplications ft argss ret check' (Var var) ty = do-  ty1 <- lookupVariable var+  moduleName <- substCurrentModule <$> ask+  ty1 <- lookupVariable moduleName var   repl <- replaceAllTypeSynonyms ty1   repl `subsumes` ty check' (TypedValue val ty1) ty2 = do-  kind <- liftCheck $ kindOf ty1+  moduleName <- substCurrentModule <$> ask+  kind <- liftCheck $ kindOf moduleName ty1   guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star   ty1 `subsumes` ty2   check val ty1@@ -643,8 +672,8 @@   guardWith "Block is missing a return statement" allCodePathsReturn check' (Constructor c) ty = do   env <- getEnv-  modulePath <- checkModulePath <$> get-  case M.lookup (qualify modulePath c) (dataConstructors env) of+  moduleName <- substCurrentModule <$> ask+  case M.lookup (qualify moduleName c) (dataConstructors env) of     Nothing -> throwError $ "Constructor " ++ show c ++ " is undefined"     Just ty1 -> do       repl <- replaceAllTypeSynonyms ty1
+ src/Language/PureScript/TypeDeclarations.hs view
@@ -0,0 +1,35 @@+-----------------------------------------------------------------------------+--+-- Module      :  Language.PureScript.TypeDeclarations+-- Copyright   :  (c) Phil Freeman 2013+-- License     :  MIT+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>+-- Stability   :  experimental+-- Portability :+--+-- |+--+-----------------------------------------------------------------------------++module Language.PureScript.TypeDeclarations (+    desugarTypeDeclarations,+    desugarTypeDeclarationsModule+) where++import Control.Applicative+import Control.Monad.Error.Class+import Control.Monad (forM)++import Language.PureScript.Declarations+import Language.PureScript.Values++desugarTypeDeclarationsModule :: [Module] -> Either String [Module]+desugarTypeDeclarationsModule ms = forM ms $ \(Module name ds) -> Module name <$> desugarTypeDeclarations ds++desugarTypeDeclarations :: [Declaration] -> Either String [Declaration]+desugarTypeDeclarations (TypeDeclaration name ty : ValueDeclaration name' [] Nothing val : rest) | name == name' =+  desugarTypeDeclarations (ValueDeclaration name [] Nothing (TypedValue val ty) : rest)+desugarTypeDeclarations (TypeDeclaration name _ : _) = throwError $ "Orphan type declaration for " ++ show name+desugarTypeDeclarations (d:ds) = (:) d <$> desugarTypeDeclarations ds+desugarTypeDeclarations [] = return []
src/Main.hs view
@@ -22,21 +22,21 @@ import qualified System.IO.UTF8 as U import Text.Parsec (ParseError) -readInput :: Maybe [FilePath] -> IO (Either ParseError [P.Declaration])-readInput Nothing = getContents >>= return . P.runIndentParser P.parseDeclarations+readInput :: Maybe [FilePath] -> IO (Either ParseError [P.Module])+readInput Nothing = getContents >>= return . P.runIndentParser P.parseModules readInput (Just input) = fmap (fmap concat . sequence) $ forM input $ \inputFile -> do   text <- U.readFile inputFile-  return $ P.runIndentParser P.parseDeclarations text+  return $ P.runIndentParser P.parseModules text  compile :: Maybe [FilePath] -> Maybe FilePath -> Maybe FilePath -> IO () compile input output externs = do-  asts <- readInput input-  case asts of+  modules <- readInput input+  case modules of     Left err -> do       U.print err       exitFailure-    Right decls ->-      case P.compile decls of+    Right ms ->+      case P.compile ms of         Left err -> do           U.putStrLn err           exitFailure
tests/Main.hs view
@@ -27,12 +27,12 @@  compile :: FilePath -> IO (Either String P.Environment) compile inputFile = do-  ast <- P.runIndentParser P.parseDeclarations <$> U.readFile inputFile-  case ast of+  modules <- P.runIndentParser P.parseModules <$> U.readFile inputFile+  case modules of     Left parseError -> do       return (Left $ show parseError)-    Right decls -> do-      case P.compile decls of+    Right ms -> do+      case P.compile ms of         Left typeError -> do           return (Left typeError)         Right (_, _, env) -> do