summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPhilFreeman <>2013-11-10 22:40:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2013-11-10 22:40:00 (GMT)
commit4160746b9f7ec6d435b29e87318534ba17d9d9fb (patch)
tree36d16e867c17168aae7a5c4d49958da3af9469e6
parent51e8b07e76bcbd0e48708d37f15097c9175e85a5 (diff)
version 0.1.80.1.8
-rw-r--r--purescript.cabal2
-rw-r--r--src/Language/PureScript/CodeGen/Externs.hs29
-rw-r--r--src/Language/PureScript/CodeGen/JS.hs170
-rw-r--r--src/Language/PureScript/CodeGen/JS/AST.hs8
-rw-r--r--src/Language/PureScript/Declarations.hs9
-rw-r--r--src/Language/PureScript/Names.hs22
-rw-r--r--src/Language/PureScript/Optimize.hs9
-rw-r--r--src/Language/PureScript/Parser/Common.hs15
-rw-r--r--src/Language/PureScript/Parser/Declarations.hs14
-rw-r--r--src/Language/PureScript/Parser/Types.hs2
-rw-r--r--src/Language/PureScript/Parser/Values.hs28
-rw-r--r--src/Language/PureScript/Pretty/JS.hs10
-rw-r--r--src/Language/PureScript/Pretty/Types.hs4
-rw-r--r--src/Language/PureScript/Pretty/Values.hs6
-rw-r--r--src/Language/PureScript/TypeChecker.hs52
-rw-r--r--src/Language/PureScript/TypeChecker/Kinds.hs71
-rw-r--r--src/Language/PureScript/TypeChecker/Monad.hs40
-rw-r--r--src/Language/PureScript/TypeChecker/Synonyms.hs9
-rw-r--r--src/Language/PureScript/TypeChecker/Types.hs57
-rw-r--r--src/Language/PureScript/Types.hs5
-rw-r--r--src/Language/PureScript/Values.hs8
-rw-r--r--src/Main.hs4
22 files changed, 356 insertions, 218 deletions
diff --git a/purescript.cabal b/purescript.cabal
index 9be84d0..86e7553 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -1,5 +1,5 @@
name: purescript
-version: 0.1.7
+version: 0.1.8
cabal-version: >=1.8
build-type: Simple
license: MIT
diff --git a/src/Language/PureScript/CodeGen/Externs.hs b/src/Language/PureScript/CodeGen/Externs.hs
index d2ea0ff..17a150d 100644
--- a/src/Language/PureScript/CodeGen/Externs.hs
+++ b/src/Language/PureScript/CodeGen/Externs.hs
@@ -17,19 +17,26 @@ module Language.PureScript.CodeGen.Externs (
) where
import Data.List (intercalate)
+import Data.Maybe (mapMaybe)
import qualified Data.Map as M
import Language.PureScript.Declarations
import Language.PureScript.TypeChecker.Monad
import Language.PureScript.Pretty
+import Language.PureScript.Names
-externToPs :: Environment -> Declaration -> Maybe String
-externToPs env (ValueDeclaration name _) = do
- (ty, _) <- M.lookup name $ names env
- return $ "foreign import " ++ show name ++ " :: " ++ prettyPrintPolyType ty
-externToPs env (ExternMemberDeclaration member name ty) =
- return $ "foreign import member " ++ show member ++ " " ++ show name ++ " :: " ++ prettyPrintPolyType ty
-externToPs env (ExternDataDeclaration name kind) =
- return $ "foreign import data " ++ name ++ " :: " ++ prettyPrintKind kind
-externToPs env (TypeSynonymDeclaration name args ty) =
- return $ "type " ++ name ++ " " ++ unwords args ++ " = " ++ prettyPrintType ty
-externToPs _ _ = Nothing
+externToPs :: Int -> ModulePath -> Environment -> Declaration -> Maybe String
+externToPs indent path env (ValueDeclaration name _) = do
+ (ty, _) <- M.lookup (path, name) $ names env
+ return $ replicate indent ' ' ++ "foreign import " ++ show name ++ " :: " ++ prettyPrintPolyType ty
+externToPs indent path env (DataDeclaration name _ _) = do
+ (kind, _) <- M.lookup (path, name) $ types env
+ return $ replicate indent ' ' ++ "foreign import data " ++ show name ++ " :: " ++ prettyPrintKind kind
+externToPs indent path env (ExternMemberDeclaration member name ty) =
+ return $ replicate indent ' ' ++ "foreign import member " ++ show member ++ " " ++ show name ++ " :: " ++ prettyPrintPolyType ty
+externToPs indent path env (ExternDataDeclaration name kind) =
+ return $ replicate indent ' ' ++ "foreign import data " ++ show name ++ " :: " ++ prettyPrintKind kind
+externToPs indent path env (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
diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs
index 1a25e13..6fa5be8 100644
--- a/src/Language/PureScript/CodeGen/JS.hs
+++ b/src/Language/PureScript/CodeGen/JS.hs
@@ -18,7 +18,7 @@ module Language.PureScript.CodeGen.JS (
) where
import Data.Char
-import Data.Maybe (fromMaybe)
+import Data.Maybe (fromMaybe, mapMaybe)
import Data.List (intercalate)
import qualified Control.Arrow as A
import Control.Arrow ((<+>), second)
@@ -33,76 +33,100 @@ import Language.PureScript.Pretty.Common
import Language.PureScript.CodeGen.Monad
import Language.PureScript.CodeGen.JS.AST as AST
-declToJs :: Declaration -> Maybe [JS]
-declToJs (ValueDeclaration ident (Abs args ret)) = Just [JSFunction (Just ident) args (JSBlock [JSReturn (valueToJs ret)])]
-declToJs (ValueDeclaration ident val) = Just [JSVariableIntroduction ident (valueToJs val)]
-declToJs (ExternMemberDeclaration member ident _) =
- Just [JSFunction (Just ident) [Ident "value"] (JSBlock [JSReturn (JSAccessor member (JSVar (Ident "value")))])]
-declToJs (DataDeclaration _ _ ctors) =
- Just $ flip map ctors $ \(ctor, maybeTy) ->
- case maybeTy of
- Nothing -> JSVariableIntroduction (Ident ctor) (JSObjectLiteral [ ("ctor", JSStringLiteral ctor) ])
- Just _ -> JSFunction (Just (Ident ctor)) [Ident "value"]
- (JSBlock [JSReturn
- (JSObjectLiteral [ ("ctor", JSStringLiteral ctor)
- , ("value", JSVar (Ident "value")) ])])
-declToJs _ = Nothing
+declToJs :: Maybe Ident -> ModulePath -> Declaration -> Maybe [JS]
+declToJs mod mp (ValueDeclaration ident (Abs args ret)) =
+ Just $ JSFunction (Just ident) args (JSBlock [JSReturn (valueToJs mp ret)]) :
+ maybe [] (return . setProperty (show ident) (JSVar ident)) mod
+declToJs mod mp (ValueDeclaration ident val) =
+ Just $ JSVariableIntroduction ident (Just (valueToJs mp val)) :
+ maybe [] (return . setProperty (show ident) (JSVar ident)) mod
+declToJs mod _ (ExternMemberDeclaration member ident _) =
+ Just $ JSFunction (Just ident) [Ident "value"] (JSBlock [JSReturn (JSAccessor member (JSVar (Ident "value")))]) :
+ maybe [] (return . setProperty (show ident) (JSVar ident)) mod
+declToJs mod 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))) ]))
+ Just _ -> JSFunction (Just (Ident ctor)) [Ident "value"]
+ (JSBlock [JSReturn
+ (JSObjectLiteral [ ("ctor", JSStringLiteral (show (Qualified mp pn)))
+ , ("value", JSVar (Ident "value")) ])])
+ in ctorJs : maybe [] (return . setProperty ctor (JSVar (Ident ctor))) mod
+declToJs mod mp (ModuleDeclaration pn@(ProperName name) decls) =
+ Just $ [ JSVariableIntroduction (Ident name) Nothing
+ , JSApp (JSFunction Nothing [Ident name]
+ (JSBlock (concat $ mapMaybe (declToJs (Just (Ident name)) (subModule mp pn)) decls)))
+ [JSAssignment (JSAssignVariable (Ident name) )
+ (JSBinary Or (JSVar (Ident name)) (JSObjectLiteral []))]] ++
+ maybe [] (return . setProperty name (JSVar (Ident name))) mod
+declToJs _ _ _ = Nothing
-valueToJs :: Value -> JS
-valueToJs (NumericLiteral n) = JSNumericLiteral n
-valueToJs (StringLiteral s) = JSStringLiteral s
-valueToJs (BooleanLiteral b) = JSBooleanLiteral b
-valueToJs (ArrayLiteral xs) = JSArrayLiteral (map valueToJs xs)
-valueToJs (ObjectLiteral ps) = JSObjectLiteral (map (second valueToJs) ps)
-valueToJs (ObjectUpdate o ps) = JSApp (JSAccessor "extend" (JSVar (Ident "Object"))) [ valueToJs o, JSObjectLiteral (map (second valueToJs) ps)]
-valueToJs (Constructor name) = JSVar (Ident name)
-valueToJs (Block sts) = JSApp (JSFunction Nothing [] (JSBlock (map statementToJs sts))) []
-valueToJs (Case value binders) = runGen (bindersToJs binders (valueToJs value))
-valueToJs (IfThenElse cond th el) = JSConditional (valueToJs cond) (valueToJs th) (valueToJs el)
-valueToJs (Accessor prop val) = JSAccessor prop (valueToJs val)
-valueToJs (Indexer index val) = JSIndexer (valueToJs index) (valueToJs val)
-valueToJs (App val args) = JSApp (valueToJs val) (map valueToJs args)
-valueToJs (Abs args val) = JSFunction Nothing args (JSBlock [JSReturn (valueToJs val)])
-valueToJs (Unary op val) = JSUnary op (valueToJs val)
-valueToJs (Binary op v1 v2) = JSBinary op (valueToJs v1) (valueToJs v2)
-valueToJs (Var ident) = JSVar ident
-valueToJs (TypedValue val _) = valueToJs val
+setProperty :: String -> JS -> Ident -> JS
+setProperty prop val mod = JSAssignment (JSAssignProperty prop (JSAssignVariable mod)) val
-bindersToJs :: [(Binder, Value)] -> JS -> Gen JS
-bindersToJs binders val = do
+valueToJs :: ModulePath -> Value -> JS
+valueToJs _ (NumericLiteral n) = JSNumericLiteral n
+valueToJs _ (StringLiteral s) = JSStringLiteral s
+valueToJs _ (BooleanLiteral b) = JSBooleanLiteral b
+valueToJs m (ArrayLiteral xs) = JSArrayLiteral (map (valueToJs m) xs)
+valueToJs m (ObjectLiteral ps) = JSObjectLiteral (map (second (valueToJs m)) ps)
+valueToJs m (ObjectUpdate o ps) = JSApp (JSAccessor "extend" (JSVar (Ident "Object"))) [ valueToJs m o, JSObjectLiteral (map (second (valueToJs m)) ps)]
+valueToJs m (Constructor name) = qualifiedToJS runProperName name
+valueToJs m (Block sts) = JSApp (JSFunction Nothing [] (JSBlock (map (statementToJs m) sts))) []
+valueToJs m (Case value binders) = runGen (bindersToJs m binders (valueToJs m value))
+valueToJs m (IfThenElse cond th el) = JSConditional (valueToJs m cond) (valueToJs m th) (valueToJs m el)
+valueToJs m (Accessor prop val) = JSAccessor prop (valueToJs m val)
+valueToJs m (Indexer index val) = JSIndexer (valueToJs m index) (valueToJs m val)
+valueToJs m (App val args) = JSApp (valueToJs m val) (map (valueToJs m) args)
+valueToJs m (Abs args val) = JSFunction Nothing args (JSBlock [JSReturn (valueToJs m val)])
+valueToJs m (Unary op val) = JSUnary op (valueToJs m val)
+valueToJs m (Binary op v1 v2) = JSBinary op (valueToJs m v1) (valueToJs m v2)
+valueToJs m (Var ident) = qualifiedToJS identToJs ident
+valueToJs m (TypedValue val _) = valueToJs m val
+
+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)
+
+bindersToJs :: ModulePath -> [(Binder, Value)] -> JS -> Gen JS
+bindersToJs m binders val = do
valName <- fresh
- jss <- forM binders $ \(binder, result) -> binderToJs valName [JSReturn (valueToJs result)] binder
+ jss <- forM binders $ \(binder, result) -> binderToJs m valName [JSReturn (valueToJs m result)] binder
return $ JSApp (JSFunction Nothing [Ident valName] (JSBlock (concat jss ++ [JSThrow (JSStringLiteral "Failed pattern match")])))
[val]
-binderToJs :: String -> [JS] -> Binder -> Gen [JS]
-binderToJs varName done NullBinder = return done
-binderToJs varName done (StringBinder str) =
+binderToJs :: ModulePath -> String -> [JS] -> Binder -> Gen [JS]
+binderToJs _ varName done NullBinder = return done
+binderToJs _ varName done (StringBinder str) =
return [JSIfElse (JSBinary EqualTo (JSVar (Ident varName)) (JSStringLiteral str)) (JSBlock done) Nothing]
-binderToJs varName done (NumberBinder num) =
+binderToJs _ varName done (NumberBinder num) =
return [JSIfElse (JSBinary EqualTo (JSVar (Ident varName)) (JSNumericLiteral num)) (JSBlock done) Nothing]
-binderToJs varName done (BooleanBinder True) =
+binderToJs _ varName done (BooleanBinder True) =
return [JSIfElse (JSVar (Ident varName)) (JSBlock done) Nothing]
-binderToJs varName done (BooleanBinder False) =
+binderToJs _ varName done (BooleanBinder False) =
return [JSIfElse (JSUnary Not (JSVar (Ident varName))) (JSBlock done) Nothing]
-binderToJs varName done (VarBinder ident) =
- return (JSVariableIntroduction ident (JSVar (Ident varName)) : done)
-binderToJs varName done (NullaryBinder ctor) =
- return [JSIfElse (JSBinary EqualTo (JSAccessor "ctor" (JSVar (Ident varName))) (JSStringLiteral ctor)) (JSBlock done) Nothing]
-binderToJs varName done (UnaryBinder ctor b) = do
+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]
+binderToJs m varName done (UnaryBinder ctor b) = do
value <- fresh
- js <- binderToJs value done b
- return [JSIfElse (JSBinary EqualTo (JSAccessor "ctor" (JSVar (Ident varName))) (JSStringLiteral ctor)) (JSBlock (JSVariableIntroduction (Ident value) (JSAccessor "value" (JSVar (Ident varName))) : js)) Nothing]
-binderToJs varName done (ObjectBinder bs) = go done bs
+ js <- binderToJs m 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]
+binderToJs m varName done (ObjectBinder bs) = go done bs
where
go :: [JS] -> [(String, Binder)] -> Gen [JS]
go done [] = return done
go done ((prop, binder):bs) = do
propVar <- fresh
done' <- go done bs
- js <- binderToJs propVar done' binder
- return (JSVariableIntroduction (Ident propVar) (JSAccessor prop (JSVar (Ident varName))) : js)
-binderToJs varName done (ArrayBinder bs rest) = do
+ js <- binderToJs m propVar done' binder
+ return (JSVariableIntroduction (Ident propVar) (Just (JSAccessor prop (JSVar (Ident varName)))) : js)
+binderToJs m varName done (ArrayBinder bs rest) = do
js <- go done rest 0 bs
return [JSIfElse (JSBinary cmp (JSAccessor "length" (JSVar (Ident varName))) (JSNumericLiteral (Left (fromIntegral $ length bs)))) (JSBlock js) Nothing]
where
@@ -112,31 +136,31 @@ binderToJs varName done (ArrayBinder bs rest) = do
go done Nothing _ [] = return done
go done (Just binder) index [] = do
restVar <- fresh
- js <- binderToJs restVar done binder
- return (JSVariableIntroduction (Ident restVar) (JSApp (JSAccessor "slice" (JSVar (Ident varName))) [JSNumericLiteral (Left index)]) : js)
+ js <- binderToJs m restVar done binder
+ return (JSVariableIntroduction (Ident restVar) (Just (JSApp (JSAccessor "slice" (JSVar (Ident varName))) [JSNumericLiteral (Left index)])) : js)
go done rest index (binder:bs) = do
elVar <- fresh
done' <- go done rest (index + 1) bs
- js <- binderToJs elVar done' binder
- return (JSVariableIntroduction (Ident elVar) (JSIndexer (JSNumericLiteral (Left index)) (JSVar (Ident varName))) : js)
-binderToJs varName done (NamedBinder ident binder) = do
- js <- binderToJs varName done binder
- return (JSVariableIntroduction ident (JSVar (Ident varName)) : js)
-binderToJs varName done (GuardedBinder cond binder) = binderToJs varName done' binder
+ js <- binderToJs m elVar done' binder
+ return (JSVariableIntroduction (Ident elVar) (Just (JSIndexer (JSNumericLiteral (Left index)) (JSVar (Ident varName)))) : js)
+binderToJs m varName done (NamedBinder ident binder) = do
+ js <- binderToJs m varName done binder
+ return (JSVariableIntroduction ident (Just (JSVar (Ident varName))) : js)
+binderToJs m varName done (GuardedBinder cond binder) = binderToJs m varName done' binder
where
- done' = [JSIfElse (valueToJs cond) (JSBlock done) Nothing]
+ done' = [JSIfElse (valueToJs m cond) (JSBlock done) Nothing]
-statementToJs :: Statement -> JS
-statementToJs (VariableIntroduction ident value) = JSVariableIntroduction ident (valueToJs value)
-statementToJs (Assignment target value) = JSAssignment target (valueToJs value)
-statementToJs (While cond sts) = JSWhile (valueToJs cond) (JSBlock (map statementToJs sts))
-statementToJs (For ident start end sts) = JSFor ident (valueToJs start) (valueToJs end) (JSBlock (map statementToJs sts))
-statementToJs (ForEach ident arr sts) = JSApp (JSAccessor "forEach" (valueToJs arr)) [JSFunction Nothing [ident] (JSBlock (map statementToJs sts))]
-statementToJs (If ifst) = ifToJs ifst
+statementToJs :: ModulePath -> Statement -> JS
+statementToJs m (VariableIntroduction ident value) = JSVariableIntroduction ident (Just (valueToJs m value))
+statementToJs m (Assignment target value) = JSAssignment (JSAssignVariable target) (valueToJs m value)
+statementToJs m (While cond sts) = JSWhile (valueToJs m cond) (JSBlock (map (statementToJs m) sts))
+statementToJs m (For ident start end sts) = JSFor ident (valueToJs m start) (valueToJs m end) (JSBlock (map (statementToJs m) sts))
+statementToJs m (ForEach ident arr sts) = JSApp (JSAccessor "forEach" (valueToJs m arr)) [JSFunction Nothing [ident] (JSBlock (map (statementToJs m) sts))]
+statementToJs m (If ifst) = ifToJs ifst
where
ifToJs :: IfStatement -> JS
- ifToJs (IfStatement cond thens elses) = JSIfElse (valueToJs cond) (JSBlock (map statementToJs thens)) (fmap elseToJs elses)
+ ifToJs (IfStatement cond thens elses) = JSIfElse (valueToJs m cond) (JSBlock (map (statementToJs m) thens)) (fmap elseToJs elses)
elseToJs :: ElseStatement -> JS
- elseToJs (Else sts) = JSBlock (map statementToJs sts)
+ elseToJs (Else sts) = JSBlock (map (statementToJs m) sts)
elseToJs (ElseIf ifst) = ifToJs ifst
-statementToJs (Return value) = JSReturn (valueToJs value)
+statementToJs m (Return value) = JSReturn (valueToJs m value)
diff --git a/src/Language/PureScript/CodeGen/JS/AST.hs b/src/Language/PureScript/CodeGen/JS/AST.hs
index e7b342d..59d34b5 100644
--- a/src/Language/PureScript/CodeGen/JS/AST.hs
+++ b/src/Language/PureScript/CodeGen/JS/AST.hs
@@ -36,10 +36,14 @@ data JS
| JSVar Ident
| JSConditional JS JS JS
| JSBlock [JS]
- | JSVariableIntroduction Ident JS
- | JSAssignment Ident JS
+ | JSVariableIntroduction Ident (Maybe JS)
+ | JSAssignment JSAssignment JS
| JSWhile JS JS
| JSFor Ident JS JS JS
| JSIfElse JS JS (Maybe JS)
| JSReturn JS
| JSThrow JS deriving (Show, Data, Typeable)
+
+data JSAssignment
+ = JSAssignVariable Ident
+ | JSAssignProperty String JSAssignment deriving (Show, Data, Typeable)
diff --git a/src/Language/PureScript/Declarations.hs b/src/Language/PureScript/Declarations.hs
index 23c57b0..7632a85 100644
--- a/src/Language/PureScript/Declarations.hs
+++ b/src/Language/PureScript/Declarations.hs
@@ -30,11 +30,12 @@ data Associativity = Infixl | Infixr deriving (Show, D.Data, D.Typeable)
data Fixity = Fixity Associativity Precedence deriving (Show, D.Data, D.Typeable)
data Declaration
- = DataDeclaration String [String] [(String, Maybe Type)]
- | TypeSynonymDeclaration String [String] Type
+ = DataDeclaration ProperName [String] [(ProperName, Maybe Type)]
+ | TypeSynonymDeclaration ProperName [String] Type
| TypeDeclaration Ident PolyType
| ValueDeclaration Ident Value
| ExternDeclaration Ident PolyType
| ExternMemberDeclaration String Ident PolyType
- | ExternDataDeclaration String Kind
- | FixityDeclaration Fixity String deriving (Show, D.Data, D.Typeable)
+ | ExternDataDeclaration ProperName Kind
+ | FixityDeclaration Fixity String
+ | ModuleDeclaration ProperName [Declaration] deriving (Show, D.Data, D.Typeable)
diff --git a/src/Language/PureScript/Names.hs b/src/Language/PureScript/Names.hs
index 6b73e01..22f8193 100644
--- a/src/Language/PureScript/Names.hs
+++ b/src/Language/PureScript/Names.hs
@@ -17,6 +17,7 @@
module Language.PureScript.Names where
import Data.Data
+import Data.List (intercalate)
data Ident = Ident String | Op String deriving (Eq, Ord, Data, Typeable)
@@ -24,3 +25,24 @@ instance Show Ident where
show (Ident s) = s
show (Op op) = '(':op ++ ")"
+newtype ProperName = ProperName { runProperName :: String } deriving (Eq, Ord, Data, Typeable)
+
+instance Show ProperName where
+ show = runProperName
+
+data ModulePath = ModulePath [ProperName] deriving (Show, Eq, Ord, Data, Typeable)
+
+subModule :: ModulePath -> ProperName -> ModulePath
+subModule (ModulePath mp) name = ModulePath (mp ++ [name])
+
+global :: ModulePath
+global = ModulePath []
+
+data Qualified a = Qualified ModulePath 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)
diff --git a/src/Language/PureScript/Optimize.hs b/src/Language/PureScript/Optimize.hs
index ac45274..c14034c 100644
--- a/src/Language/PureScript/Optimize.hs
+++ b/src/Language/PureScript/Optimize.hs
@@ -35,7 +35,7 @@ isReassigned :: (Data d) => Ident -> d -> Bool
isReassigned var1 = everything (||) (mkQ False check)
where
check :: JS -> Bool
- check (JSAssignment var2 _) | var1 == var2 = True
+ check (JSAssignment (JSAssignVariable var2) _) | var1 == var2 = True
check _ = False
isUsed :: (Data d) => Ident -> d -> Bool
@@ -43,8 +43,11 @@ isUsed var1 = everything (||) (mkQ False check)
where
check :: JS -> Bool
check (JSVar var2) | var1 == var2 = True
- check (JSAssignment var2 _) | var1 == var2 = True
+ check (JSAssignment target _) | var1 == targetVariable target = True
check _ = False
+ targetVariable :: JSAssignment -> Ident
+ targetVariable (JSAssignVariable var) = var
+ targetVariable (JSAssignProperty _ tgt) = targetVariable tgt
shouldInline :: JS -> Bool
shouldInline (JSVar _) = True
@@ -63,7 +66,7 @@ inlineVariables = everywhere (mkT removeFromBlock)
removeFromBlock js = js
go :: [JS] -> [JS]
go [] = []
- go (JSVariableIntroduction var js : sts) | shouldInline js && not (isReassigned var sts) = go (replaceIdent var js sts)
+ go (JSVariableIntroduction var (Just js) : sts) | shouldInline js && not (isReassigned var sts) = go (replaceIdent var js sts)
go (s:sts) = s : go sts
removeUnusedVariables :: JS -> JS
diff --git a/src/Language/PureScript/Parser/Common.hs b/src/Language/PureScript/Parser/Common.hs
index 729b9bb..fc359d3 100644
--- a/src/Language/PureScript/Parser/Common.hs
+++ b/src/Language/PureScript/Parser/Common.hs
@@ -72,7 +72,8 @@ reservedNames = [ "case"
, "String"
, "Boolean"
, "infixl"
- , "infixr" ]
+ , "infixr"
+ , "module" ]
reservedOpNames :: [String]
reservedOpNames = [ "!", "~", "-", "<=", ">=", "<", ">", "*", "/", "%", "++", "+", "<<", ">>>", ">>"
@@ -133,8 +134,16 @@ natural = PT.natural tokenParser
tick :: P.Parsec String u Char
tick = lexeme $ P.char '`'
-properName :: P.Parsec String u String
-properName = lexeme $ P.try ((:) <$> P.upper <*> many (PT.identLetter langDef) P.<?> "name")
+properName :: P.Parsec String u ProperName
+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
+ where
+ part path = (do name <- P.try (properName <* delimiter)
+ part (subModule path name))
+ <|> (Qualified path <$> P.try parser)
+ delimiter = indented *> colon <* P.notFollowedBy colon
integerOrFloat :: P.Parsec String u (Either Integer Double)
integerOrFloat = (Left <$> P.try (PT.natural tokenParser) <|>
diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs
index f32885d..7933cef 100644
--- a/src/Language/PureScript/Parser/Declarations.hs
+++ b/src/Language/PureScript/Parser/Declarations.hs
@@ -90,6 +90,15 @@ parseFixityDeclaration = do
P.modifyState $ \st -> st { fixities = M.insert name fixity current }
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
+
parseDeclaration :: P.Parsec String ParseState Declaration
parseDeclaration = P.choice
[ parseDataDeclaration
@@ -97,7 +106,8 @@ parseDeclaration = P.choice
, parseTypeSynonymDeclaration
, parseValueDeclaration
, parseExternDeclaration
- , parseFixityDeclaration ] P.<?> "declaration"
+ , parseFixityDeclaration
+ , parseModuleDeclaration ] P.<?> "declaration"
parseDeclarations :: P.Parsec String ParseState [Declaration]
-parseDeclarations = whiteSpace *> mark (same *> P.many parseDeclaration) <* P.eof
+parseDeclarations = whiteSpace *> mark (P.many (same *> parseDeclaration)) <* P.eof
diff --git a/src/Language/PureScript/Parser/Types.hs b/src/Language/PureScript/Parser/Types.hs
index 8fea205..156a9fd 100644
--- a/src/Language/PureScript/Parser/Types.hs
+++ b/src/Language/PureScript/Parser/Types.hs
@@ -52,7 +52,7 @@ parseTypeVariable :: P.Parsec String ParseState Type
parseTypeVariable = TypeVar <$> identifier
parseTypeConstructor :: P.Parsec String ParseState Type
-parseTypeConstructor = TypeConstructor <$> properName
+parseTypeConstructor = TypeConstructor <$> parseQualified properName
parseTypeAtom :: P.Parsec String ParseState Type
parseTypeAtom = indented *> P.choice (map P.try
diff --git a/src/Language/PureScript/Parser/Values.hs b/src/Language/PureScript/Parser/Values.hs
index c0d60c8..4570edf 100644
--- a/src/Language/PureScript/Parser/Values.hs
+++ b/src/Language/PureScript/Parser/Values.hs
@@ -59,20 +59,30 @@ parseIdentifierAndValue = (,) <$> (C.indented *> C.identifier <* C.indented <* C
parseAbs :: P.Parsec String ParseState Value
parseAbs = do
C.lexeme $ P.char '\\'
- args <- (C.indented *> C.parseIdent) `P.sepBy` (C.indented *> C.comma)
+ args <- P.many (C.indented *> (P.try singleArg <|> manyArgs))
C.lexeme $ C.indented *> P.string "->"
value <- parseValue
- return $ Abs args value
+ return $ toFunction args value
+ where
+ manyArgs :: P.Parsec String ParseState (Value -> Value)
+ manyArgs = do
+ args <- C.parens ((C.indented *> C.parseIdent) `P.sepBy` (C.indented *> C.comma))
+ return $ Abs args
+ singleArg :: P.Parsec String ParseState (Value -> Value)
+ singleArg = Abs . return <$> C.parseIdent
+ toFunction :: [Value -> Value] -> Value -> Value
+ toFunction [] value = Abs [] value
+ toFunction args value = foldr (($)) value args
parseApp :: P.Parsec String ParseState Value
parseApp = App <$> parseValue
<*> (C.indented *> C.parens (parseValue `P.sepBy` (C.indented *> C.comma)))
parseVar :: P.Parsec String ParseState Value
-parseVar = Var <$> C.parseIdent
+parseVar = Var <$> C.parseQualified C.parseIdent
parseConstructor :: P.Parsec String ParseState Value
-parseConstructor = Constructor <$> C.properName
+parseConstructor = Constructor <$> C.parseQualified C.properName
parseCase :: P.Parsec String ParseState Value
parseCase = Case <$> P.between (P.try (C.reserved "case")) (C.indented *> C.reserved "of") parseValue
@@ -102,8 +112,8 @@ parseValueAtom = C.indented *> P.choice
, parseArrayLiteral
, parseObjectLiteral
, parseAbs
- , P.try parseVar
, P.try parseConstructor
+ , P.try parseVar
, parseBlock
, parseCase
, parseIfThenElse
@@ -135,7 +145,7 @@ parseValue = do
, Prefix $ C.lexeme (P.try $ C.indented *> C.reservedOp "-") >> return (Unary Negate)
, Prefix $ C.lexeme (P.try $ C.indented *> C.reservedOp "+") >> return id ]
] ++ customOperatorTable user ++
- [ [ Infix (C.lexeme (P.try (C.indented *> C.parseIdentInfix P.<?> "operator") >>= \ident -> return $ \t1 t2 -> App (App (Var ident) [t1]) [t2])) AssocLeft ]
+ [ [ Infix (C.lexeme (P.try (C.indented *> C.parseQualified C.parseIdentInfix P.<?> "operator") >>= \ident -> return $ \t1 t2 -> App (App (Var ident) [t1]) [t2])) AssocLeft ]
, [ Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "!!") >> return (flip Indexer)) AssocRight ]
, [ Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "<=") >> return (Binary LessThanOrEqualTo)) AssocRight
, Infix (C.lexeme (P.try $ C.indented *> C.reservedOp ">=") >> return (Binary GreaterThanOrEqualTo)) AssocRight ]
@@ -171,7 +181,7 @@ customOperatorTable fixities =
C.lexeme $ P.try $ do
C.indented
C.reservedOp name P.<?> "operator"
- return $ \t1 t2 -> App (App (Var (Op name)) [t1]) [t2])
+ return $ \t1 t2 -> App (App (Var (Qualified global (Op name))) [t1]) [t2])
levels
toAssoc :: Associativity -> Assoc
@@ -247,10 +257,10 @@ parseVarBinder :: P.Parsec String ParseState Binder
parseVarBinder = VarBinder <$> C.parseIdent
parseNullaryBinder :: P.Parsec String ParseState Binder
-parseNullaryBinder = NullaryBinder <$> C.lexeme C.properName
+parseNullaryBinder = NullaryBinder <$> C.lexeme (C.parseQualified C.properName)
parseUnaryBinder :: P.Parsec String ParseState Binder
-parseUnaryBinder = UnaryBinder <$> C.lexeme C.properName <*> (C.indented *> parseBinder)
+parseUnaryBinder = UnaryBinder <$> C.lexeme (C.parseQualified C.properName) <*> (C.indented *> parseBinder)
parseObjectBinder :: P.Parsec String ParseState Binder
parseObjectBinder = ObjectBinder <$> C.braces ((C.indented *> parseIdentifierAndBinder) `P.sepBy` (C.indented *> C.comma))
diff --git a/src/Language/PureScript/Pretty/JS.hs b/src/Language/PureScript/Pretty/JS.hs
index 63ab54d..e449a25 100644
--- a/src/Language/PureScript/Pretty/JS.hs
+++ b/src/Language/PureScript/Pretty/JS.hs
@@ -37,8 +37,8 @@ literals = Pattern $ A.Kleisli match
match (JSObjectLiteral ps) = Just $ "{ " ++ intercalate ", " (map (\(key, value) -> key ++ ": " ++ prettyPrintJS value) ps) ++ " }"
match (JSBlock sts) = Just $ "{ " ++ intercalate "; " (map prettyPrintJS sts) ++ " }"
match (JSVar ident) = Just (identToJs ident)
- match (JSVariableIntroduction ident value) = Just $ "var " ++ identToJs ident ++ " = " ++ prettyPrintJS value
- match (JSAssignment target value) = Just $ identToJs target ++ " = " ++ prettyPrintJS value
+ match (JSVariableIntroduction ident value) = Just $ "var " ++ identToJs ident ++ maybe "" ((" = " ++) . prettyPrintJS) value
+ match (JSAssignment target value) = Just $ targetToJs target ++ " = " ++ prettyPrintJS value
match (JSWhile cond sts) = Just $ "while ("
++ prettyPrintJS cond ++ ") "
++ prettyPrintJS sts
@@ -55,6 +55,10 @@ literals = Pattern $ A.Kleisli match
match (JSThrow value) = Just $ "throw " ++ prettyPrintJS value
match _ = Nothing
+targetToJs :: JSAssignment -> String
+targetToJs (JSAssignVariable ident) = identToJs ident
+targetToJs (JSAssignProperty prop target) = targetToJs target ++ "." ++ prop
+
conditional :: Pattern JS ((JS, JS), JS)
conditional = Pattern $ A.Kleisli match
where
@@ -115,7 +119,7 @@ prettyPrintJS = fromMaybe (error "Incomplete pattern") . pattern matchValue
, [ Wrap app $ \args val -> val ++ "(" ++ args ++ ")" ]
, [ Wrap lam $ \(name, args) ret -> "function "
++ maybe "" identToJs name
- ++ "(" ++ intercalate "," (map identToJs args) ++ ") "
+ ++ "(" ++ intercalate ", " (map identToJs args) ++ ") "
++ ret ]
, [ Wrap conditional $ \(th, el) cond -> cond ++ " ? " ++ prettyPrintJS th ++ " : " ++ prettyPrintJS el ]
, [ binary LessThan "<" ]
diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs
index 8eb55ed..5142416 100644
--- a/src/Language/PureScript/Pretty/Types.hs
+++ b/src/Language/PureScript/Pretty/Types.hs
@@ -41,9 +41,9 @@ typeLiterals = Pattern $ A.Kleisli match
match (Array ty) = Just $ "[" ++ prettyPrintType ty ++ "]"
match (Object row) = Just $ "{ " ++ prettyPrintRow row ++ " }"
match (TypeVar var) = Just var
- match (TypeConstructor ctor) = Just ctor
+ match (TypeConstructor ctor) = Just $ show ctor
match (TUnknown u) = Just $ 'u' : show u
- match (SaturatedTypeSynonym name args) = Just $ name ++ "<" ++ intercalate "," (map prettyPrintType args) ++ ">"
+ match (SaturatedTypeSynonym name args) = Just $ show name ++ "<" ++ intercalate "," (map prettyPrintType args) ++ ">"
match _ = Nothing
prettyPrintRow :: Row -> String
diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs
index f63d9b6..eff00eb 100644
--- a/src/Language/PureScript/Pretty/Values.hs
+++ b/src/Language/PureScript/Pretty/Values.hs
@@ -38,7 +38,7 @@ literals = Pattern $ A.Kleisli match
match (BooleanLiteral False) = Just "false"
match (ArrayLiteral xs) = Just $ "[" ++ intercalate ", " (map prettyPrintValue xs) ++ "]"
match (ObjectLiteral ps) = Just $ "{" ++ intercalate ", " (map (uncurry prettyPrintObjectProperty) ps) ++ "}"
- match (Constructor name) = Just name
+ match (Constructor name) = Just $ show name
match (Block sts) = Just $ "do { " ++ intercalate " ; " (map prettyPrintStatement sts) ++ " }"
match (Case value binders) = Just $ "case " ++ prettyPrintValue value ++ " of { " ++ intercalate " ; " (map (uncurry prettyPrintCaseAlternative) binders) ++ " }"
match (Var ident) = Just $ show ident
@@ -146,8 +146,8 @@ prettyPrintBinder (NumberBinder num) = either show show num
prettyPrintBinder (BooleanBinder True) = "true"
prettyPrintBinder (BooleanBinder False) = "false"
prettyPrintBinder (VarBinder ident) = show ident
-prettyPrintBinder (NullaryBinder ctor) = ctor
-prettyPrintBinder (UnaryBinder ctor b) = ctor ++ prettyPrintBinder b
+prettyPrintBinder (NullaryBinder ctor) = show ctor
+prettyPrintBinder (UnaryBinder ctor b) = show ctor ++ prettyPrintBinder b
prettyPrintBinder (ObjectBinder bs) = "{ " ++ intercalate ", " (map (uncurry prettyPrintObjectPropertyBinder) bs) ++ " }"
prettyPrintBinder (ArrayBinder bs rest) = "[ " ++ intercalate ", " (map prettyPrintBinder bs) ++ maybe "" (("; " ++) . prettyPrintBinder) rest ++ " ]"
prettyPrintBinder (NamedBinder ident binder) = show ident ++ "@" ++ prettyPrintBinder binder
diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs
index 79fe476..8de9dbc 100644
--- a/src/Language/PureScript/TypeChecker.hs
+++ b/src/Language/PureScript/TypeChecker.hs
@@ -42,27 +42,29 @@ import Control.Monad.Error
typeCheckAll :: [Declaration] -> Check ()
typeCheckAll [] = return ()
typeCheckAll (DataDeclaration name args dctors : rest) = do
- rethrow (("Error in type constructor " ++ name ++ ": ") ++) $ do
+ rethrow (("Error in type constructor " ++ show name ++ ": ") ++) $ do
env <- getEnv
- guardWith (name ++ " is already defined") $ not $ M.member name (types env)
+ 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 name (ctorKind, Data) (types env) }
+ putEnv $ env { types = M.insert (modulePath, name) (ctorKind, Data) (types env) }
forM_ dctors $ \(dctor, maybeTy) ->
- rethrow (("Error in data constructor " ++ name ++ ": ") ++) $ do
+ rethrow (("Error in data constructor " ++ show name ++ ": ") ++) $ do
env' <- getEnv
- guardWith (dctor ++ " is already defined") $ not $ M.member dctor (dataConstructors env')
- let retTy = foldl TypeApp (TypeConstructor name) (map TypeVar args)
+ 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 = PolyType args dctorTy
- putEnv $ env' { dataConstructors = M.insert dctor polyType (dataConstructors env') }
+ putEnv $ env' { dataConstructors = M.insert (modulePath, dctor) polyType (dataConstructors env') }
typeCheckAll rest
typeCheckAll (TypeSynonymDeclaration name args ty : rest) = do
- rethrow (("Error in type synonym " ++ name ++ ": ") ++) $ do
+ rethrow (("Error in type synonym " ++ show name ++ ": ") ++) $ do
env <- getEnv
- guardWith (name ++ " is already defined") $ not $ M.member name (types env)
+ 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 name (kind, TypeSynonym) (types env)
- , typeSynonyms = M.insert name (args, ty) (typeSynonyms env) }
+ 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' val : rest) | name == name' =
typeCheckAll (ValueDeclaration name (TypedValue val ty) : rest)
@@ -70,40 +72,48 @@ typeCheckAll (TypeDeclaration name _ : _) = throwError $ "Orphan type declaratio
typeCheckAll (ValueDeclaration name val : rest) = do
rethrow (("Error in declaration " ++ show name ++ ": ") ++) $ do
env <- getEnv
- case M.lookup name (names env) of
+ modulePath <- checkModulePath `fmap` get
+ case M.lookup (modulePath, name) (names env) of
Just ty -> throwError $ show name ++ " is already defined"
Nothing -> do
ty <- typeOf name val
- putEnv (env { names = M.insert name (ty, Value) (names env) })
+ putEnv (env { names = M.insert (modulePath, name) (ty, Value) (names env) })
typeCheckAll rest
typeCheckAll (ExternDataDeclaration name kind : rest) = do
env <- getEnv
- guardWith (name ++ " is already defined") $ not $ M.member name (types env)
- putEnv $ env { types = M.insert name (kind, TypeSynonym) (types env) }
+ 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
rethrow (("Error in foreign import member declaration " ++ show name ++ ": ") ++) $ do
env <- getEnv
+ modulePath <- checkModulePath `fmap` get
kind <- kindOf ty
guardWith "Expected kind *" $ kind == Star
- case M.lookup name (names env) of
+ case M.lookup (modulePath, name) (names env) of
Just _ -> throwError $ show name ++ " is already defined"
Nothing -> case ty of
(PolyType _ (Function [_] _)) -> do
- putEnv (env { names = M.insert name (ty, Extern) (names env)
- , members = M.insert name member (members env) })
+ putEnv (env { names = M.insert (modulePath, name) (ty, Extern) (names env)
+ , members = M.insert (modulePath, name) member (members env) })
_ -> throwError "Foreign member declarations must have function types, with an single argument."
typeCheckAll rest
typeCheckAll (ExternDeclaration name ty : rest) = do
rethrow (("Error in foreign import declaration " ++ show name ++ ": ") ++) $ do
env <- getEnv
+ modulePath <- checkModulePath `fmap` get
kind <- kindOf ty
guardWith "Expected kind *" $ kind == Star
- case M.lookup name (names env) of
+ case M.lookup (modulePath, name) (names env) of
Just _ -> throwError $ show name ++ " is already defined"
- Nothing -> putEnv (env { names = M.insert name (ty, Extern) (names env) })
+ Nothing -> putEnv (env { names = M.insert (modulePath, name) (ty, Extern) (names env) })
typeCheckAll rest
typeCheckAll (FixityDeclaration _ name : rest) = do
typeCheckAll rest
env <- getEnv
- guardWith ("Fixity declaration with no binding: " ++ name) $ M.member (Op name) $ names env
+ 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
diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs
index ef7dcd2..92caf37 100644
--- a/src/Language/PureScript/TypeChecker/Kinds.hs
+++ b/src/Language/PureScript/TypeChecker/Kinds.hs
@@ -28,6 +28,7 @@ import Data.Data
import Language.PureScript.Types
import Language.PureScript.Kinds
+import Language.PureScript.Names
import Language.PureScript.Declarations
import Language.PureScript.TypeChecker.Monad
import Language.PureScript.Pretty
@@ -61,15 +62,15 @@ emptyKindSolution = KindSolution KUnknown
kindOf :: PolyType -> Check Kind
kindOf (PolyType idents ty) = do
ns <- replicateM (length idents) fresh
- (cs, n, m) <- kindConstraints (M.fromList (zip idents ns)) ty
+ (cs, n, m) <- kindConstraints Nothing (M.fromList (zip idents ns)) ty
solution <- solveKindConstraints cs emptyKindSolution
return $ starIfUnknown $ runKindSolution solution n
-kindsOf :: Maybe String -> [String] -> [Type] -> Check Kind
+kindsOf :: Maybe ProperName -> [String] -> [Type] -> Check Kind
kindsOf name args ts = do
tyCon <- fresh
nargs <- replicateM (length args) fresh
- (cs, ns, m) <- kindConstraintsAll (maybe id (`M.insert` tyCon) name $ M.fromList (zip args nargs)) ts
+ (cs, ns, m) <- kindConstraintsAll (fmap (\pn -> (pn, tyCon)) name) (M.fromList (zip args nargs)) ts
let extraConstraints =
KindConstraint tyCon (foldr (FunKind . KUnknown) Star nargs) DataDeclOrigin
: zipWith (\n arg -> KindConstraint n Star (TypeOrigin arg)) ns ts
@@ -81,61 +82,65 @@ starIfUnknown (KUnknown _) = Star
starIfUnknown (FunKind k1 k2) = FunKind (starIfUnknown k1) (starIfUnknown k2)
starIfUnknown k = k
-kindConstraintsAll :: M.Map String Int -> [Type] -> Check ([KindConstraint], [Int], M.Map String Int)
-kindConstraintsAll m [] = return ([], [], m)
-kindConstraintsAll m (t:ts) = do
- (cs, n1, m') <- kindConstraints m t
- (cs', ns, m'') <- kindConstraintsAll m' ts
+kindConstraintsAll :: Maybe (ProperName, Int) -> M.Map String Int -> [Type] -> Check ([KindConstraint], [Int], M.Map String Int)
+kindConstraintsAll _ m [] = return ([], [], m)
+kindConstraintsAll name m (t:ts) = do
+ (cs, n1, m') <- kindConstraints name m t
+ (cs', ns, m'') <- kindConstraintsAll name m' ts
return (KindConstraint n1 Star (TypeOrigin t) : cs ++ cs', n1:ns, m'')
-kindConstraints :: M.Map String Int -> Type -> Check ([KindConstraint], Int, M.Map String Int)
-kindConstraints m a@(Array t) = do
+kindConstraints :: Maybe (ProperName, Int) -> M.Map String Int -> Type -> Check ([KindConstraint], Int, M.Map String Int)
+kindConstraints name m a@(Array t) = do
me <- fresh
- (cs, n1, m') <- kindConstraints m t
+ (cs, n1, m') <- kindConstraints name m t
return (KindConstraint n1 Star (TypeOrigin t) : KindConstraint me Star (TypeOrigin a) : cs, me, m')
-kindConstraints m o@(Object row) = do
+kindConstraints name m o@(Object row) = do
me <- fresh
- (cs, r, m') <- kindConstraintsForRow m row
+ (cs, r, m') <- kindConstraintsForRow name m row
return (KindConstraint me Star (TypeOrigin o) : KindConstraint r Row (RowOrigin row) : cs, me, m')
-kindConstraints m f@(Function args ret) = do
+kindConstraints name m f@(Function args ret) = do
me <- fresh
- (cs, ns, m') <- kindConstraintsAll m args
- (cs', retN, m'') <- kindConstraints m' ret
+ (cs, ns, m') <- kindConstraintsAll name m args
+ (cs', retN, m'') <- kindConstraints name m' ret
return (KindConstraint retN Star (TypeOrigin ret) : KindConstraint me Star (TypeOrigin f) : zipWith (\n arg -> KindConstraint n Star (TypeOrigin arg)) ns args ++ cs ++ cs', me, m'')
-kindConstraints m (TypeVar v) =
+kindConstraints _ m (TypeVar v) =
case M.lookup v m of
Just u -> return ([], u, m)
Nothing -> throwError $ "Unbound type variable " ++ v
-kindConstraints m c@(TypeConstructor v) = do
+kindConstraints (Just (name, u)) m c@(TypeConstructor v@(Qualified (ModulePath []) pn)) | name == pn = do
env <- getEnv
me <- fresh
- case M.lookup v m of
- Nothing -> case M.lookup v (types env) of
- Nothing -> throwError $ "Unknown type constructor '" ++ v ++ "'"
- Just (kind, _) -> return ([KindConstraint me kind (TypeOrigin c)], me, m)
- Just u -> return ([KindConstraint me (KUnknown u) (TypeOrigin c)], me, m)
-kindConstraints m a@(TypeApp t1 t2) = do
+ modulePath <- checkModulePath `fmap` get
+ return ([KindConstraint me (KUnknown u) (TypeOrigin c)], me, m)
+kindConstraints name m c@(TypeConstructor v) = do
+ env <- getEnv
+ me <- fresh
+ modulePath <- checkModulePath `fmap` get
+ case M.lookup (qualify modulePath v) (types env) of
+ Nothing -> throwError $ "Unknown type constructor '" ++ show v ++ "'"
+ Just (kind, _) -> return ([KindConstraint me kind (TypeOrigin c)], me, m)
+kindConstraints name m a@(TypeApp t1 t2) = do
me <- fresh
- (cs1, n1, m1) <- kindConstraints m t1
- (cs2, n2, m2) <- kindConstraints m1 t2
+ (cs1, n1, m1) <- kindConstraints name m t1
+ (cs2, n2, m2) <- kindConstraints name m1 t2
return (KindConstraint n1 (FunKind (KUnknown n2) (KUnknown me)) (TypeOrigin a) : cs1 ++ cs2, me, m2)
-kindConstraints m t = do
+kindConstraints _ m t = do
me <- fresh
return ([KindConstraint me Star (TypeOrigin t)], me, m)
-kindConstraintsForRow :: M.Map String Int -> Row -> Check ([KindConstraint], Int, M.Map String Int)
-kindConstraintsForRow m r@(RowVar v) = do
+kindConstraintsForRow :: Maybe (ProperName, Int) -> M.Map String Int -> Row -> Check ([KindConstraint], Int, M.Map String Int)
+kindConstraintsForRow _ m r@(RowVar v) = do
me <- case M.lookup v m of
Just u -> return u
Nothing -> fresh
return ([KindConstraint me Row (RowOrigin r)], me, M.insert v me m)
-kindConstraintsForRow m r@REmpty = do
+kindConstraintsForRow _ m r@REmpty = do
me <- fresh
return ([KindConstraint me Row (RowOrigin r)], me, m)
-kindConstraintsForRow m r@(RCons _ ty row) = do
+kindConstraintsForRow name m r@(RCons _ ty row) = do
me <- fresh
- (cs1, n1, m1) <- kindConstraints m ty
- (cs2, n2, m2) <- kindConstraintsForRow m1 row
+ (cs1, n1, m1) <- kindConstraints name m ty
+ (cs2, n2, m2) <- kindConstraintsForRow name m1 row
return (KindConstraint me Row (RowOrigin r) : KindConstraint n1 Star (TypeOrigin ty) : KindConstraint n2 Row (RowOrigin r) : cs1 ++ cs2, me, m2)
solveKindConstraints :: [KindConstraint] -> KindSolution -> Check KindSolution
diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs
index b296e25..7d57bc6 100644
--- a/src/Language/PureScript/TypeChecker/Monad.hs
+++ b/src/Language/PureScript/TypeChecker/Monad.hs
@@ -33,32 +33,38 @@ data NameKind = Value | Extern deriving Show
data TypeDeclarationKind = Data | ExternData | TypeSynonym deriving Show
data Environment = Environment
- { names :: M.Map Ident (PolyType, NameKind)
- , types :: M.Map String (Kind, TypeDeclarationKind)
- , dataConstructors :: M.Map String PolyType
- , typeSynonyms :: M.Map String ([String], Type)
- , members :: M.Map Ident String
- }
+ { names :: M.Map (ModulePath, Ident) (PolyType, NameKind)
+ , types :: M.Map (ModulePath, ProperName) (Kind, TypeDeclarationKind)
+ , dataConstructors :: M.Map (ModulePath, ProperName) PolyType
+ , typeSynonyms :: M.Map (ModulePath, ProperName) ([String], Type)
+ , members :: M.Map (ModulePath, Ident) String
+ } deriving (Show)
emptyEnvironment :: Environment
emptyEnvironment = Environment M.empty M.empty M.empty M.empty M.empty
-newtype Check a = Check { unCheck :: StateT (Environment, Int) (Either String) a } deriving (Functor, Monad, Applicative, MonadPlus, MonadState (Environment, Int), MonadError String)
+data CheckState = CheckState { checkEnv :: Environment
+ , checkNextVar :: Int
+ , checkModulePath :: ModulePath
+ } deriving (Show)
+
+newtype Check a = Check { unCheck :: StateT CheckState (Either String) a }
+ deriving (Functor, Monad, Applicative, MonadPlus, MonadState CheckState, MonadError String)
getEnv :: Check Environment
-getEnv = fmap fst get
+getEnv = fmap checkEnv get
putEnv :: Environment -> Check ()
-putEnv env = fmap (first (const env)) get >>= put
+putEnv env = modify (\s -> s { checkEnv = env })
fresh :: Check Int
fresh = do
- (env, n) <- get
- put (env, n + 1)
- return n
+ st <- get
+ put $ st { checkNextVar = checkNextVar st + 1 }
+ return $ checkNextVar st
check :: Check a -> Either String (a, Environment)
-check = fmap (second fst) . flip runStateT (emptyEnvironment, 0) . unCheck
+check = fmap (second checkEnv) . flip runStateT (CheckState emptyEnvironment 0 global) . unCheck
guardWith :: (MonadError e m) => e -> Bool -> m ()
guardWith _ True = return ()
@@ -66,3 +72,11 @@ guardWith e False = throwError e
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
diff --git a/src/Language/PureScript/TypeChecker/Synonyms.hs b/src/Language/PureScript/TypeChecker/Synonyms.hs
index 62b8bd9..8899fef 100644
--- a/src/Language/PureScript/TypeChecker/Synonyms.hs
+++ b/src/Language/PureScript/TypeChecker/Synonyms.hs
@@ -21,6 +21,7 @@ module Language.PureScript.TypeChecker.Synonyms (
import Language.PureScript.Types
import Language.PureScript.Declarations
+import Language.PureScript.Names
import Data.Maybe (fromMaybe)
import Data.Data
@@ -30,12 +31,12 @@ import Control.Monad.Writer
import Control.Monad.Error
import qualified Data.Map as M
-buildTypeSubstitution :: String -> Int -> Type -> Either String (Maybe Type)
+buildTypeSubstitution :: Qualified ProperName -> Int -> Type -> Either String (Maybe Type)
buildTypeSubstitution 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 n _ (TypeConstructor ctor) | n > 0 && name == ctor = throwError $ "Partially applied type synonym " ++ name
+ go n _ (TypeConstructor ctor) | n > 0 && name == ctor = throwError $ "Partially applied type synonym " ++ show name
go n args (TypeApp f arg) = go (n - 1) (arg:args) f
go _ _ _ = return Nothing
@@ -44,12 +45,12 @@ everywhereM' f x = do
y <- f x
gmapM (everywhereM' f) y
-saturateTypeSynonym :: (Data d) => String -> Int -> d -> Either String d
+saturateTypeSynonym :: (Data d) => Qualified ProperName -> Int -> d -> Either String d
saturateTypeSynonym name n = everywhereM' (mkM replace)
where
replace t = fmap (fromMaybe t) $ buildTypeSubstitution name n t
-saturateAllTypeSynonyms :: (Data d) => [(String, Int)] -> d -> Either String d
+saturateAllTypeSynonyms :: (Data d) => [(Qualified ProperName, Int)] -> d -> Either String d
saturateAllTypeSynonyms syns d = foldM (\d (name, n) -> saturateTypeSynonym name n d) d syns
diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
index 489be24..fcd8c01 100644
--- a/src/Language/PureScript/TypeChecker/Types.hs
+++ b/src/Language/PureScript/TypeChecker/Types.hs
@@ -192,7 +192,7 @@ replaceVarsWithUnknowns idents = flip evalStateT M.empty . everywhereM (flip ext
replaceAllTypeSynonyms :: (D.Data d) => d -> Check d
replaceAllTypeSynonyms d = do
env <- getEnv
- let syns = map (\(name, (args, _)) -> (name, length args)) . M.toList $ typeSynonyms env
+ let syns = map (\((path, name), (args, _)) -> (Qualified path name, length args)) . M.toList $ typeSynonyms env
either throwError return $ saturateAllTypeSynonyms syns d
desaturateAllTypeSynonyms :: (D.Data d) => d -> d
@@ -306,19 +306,25 @@ typeConstraints m v@(App f xs) = do
let (cs2, ns) = (concatMap fst &&& map snd) all
me <- fresh
return (TypeConstraint n1 (Function (map TUnknown ns) (TUnknown me)) (ValueOrigin v) : cs1 ++ cs2, me)
-typeConstraints m v@(Var var) =
- case M.lookup var m of
- Nothing -> do
- env <- getEnv
- case M.lookup var (names env) of
- Nothing -> throwError $ show var ++ " is undefined"
- Just (PolyType idents ty, _) -> do
+typeConstraints m v@(Var var@(Qualified mp name)) = do
+ case mp of
+ ModulePath [] ->
+ case M.lookup name m of
+ Just u -> do
me <- fresh
- replaced <- replaceVarsWithUnknowns idents ty
- return ([TypeConstraint me replaced (ValueOrigin v)], me)
- Just u -> do
- me <- fresh
- return ([TypeConstraint u (TUnknown me) (ValueOrigin v)], me)
+ return ([TypeConstraint u (TUnknown me) (ValueOrigin v)], me)
+ Nothing -> lookupGlobal
+ _ -> lookupGlobal
+ where
+ lookupGlobal = do
+ env <- getEnv
+ modulePath <- checkModulePath `fmap` get
+ case M.lookup (qualify modulePath var) (names env) of
+ Nothing -> throwError $ show var ++ " is undefined"
+ Just (PolyType idents ty, _) -> do
+ me <- fresh
+ replaced <- replaceVarsWithUnknowns idents ty
+ return ([TypeConstraint me replaced (ValueOrigin v)], me)
typeConstraints m (Block ss) = do
ret <- fresh
(cs, allCodePathsReturn, _) <- typeConstraintsForBlock m M.empty ret ss
@@ -326,8 +332,9 @@ typeConstraints m (Block ss) = do
return (cs, ret)
typeConstraints m v@(Constructor c) = do
env <- getEnv
- case M.lookup c (dataConstructors env) of
- Nothing -> throwError $ "Constructor " ++ c ++ " is undefined"
+ modulePath <- checkModulePath `fmap` get
+ case M.lookup (qualify modulePath c) (dataConstructors env) of
+ Nothing -> throwError $ "Constructor " ++ show c ++ " is undefined"
Just (PolyType idents ty) -> do
me <- fresh
replaced <- replaceVarsWithUnknowns idents ty
@@ -394,21 +401,23 @@ typeConstraintsForBinder val b@(VarBinder name) = do
return ([TypeConstraint me (TUnknown val) (BinderOrigin b)], M.singleton name me)
typeConstraintsForBinder val b@(NullaryBinder ctor) = do
env <- getEnv
- case M.lookup ctor (dataConstructors env) of
+ modulePath <- checkModulePath `fmap` get
+ case M.lookup (qualify modulePath ctor) (dataConstructors env) of
Just (PolyType args ret) -> do
ret' <- replaceVarsWithUnknowns args ret
return ([TypeConstraint val ret' (BinderOrigin b)], M.empty)
- _ -> throwError $ "Constructor " ++ ctor ++ " is not defined"
+ _ -> throwError $ "Constructor " ++ show ctor ++ " is not defined"
typeConstraintsForBinder val b@(UnaryBinder ctor binder) = do
env <- getEnv
- case M.lookup ctor (dataConstructors env) of
+ modulePath <- checkModulePath `fmap` get
+ case M.lookup (qualify modulePath ctor) (dataConstructors env) of
Just (PolyType idents f@(Function [_] _)) -> do
obj <- fresh
(Function [ty] ret) <- replaceVarsWithUnknowns idents f
(cs, m1) <- typeConstraintsForBinder obj binder
return (TypeConstraint val ret (BinderOrigin b) : TypeConstraint obj ty (BinderOrigin b) : cs, m1)
- Just _ -> throwError $ ctor ++ " is not a unary constructor"
- _ -> throwError $ "Constructor " ++ ctor ++ " is not defined"
+ Just _ -> throwError $ show ctor ++ " is not a unary constructor"
+ _ -> throwError $ "Constructor " ++ show ctor ++ " is not defined"
typeConstraintsForBinder val b@(ObjectBinder props) = do
row <- fresh
rest <- fresh
@@ -573,7 +582,8 @@ unifyTypes o (SaturatedTypeSynonym name1 args1) (SaturatedTypeSynonym name2 args
fmap concat $ zipWithM (unifyTypes o) args1 args2
unifyTypes o (SaturatedTypeSynonym name args) ty = do
env <- getEnv
- case M.lookup name (typeSynonyms env) of
+ modulePath <- checkModulePath `fmap` get
+ case M.lookup (qualify modulePath name) (typeSynonyms env) of
Just (synArgs, body) -> do
let m = M.fromList $ zip synArgs args
let replaced = replaceTypeVars m body
@@ -591,7 +601,10 @@ unifyTypes o (Function args1 ret1) (Function args2 ret2) = do
cs2 <- unifyTypes o ret1 ret2
return $ cs1 ++ cs2
unifyTypes _ (TypeVar v1) (TypeVar v2) | v1 == v2 = return []
-unifyTypes _ (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = 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)
+ return []
unifyTypes o (TypeApp t1 t2) (TypeApp t3 t4) = do
cs1 <- unifyTypes o t1 t3
cs2 <- unifyTypes o t2 t4
diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs
index 8c9bbb4..79042a7 100644
--- a/src/Language/PureScript/Types.hs
+++ b/src/Language/PureScript/Types.hs
@@ -17,6 +17,7 @@
module Language.PureScript.Types where
import Data.Data
+import Language.PureScript.Names
data Type
= TUnknown Int
@@ -27,9 +28,9 @@ data Type
| Object Row
| Function [Type] Type
| TypeVar String
- | TypeConstructor String
+ | TypeConstructor (Qualified ProperName)
| TypeApp Type Type
- | SaturatedTypeSynonym String [Type] deriving (Show, Eq, Data, Typeable)
+ | SaturatedTypeSynonym (Qualified ProperName) [Type] deriving (Show, Eq, Data, Typeable)
data PolyType = PolyType [String] Type deriving (Show, Eq, Data, Typeable)
diff --git a/src/Language/PureScript/Values.hs b/src/Language/PureScript/Values.hs
index 28ce5c0..a486173 100644
--- a/src/Language/PureScript/Values.hs
+++ b/src/Language/PureScript/Values.hs
@@ -61,10 +61,10 @@ data Value
| ObjectUpdate Value [(String, Value)]
| Abs [Ident] Value
| App Value [Value]
- | Var Ident
+ | Var (Qualified Ident)
| IfThenElse Value Value Value
| Block [Statement]
- | Constructor String
+ | Constructor (Qualified ProperName)
| Case Value [(Binder, Value)]
| TypedValue Value PolyType deriving (Show, Data, Typeable)
@@ -89,8 +89,8 @@ data Binder
| StringBinder String
| NumberBinder (Either Integer Double)
| VarBinder Ident
- | NullaryBinder String
- | UnaryBinder String Binder
+ | NullaryBinder (Qualified ProperName)
+ | UnaryBinder (Qualified ProperName) Binder
| ObjectBinder [(String, Binder)]
| ArrayBinder [Binder] (Maybe Binder)
| NamedBinder Ident Binder
diff --git a/src/Main.hs b/src/Main.hs
index 25e058a..4cdcdfc 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -40,13 +40,13 @@ compile inputFiles outputFile externsFile = do
U.putStrLn typeError
exitFailure
Right (_, env) -> do
- let js = intercalate "; " . map (prettyPrintJS . optimize) . concat . mapMaybe (declToJs) $ decls
+ let js = intercalate "; " . map (prettyPrintJS . optimize) . concat . mapMaybe (declToJs Nothing global) $ decls
case outputFile of
Just path -> U.writeFile path js
Nothing -> U.putStrLn js
case externsFile of
Nothing -> return ()
- Just filePath -> U.writeFile filePath $ intercalate "\n" $ mapMaybe (externToPs env) decls
+ Just filePath -> U.writeFile filePath $ intercalate "\n" $ mapMaybe (externToPs 0 global env) decls
exitSuccess
inputFiles :: Term [FilePath]