summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPhilFreeman <>2014-01-04 06:27:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2014-01-04 06:27:00 (GMT)
commit94e5e17d8cf671bd60064c2482d5fbcea8bfdb43 (patch)
treee1def1c37e2b4c15d68d84161cc85a91e93bdfc0
parent93dfbdb3779ebcf9961a0402f46c297c3903a6fa (diff)
version 0.2.30.2.3
-rw-r--r--purescript.cabal45
-rw-r--r--src/Data/Generics/Extras.hs2
-rw-r--r--src/Language/PureScript.hs18
-rw-r--r--src/Language/PureScript/BindingGroups.hs98
-rw-r--r--src/Language/PureScript/CaseDeclarations.hs67
-rw-r--r--src/Language/PureScript/CodeGen/Externs.hs41
-rw-r--r--src/Language/PureScript/CodeGen/JS.hs252
-rw-r--r--src/Language/PureScript/CodeGen/JS/AST.hs2
-rw-r--r--src/Language/PureScript/CodeGen/Monad.hs8
-rw-r--r--src/Language/PureScript/Declarations.hs9
-rw-r--r--src/Language/PureScript/Names.hs24
-rw-r--r--src/Language/PureScript/Operators.hs46
-rw-r--r--src/Language/PureScript/Optimize.hs12
-rw-r--r--src/Language/PureScript/Parser/Common.hs115
-rw-r--r--src/Language/PureScript/Parser/Declarations.hs55
-rw-r--r--src/Language/PureScript/Parser/State.hs4
-rw-r--r--src/Language/PureScript/Parser/Types.hs5
-rw-r--r--src/Language/PureScript/Parser/Values.hs121
-rw-r--r--src/Language/PureScript/Pretty/Common.hs19
-rw-r--r--src/Language/PureScript/Pretty/JS.hs31
-rw-r--r--src/Language/PureScript/Pretty/Kinds.hs6
-rw-r--r--src/Language/PureScript/Pretty/Types.hs12
-rw-r--r--src/Language/PureScript/Pretty/Values.hs75
-rw-r--r--src/Language/PureScript/Scope.hs75
-rw-r--r--src/Language/PureScript/TypeChecker.hs223
-rw-r--r--src/Language/PureScript/TypeChecker/Kinds.hs107
-rw-r--r--src/Language/PureScript/TypeChecker/Monad.hs128
-rw-r--r--src/Language/PureScript/TypeChecker/Synonyms.hs23
-rw-r--r--src/Language/PureScript/TypeChecker/Types.hs734
-rw-r--r--src/Language/PureScript/TypeDeclarations.hs35
-rw-r--r--src/Language/PureScript/Types.hs5
-rw-r--r--src/Language/PureScript/Unknown.hs1
-rw-r--r--src/Language/PureScript/Values.hs11
-rw-r--r--src/Main.hs48
-rw-r--r--tests/Main.hs13
35 files changed, 1498 insertions, 972 deletions
diff --git a/purescript.cabal b/purescript.cabal
index d085cc2..40f9892 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -1,5 +1,5 @@
name: purescript
-version: 0.1.12
+version: 0.2.3
cabal-version: >=1.8
build-type: Simple
license: MIT
@@ -14,46 +14,49 @@ author: Phil Freeman <paf31@cantab.net>
data-dir: ""
library
- build-depends: base >=4 && <5, syb -any, cmdtheline -any,
- containers -any, mtl -any, transformers -any, parsec -any,
- utf8-string -any
- exposed-modules: Data.Generics.Extras Language.PureScript.Operators
- Language.PureScript.Optimize Language.PureScript.Pretty.JS
- Language.PureScript.CodeGen.JS.AST Main Language.PureScript
- Language.PureScript.Declarations Language.PureScript.Names
- Language.PureScript.Types Language.PureScript.Values
- Language.PureScript.Kinds Language.PureScript.Pretty
- Language.PureScript.Pretty.Common Language.PureScript.Pretty.Values
- Language.PureScript.Pretty.Types Language.PureScript.Pretty.Kinds
+ 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.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.Monad
+ 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
Language.PureScript.Parser Language.PureScript.Parser.Common
Language.PureScript.Parser.Declarations
+ Language.PureScript.Parser.Kinds Language.PureScript.Parser.State
Language.PureScript.Parser.Types Language.PureScript.Parser.Values
- Language.PureScript.Parser.State Language.PureScript.Parser.Kinds
+ Language.PureScript.Pretty Language.PureScript.Pretty.Common
+ Language.PureScript.Pretty.JS Language.PureScript.Pretty.Kinds
+ Language.PureScript.Pretty.Types Language.PureScript.Pretty.Values
Language.PureScript.TypeChecker
Language.PureScript.TypeChecker.Kinds
Language.PureScript.TypeChecker.Monad
- Language.PureScript.TypeChecker.Types
Language.PureScript.TypeChecker.Synonyms
- Language.PureScript.Unknown
+ Language.PureScript.TypeChecker.Types Language.PureScript.Types
+ Language.PureScript.Unknown Language.PureScript.Values Main
+ Language.PureScript.CaseDeclarations
exposed: True
buildable: True
hs-source-dirs: src
executable psc
build-depends: base >=4 && <5, cmdtheline -any, containers -any,
- mtl -any, transformers -any, parsec -any, utf8-string -any,
- syb -any
+ directory -any, filepath -any, mtl -any, parsec -any,
+ purescript -any, syb -any, transformers -any, utf8-string -any
main-is: Main.hs
buildable: True
hs-source-dirs: src
other-modules:
+ ghc-options: -Wall -O2 -fno-warn-unused-do-bind
test-suite tests
- build-depends: base >=4 && <5, syb -any, directory -any,
- filepath -any, containers -any, mtl -any, transformers -any,
- parsec -any, utf8-string -any, purescript -any
+ build-depends: base >=4 && <5, cmdtheline -any, containers -any,
+ directory -any, filepath -any, mtl -any, parsec -any,
+ purescript -any, syb -any, transformers -any, utf8-string -any
type: exitcode-stdio-1.0
main-is: Main.hs
buildable: True
diff --git a/src/Data/Generics/Extras.hs b/src/Data/Generics/Extras.hs
index 89d05f0..02db199 100644
--- a/src/Data/Generics/Extras.hs
+++ b/src/Data/Generics/Extras.hs
@@ -18,7 +18,7 @@ module Data.Generics.Extras where
import Data.Data
-everywhereM' :: (Monad m, Data d) => (forall d. (Data d) => d -> m d) -> d -> m d
+everywhereM' :: (Monad m, Data d) => (forall d1. (Data d1) => d1 -> m d1) -> d -> m d
everywhereM' f x = do
y <- f x
gmapM (everywhereM' f) y
diff --git a/src/Language/PureScript.hs b/src/Language/PureScript.hs
index 9a40e30..97a7991 100644
--- a/src/Language/PureScript.hs
+++ b/src/Language/PureScript.hs
@@ -25,14 +25,18 @@ import Language.PureScript.TypeChecker as P
import Language.PureScript.Pretty as P
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
- (_, env) <- runCheck (typeCheckAll bracketted)
- let js = prettyPrintJS . map optimize . concat . mapMaybe (\decl -> declToJs Nothing global decl env) $ bracketted
- let exts = intercalate "\n" . mapMaybe (externToPs 0 global env) $ bracketted
+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)
diff --git a/src/Language/PureScript/BindingGroups.hs b/src/Language/PureScript/BindingGroups.hs
new file mode 100644
index 0000000..5fe000d
--- /dev/null
+++ b/src/Language/PureScript/BindingGroups.hs
@@ -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"
diff --git a/src/Language/PureScript/CaseDeclarations.hs b/src/Language/PureScript/CaseDeclarations.hs
new file mode 100644
index 0000000..66c9ea7
--- /dev/null
+++ b/src/Language/PureScript/CaseDeclarations.hs
@@ -0,0 +1,67 @@
+-----------------------------------------------------------------------------
+--
+-- Module : Language.PureScript.CaseDeclarations
+-- Copyright : (c) Phil Freeman 2013
+-- License : MIT
+--
+-- Maintainer : Phil Freeman <paf31@cantab.net>
+-- Stability : experimental
+-- Portability :
+--
+-- |
+--
+-----------------------------------------------------------------------------
+
+module Language.PureScript.CaseDeclarations (
+ desugarCases,
+ desugarCasesModule
+) where
+
+import Data.List (groupBy)
+import Control.Applicative ((<$>))
+import Control.Monad (forM, join, unless)
+import Control.Monad.Error.Class
+
+import Language.PureScript.Names
+import Language.PureScript.Values
+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
+
+inSameGroup :: Declaration -> Declaration -> Bool
+inSameGroup (ValueDeclaration ident1 _ _ _) (ValueDeclaration ident2 _ _ _) = ident1 == ident2
+inSameGroup _ _ = False
+
+toDecls :: [Declaration] -> Either String [Declaration]
+toDecls d@[ValueDeclaration _ [] Nothing _] = return d
+toDecls ds@(ValueDeclaration ident bs _ _ : _) = do
+ let tuples = map toTuple ds
+ unless (all ((== map length bs) . map length . fst) tuples) $
+ throwError $ "Argument list lengths differ in declaration " ++ show ident
+ return [makeCaseDeclaration ident tuples]
+toDecls ds = return ds
+
+toTuple :: Declaration -> ([[Binder]], (Maybe Guard, Value))
+toTuple (ValueDeclaration _ bs g val) = (bs, (g, val))
+toTuple _ = error "Not a value declaration"
+
+makeCaseDeclaration :: Ident -> [([[Binder]], (Maybe Guard, Value))] -> Declaration
+makeCaseDeclaration ident alternatives =
+ let
+ argPattern = map length . fst . head $ alternatives
+ args = take (sum argPattern) $ unusedNames (ident, alternatives)
+ 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
+ ValueDeclaration ident [] Nothing value
+
+rearrange :: [Int] -> [a] -> [[a]]
+rearrange [] _ = []
+rearrange (n:ns) xs = take n xs : rearrange ns (drop n xs)
+
diff --git a/src/Language/PureScript/CodeGen/Externs.hs b/src/Language/PureScript/CodeGen/Externs.hs
index eacd224..8e04d05 100644
--- a/src/Language/PureScript/CodeGen/Externs.hs
+++ b/src/Language/PureScript/CodeGen/Externs.hs
@@ -13,30 +13,37 @@
-----------------------------------------------------------------------------
module Language.PureScript.CodeGen.Externs (
- externToPs
+ moduleToPs
) where
-import Data.List (intercalate)
-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)
+
+moduleToPs :: Module -> Environment -> String
+moduleToPs (Module pname@(ProperName moduleName) decls) env =
+ "module " ++ moduleName ++ " where\n" ++
+ (intercalate "\n" . map (" " ++) . concatMap (declToPs (ModuleName pname) env) $ decls)
-externToPs :: Int -> ModulePath -> Environment -> Declaration -> Maybe String
-externToPs indent path env (ValueDeclaration name _) = do
+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 path env (ExternMemberDeclaration member name ty) =
- return $ replicate indent ' ' ++ "foreign import member " ++ show member ++ " " ++ show name ++ " :: " ++ prettyPrintType 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
+ 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 _ _ _ = []
diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs
index 720d197..ba09b41 100644
--- a/src/Language/PureScript/CodeGen/JS.hs
+++ b/src/Language/PureScript/CodeGen/JS.hs
@@ -14,162 +14,182 @@
module Language.PureScript.CodeGen.JS (
module AST,
- declToJs
+ declToJs,
+ moduleToJs
) where
-import Data.Char
-import Data.Maybe (fromMaybe, mapMaybe)
-import Data.List (intercalate)
+import Data.Maybe (mapMaybe)
import qualified Data.Map as M
-import qualified Control.Arrow as A
-import Control.Arrow ((<+>), second)
-import Control.Monad (forM)
-import Control.Applicative
+import Control.Arrow (second)
+import Control.Monad (replicateM, forM)
import Language.PureScript.TypeChecker (Environment, names)
-import Language.PureScript.Types
import Language.PureScript.Values
import Language.PureScript.Names
+import Language.PureScript.Scope
import Language.PureScript.Declarations
import Language.PureScript.Pretty.Common
import Language.PureScript.CodeGen.Monad
import Language.PureScript.CodeGen.JS.AST as AST
+import Language.PureScript.TypeChecker.Monad (NameKind(..))
-declToJs :: Maybe Ident -> ModulePath -> Declaration -> Environment -> Maybe [JS]
-declToJs mod mp (ValueDeclaration ident (Abs args ret)) _ =
- Just $ JSFunction (Just ident) args (JSBlock [JSReturn (valueToJs mp ret)]) :
- maybe [] (return . setProperty (identToJs ident) (JSVar ident)) mod
-declToJs mod mp (ValueDeclaration ident val) _ =
- Just $ JSVariableIntroduction ident (Just (valueToJs mp val)) :
- maybe [] (return . setProperty (identToJs 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) _ =
+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))) mod
-declToJs mod 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))) mod
-declToJs mod omp (ImportDeclaration mp idents) env =
- Just $ case idents of
- Nothing ->
- let idents = map snd . filter ((== mp) . fst) . M.keys $ names env
- in map mkLocal idents
- Just idents -> map mkLocal idents
- where mkLocal ident = JSVariableIntroduction ident (Just (qualifiedToJS identToJs (Qualified mp ident)))
-declToJs _ _ _ _ = Nothing
+ in [ ctorJs, setProperty ctor (JSVar (Ident ctor)) mp ]
+declToJs _ _ _ = Nothing
+
+setProperty :: String -> JS -> ModuleName -> JS
+setProperty prop val (ModuleName (ProperName moduleName)) = JSAssignment (JSAssignProperty prop (JSAssignVariable (Ident moduleName))) val
-setProperty :: String -> JS -> Ident -> JS
-setProperty prop val mod = JSAssignment (JSAssignProperty prop (JSAssignVariable mod)) val
+valueToJs :: ModuleName -> Environment -> Value -> JS
+valueToJs _ _ (NumericLiteral n) = JSNumericLiteral n
+valueToJs _ _ (StringLiteral s) = JSStringLiteral s
+valueToJs _ _ (BooleanLiteral b) = JSBooleanLiteral b
+valueToJs m e (ArrayLiteral xs) = JSArrayLiteral (map (valueToJs m e) xs)
+valueToJs m e (ObjectLiteral ps) = JSObjectLiteral (map (second (valueToJs m e)) ps)
+valueToJs m e (ObjectUpdate o ps) = JSApp (JSAccessor "extend" (JSVar (Ident "Object"))) [ valueToJs m e o, JSObjectLiteral (map (second (valueToJs m e)) ps)]
+valueToJs _ _ (Constructor name) = qualifiedToJS runProperName name
+valueToJs m e (Block sts) = JSApp (JSFunction Nothing [] (JSBlock (map (statementToJs m e) sts))) []
+valueToJs m e (Case values binders) = runGen (bindersToJs m e binders (map (valueToJs m e) values))
+valueToJs m e (IfThenElse cond th el) = JSConditional (valueToJs m e cond) (valueToJs m e th) (valueToJs m e el)
+valueToJs m e (Accessor prop val) = JSAccessor prop (valueToJs m e val)
+valueToJs m e (Indexer index val) = JSIndexer (valueToJs m e index) (valueToJs m e val)
+valueToJs m e (App val args) = JSApp (valueToJs m e val) (map (valueToJs m e) args)
+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) = varToJs m e ident
+valueToJs m e (TypedValue val _) = valueToJs m e val
+valueToJs _ _ _ = error "Invalid argument to valueToJs"
-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
+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)
+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 -> [(Binder, Value)] -> JS -> Gen JS
-bindersToJs m binders val = do
- valName <- fresh
- 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]
+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
+ jss <- forM binders $ \(bs, grd, result) -> go valNames [JSReturn (valueToJs m e result)] bs grd
+ return $ JSApp (JSFunction Nothing (map Ident valNames) (JSBlock (concat jss ++ [JSThrow (JSStringLiteral "Failed pattern match")])))
+ vals
+ where
+ go :: [String] -> [JS] -> [Binder] -> Maybe Guard -> Gen [JS]
+ go _ done [] Nothing = return done
+ go _ done [] (Just cond) = return [JSIfElse (valueToJs m e cond) (JSBlock done) Nothing]
+ go (v:vs) done' (b:bs) grd = do
+ done'' <- go vs done' bs grd
+ binderToJs m e v done'' b
+ go _ _ _ _ = error "Invalid arguments to bindersToJs"
-binderToJs :: ModulePath -> String -> [JS] -> Binder -> Gen [JS]
-binderToJs _ varName done NullBinder = return done
-binderToJs _ varName done (StringBinder str) =
+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]
-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) =
+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
+binderToJs m _ varName done (NullaryBinder ctor) =
+ 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 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
+ js <- binderToJs m e value done b
+ 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]
- go done [] = return done
- go done ((prop, binder):bs) = do
+ go done' [] = return done'
+ go done' ((prop, binder):bs') = do
propVar <- fresh
- done' <- go done bs
- js <- binderToJs m propVar done' binder
+ done'' <- go done' bs'
+ js <- binderToJs m e 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]
+binderToJs m e varName done (ArrayBinder bs) = do
+ js <- go done 0 bs
+ return [JSIfElse (JSBinary EqualTo (JSAccessor "length" (JSVar (Ident varName))) (JSNumericLiteral (Left (fromIntegral $ length bs)))) (JSBlock js) Nothing]
where
- cmp :: BinaryOperator
- cmp = maybe EqualTo (const GreaterThanOrEqualTo) rest
- go :: [JS] -> Maybe Binder -> Integer -> [Binder] -> Gen [JS]
- go done Nothing _ [] = return done
- go done (Just binder) index [] = do
- restVar <- fresh
- 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
+ go :: [JS] -> Integer -> [Binder] -> Gen [JS]
+ go done' _ [] = return done'
+ go done' index (binder:bs') = do
elVar <- fresh
- done' <- go done rest (index + 1) bs
- js <- binderToJs m elVar done' binder
+ done'' <- go done' (index + 1) bs'
+ js <- binderToJs m e 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
+binderToJs m e varName done (ConsBinder headBinder tailBinder) = do
+ headVar <- fresh
+ tailVar <- fresh
+ js1 <- binderToJs m e headVar done headBinder
+ js2 <- binderToJs m e tailVar js1 tailBinder
+ return [JSIfElse (JSBinary GreaterThan (JSAccessor "length" (JSVar (Ident varName))) (JSNumericLiteral (Left 0))) (JSBlock
+ ( JSVariableIntroduction (Ident headVar) (Just (JSIndexer (JSNumericLiteral (Left 0)) (JSVar (Ident varName)))) :
+ JSVariableIntroduction (Ident tailVar) (Just (JSApp (JSAccessor "slice" (JSVar (Ident varName))) [JSNumericLiteral (Left 1)])) :
+ js2
+ )) Nothing]
+binderToJs m e varName done (NamedBinder ident binder) = do
+ js <- binderToJs m e 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 m cond) (JSBlock done) Nothing]
-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
+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))
+statementToJs m e (For ident start end sts) = JSFor ident (valueToJs m e start) (valueToJs m e end) (JSBlock (map (statementToJs m e) sts))
+statementToJs m e (ForEach ident arr sts) = JSApp (JSAccessor "forEach" (valueToJs m e arr)) [JSFunction Nothing [ident] (JSBlock (map (statementToJs m e) sts))]
+statementToJs m e (If ifst) = ifToJs ifst
where
ifToJs :: IfStatement -> JS
- ifToJs (IfStatement cond thens elses) = JSIfElse (valueToJs m cond) (JSBlock (map (statementToJs m) thens)) (fmap elseToJs elses)
+ ifToJs (IfStatement cond thens elses) = JSIfElse (valueToJs m e cond) (JSBlock (map (statementToJs m e) thens)) (fmap elseToJs elses)
elseToJs :: ElseStatement -> JS
- elseToJs (Else sts) = JSBlock (map (statementToJs m) sts)
- elseToJs (ElseIf ifst) = ifToJs ifst
-statementToJs m (Return value) = JSReturn (valueToJs m value)
+ elseToJs (Else sts) = JSBlock (map (statementToJs m e) sts)
+ elseToJs (ElseIf elif) = ifToJs elif
+statementToJs m e (ValueStatement val) = valueToJs m e val
+statementToJs m e (Return value) = JSReturn (valueToJs m e value)
diff --git a/src/Language/PureScript/CodeGen/JS/AST.hs b/src/Language/PureScript/CodeGen/JS/AST.hs
index 59d34b5..ee8ad50 100644
--- a/src/Language/PureScript/CodeGen/JS/AST.hs
+++ b/src/Language/PureScript/CodeGen/JS/AST.hs
@@ -47,3 +47,5 @@ data JS
data JSAssignment
= JSAssignVariable Ident
| JSAssignProperty String JSAssignment deriving (Show, Data, Typeable)
+
+
diff --git a/src/Language/PureScript/CodeGen/Monad.hs b/src/Language/PureScript/CodeGen/Monad.hs
index 5cf876e..0ea9f5d 100644
--- a/src/Language/PureScript/CodeGen/Monad.hs
+++ b/src/Language/PureScript/CodeGen/Monad.hs
@@ -19,7 +19,7 @@ module Language.PureScript.CodeGen.Monad where
import Control.Monad.State
import Control.Applicative
-newtype Gen a = Gen { unGen :: State Int a } deriving (Functor, Applicative, Monad, MonadState Int)
+newtype Gen a = Gen { unGen :: State Int a } deriving (Functor, Applicative, Monad, MonadState Int, MonadFix)
runGen :: Gen a -> a
runGen = flip evalState 0 . unGen
@@ -29,3 +29,9 @@ fresh = do
n <- get
modify (+ 1)
return $ '_' : show n
+
+getNextName :: Gen Int
+getNextName = get
+
+setNextName :: Int -> Gen ()
+setNextName = put
diff --git a/src/Language/PureScript/Declarations.hs b/src/Language/PureScript/Declarations.hs
index 5457a73..89f744f 100644
--- a/src/Language/PureScript/Declarations.hs
+++ b/src/Language/PureScript/Declarations.hs
@@ -29,15 +29,18 @@ data Associativity = Infixl | Infixr deriving (Show, D.Data, D.Typeable)
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 Value
+ | 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)
diff --git a/src/Language/PureScript/Names.hs b/src/Language/PureScript/Names.hs
index 7bb47b3..219f5e5 100644
--- a/src/Language/PureScript/Names.hs
+++ b/src/Language/PureScript/Names.hs
@@ -17,7 +17,6 @@
module Language.PureScript.Names where
import Data.Data
-import Data.List (intercalate)
data Ident = Ident String | Op String deriving (Eq, Ord, Data, Typeable)
@@ -30,22 +29,17 @@ newtype ProperName = ProperName { runProperName :: String } deriving (Eq, Ord, D
instance Show ProperName where
show = runProperName
-data ModulePath = ModulePath [ProperName] deriving (Eq, Ord, Data, Typeable)
+data ModuleName = ModuleName ProperName deriving (Eq, Ord, Data, Typeable)
-instance Show ModulePath where
- show (ModulePath segments) = intercalate "." $ map show segments
+instance Show ModuleName where
+ show (ModuleName name) = show name
-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)
+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])
+ show (Qualified Nothing a) = show a
+ show (Qualified (Just (ModuleName name)) a) = show name ++ "." ++ show a
-qualify :: ModulePath -> Qualified a -> (ModulePath, a)
-qualify mp (Qualified (ModulePath []) a) = (mp, a)
-qualify _ (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)
diff --git a/src/Language/PureScript/Operators.hs b/src/Language/PureScript/Operators.hs
index f957315..c942f9d 100644
--- a/src/Language/PureScript/Operators.hs
+++ b/src/Language/PureScript/Operators.hs
@@ -22,7 +22,6 @@ import Language.PureScript.Names
import Language.PureScript.Declarations
import Language.PureScript.Values
-import qualified Data.Data as D
import Data.Function (on)
import Data.List (groupBy, sortBy)
import qualified Data.Map as M
@@ -34,12 +33,12 @@ import qualified Text.Parsec as P
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
@@ -57,18 +56,18 @@ customOperatorTable fixities =
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)
- parseChains val = return val
+ parseChains other = return other
extendChain :: Value -> Chain
extendChain (BinaryNoParens name l r) = Left l : Right name : extendChain r
- extendChain val = [Left val]
+ 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
@@ -81,27 +80,24 @@ parseValue = P.token show (const (P.initialPos "")) (either Just (const Nothing)
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)
diff --git a/src/Language/PureScript/Optimize.hs b/src/Language/PureScript/Optimize.hs
index c14034c..b9e2790 100644
--- a/src/Language/PureScript/Optimize.hs
+++ b/src/Language/PureScript/Optimize.hs
@@ -17,6 +17,7 @@ module Language.PureScript.Optimize (
) where
import Data.Data
+import Data.Maybe (fromMaybe)
import Data.Generics
import Language.PureScript.Names
@@ -29,7 +30,13 @@ replaceIdent :: (Data d) => Ident -> JS -> d -> d
replaceIdent var1 js = everywhere (mkT replace)
where
replace (JSVar var2) | var1 == var2 = js
- replace js = js
+ replace other = other
+
+replaceIdents :: (Data d) => [(Ident, JS)] -> d -> d
+replaceIdents vars = everywhere (mkT replace)
+ where
+ replace v@(JSVar var) = fromMaybe v $ lookup var vars
+ replace other = other
isReassigned :: (Data d) => Ident -> d -> Bool
isReassigned var1 = everything (||) (mkQ False check)
@@ -84,7 +91,8 @@ etaConvert :: JS -> JS
etaConvert = everywhere (mkT convert)
where
convert :: JS -> JS
- convert (JSBlock [JSReturn (JSApp (JSFunction Nothing [ident] (JSBlock body)) [arg])]) | shouldInline arg = JSBlock (replaceIdent ident arg body)
+ convert (JSBlock [JSReturn (JSApp (JSFunction Nothing idents (JSBlock body)) args)])
+ | all shouldInline args = JSBlock (replaceIdents (zip idents args) body)
convert js = js
unThunk :: JS -> JS
diff --git a/src/Language/PureScript/Parser/Common.hs b/src/Language/PureScript/Parser/Common.hs
index 7f202de..1e32d5f 100644
--- a/src/Language/PureScript/Parser/Common.hs
+++ b/src/Language/PureScript/Parser/Common.hs
@@ -16,14 +16,11 @@
module Language.PureScript.Parser.Common where
-import Data.Char (isSpace)
+import Data.Functor.Identity
import Control.Applicative
import Control.Monad
-import Control.Monad.State
import Language.PureScript.Parser.State
-import qualified Data.Map as M
import qualified Text.Parsec as P
-import qualified Text.Parsec.Pos as P
import qualified Text.Parsec.Token as PT
import Language.PureScript.Names
@@ -80,7 +77,7 @@ builtInOperators = [ "~", "-", "<=", ">=", "<", ">", "*", "/", "%", "++", "+", "
, "==", "!=", "&&", "||", "&", "^", "|", "!!", "!" ]
reservedOpNames :: [String]
-reservedOpNames = builtInOperators ++ [ "->" ]
+reservedOpNames = builtInOperators ++ [ "->", "=", "." ]
identStart :: P.Parsec String u Char
identStart = P.lower <|> P.oneOf "_$"
@@ -92,11 +89,12 @@ identLetter :: P.Parsec String u Char
identLetter = P.alphaNum <|> P.oneOf "_'"
opStart :: P.Parsec String u Char
-opStart = P.oneOf "!#$%&*+/<=>?@^|~"
+opStart = P.oneOf ":.!#%&*+/<=>?@^|~"
opLetter :: P.Parsec String u Char
-opLetter = P.oneOf ":#$%&*+./<=>?@^|"
+opLetter = P.oneOf ":.#$%&*+./<=>?@^|"
+langDef :: PT.GenLanguageDef String u Identity
langDef = PT.LanguageDef
{ PT.reservedNames = reservedNames
, PT.reservedOpNames = reservedOpNames
@@ -111,47 +109,90 @@ langDef = PT.LanguageDef
, PT.caseSensitive = True
}
+tokenParser :: PT.GenTokenParser String u Identity
tokenParser = PT.makeTokenParser langDef
-lexeme = PT.lexeme tokenParser
-identifier = PT.identifier tokenParser
-reserved = PT.reserved tokenParser
-reservedOp = PT.reservedOp tokenParser
-operator = PT.operator tokenParser
-stringLiteral = PT.stringLiteral tokenParser
-whiteSpace = PT.whiteSpace tokenParser
-squares = PT.squares tokenParser
-semi = PT.semi tokenParser
-comma = PT.comma tokenParser
-colon = PT.colon tokenParser
-dot = PT.dot tokenParser
-natural = PT.natural tokenParser
+lexeme :: P.Parsec String u a -> P.Parsec String u a
+lexeme = PT.lexeme tokenParser
+identifier :: P.Parsec String u String
+identifier = PT.identifier tokenParser
+
+reserved :: String -> P.Parsec String u ()
+reserved = PT.reserved tokenParser
+
+reservedOp :: String -> P.Parsec String u ()
+reservedOp = PT.reservedOp tokenParser
+
+operator :: P.Parsec String u String
+operator = PT.operator tokenParser
+
+stringLiteral :: P.Parsec String u String
+stringLiteral = PT.stringLiteral tokenParser
+
+whiteSpace :: P.Parsec String u ()
+whiteSpace = PT.whiteSpace tokenParser
+
+semi :: P.Parsec String u String
+semi = PT.semi tokenParser
+
+colon :: P.Parsec String u String
+colon = PT.colon tokenParser
+
+dot :: P.Parsec String u String
+dot = PT.dot tokenParser
+
+comma :: P.Parsec String u String
+comma = PT.comma tokenParser
+
+tick :: P.Parsec String u Char
+tick = lexeme $ P.char '`'
+
+pipe :: P.Parsec String u Char
+pipe = lexeme $ P.char '|'
+
+natural :: P.Parsec String u Integer
+natural = PT.natural tokenParser
+
+squares :: P.Parsec String ParseState a -> P.Parsec String ParseState a
+squares = P.between (lexeme $ P.char '[') (lexeme $ indented *> P.char ']') . (indented *>)
+
+parens :: P.Parsec String ParseState a -> P.Parsec String ParseState a
parens = P.between (lexeme $ P.char '(') (lexeme $ indented *> P.char ')') . (indented *>)
+
+braces :: P.Parsec String ParseState a -> P.Parsec String ParseState a
braces = P.between (lexeme $ P.char '{') (lexeme $ indented *> P.char '}') . (indented *>)
+
+angles :: P.Parsec String ParseState a -> P.Parsec String ParseState a
angles = P.between (lexeme $ P.char '<') (lexeme $ indented *> P.char '>') . (indented *>)
+sepBy :: P.Parsec String ParseState a -> P.Parsec String ParseState sep -> P.Parsec String ParseState [a]
sepBy p s = P.sepBy (indented *> p) (indented *> s)
+
+sepBy1 :: P.Parsec String ParseState a -> P.Parsec String ParseState sep -> P.Parsec String ParseState [a]
sepBy1 p s = P.sepBy1 (indented *> p) (indented *> s)
-semiSep = flip sepBy semi
-semiSep1 = flip sepBy1 semi
-commaSep = flip sepBy comma
-commaSep1 = flip sepBy1 comma
+semiSep :: P.Parsec String ParseState a -> P.Parsec String ParseState [a]
+semiSep = flip sepBy semi
-tick = lexeme $ P.char '`'
-pipe = lexeme $ P.char '|'
+semiSep1 :: P.Parsec String ParseState a -> P.Parsec String ParseState [a]
+semiSep1 = flip sepBy1 semi
+
+commaSep :: P.Parsec String ParseState a -> P.Parsec String ParseState [a]
+commaSep = flip sepBy comma
+
+commaSep1 :: P.Parsec String ParseState a -> P.Parsec String ParseState [a]
+commaSep1 = flip sepBy1 comma
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
+parseQualified parser = qual
where
- part path = (do name <- P.try (properName <* delimiter)
- part (subModule path name))
- <|> (Qualified path <$> P.try parser)
- delimiter = indented *> colon <* P.notFollowedBy colon
+ 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)
integerOrFloat = (Left <$> P.try (PT.natural tokenParser) <|>
@@ -166,8 +207,16 @@ fold first more combine = do
bs <- P.many more
return $ foldl combine a bs
-buildPostfixParser :: P.Stream s m t => [P.ParsecT s u m (a -> a)] -> P.ParsecT s u m a -> P.ParsecT s u m a
-buildPostfixParser f x = fold x (P.choice f) (flip ($))
+buildPostfixParser :: P.Stream s m t => [a -> P.ParsecT s u m a] -> P.ParsecT s u m a -> P.ParsecT s u m a
+buildPostfixParser fs first = do
+ a <- first
+ go a
+ where
+ go a = do
+ maybeA <- P.optionMaybe $ P.choice (map ($ a) fs)
+ case maybeA of
+ Nothing -> return a
+ Just a' -> go a'
operatorOrBuiltIn :: P.Parsec String u String
operatorOrBuiltIn = P.try operator <|> P.choice (map (\s -> P.try (reservedOp s) >> return s) builtInOperators)
diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs
index d8c270b..b1d5d77 100644
--- a/src/Language/PureScript/Parser/Declarations.hs
+++ b/src/Language/PureScript/Parser/Declarations.hs
@@ -14,29 +14,21 @@
module Language.PureScript.Parser.Declarations (
parseDeclaration,
- parseDeclarations
+ parseModule,
+ parseModules
) where
-import Data.Char
-import Data.List
-import Data.Maybe
-import Data.Function
import Control.Applicative
-import Control.Arrow (Arrow(..))
-import Control.Monad.State
-import qualified Data.Map as M
import qualified Text.Parsec as P
-import qualified Text.Parsec.Pos as P
import Language.PureScript.Names
-import Language.PureScript.Values
-import Language.PureScript.Types
import Language.PureScript.Parser.State
import Language.PureScript.Parser.Common
import Language.PureScript.Declarations
import Language.PureScript.Parser.Values
import Language.PureScript.Parser.Types
import Language.PureScript.Parser.Kinds
+import Language.PureScript.Values
parseDataDeclaration :: P.Parsec String ParseState Declaration
parseDataDeclaration = do
@@ -60,8 +52,13 @@ parseTypeSynonymDeclaration =
parseValueDeclaration :: P.Parsec String ParseState Declaration
parseValueDeclaration =
- ValueDeclaration <$> P.try (parseIdent <* lexeme (indented *> P.char '='))
- <*> parseValue
+ ValueDeclaration <$> parseIdent
+ <*> P.many parseTopLevelBinder
+ <*> P.optionMaybe parseGuard
+ <*> ((lexeme (indented *> P.char '=')) *> parseValue)
+
+parseTopLevelBinder :: P.Parsec String ParseState [Binder]
+parseTopLevelBinder = return <$> P.try parseBinderNoParens <|> parens (commaSep parseBinder)
parseExternDeclaration :: P.Parsec String ParseState Declaration
parseExternDeclaration = P.try (reserved "foreign") *> indented *> (reserved "import") *> indented *>
@@ -88,25 +85,13 @@ parseFixityDeclaration = do
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
@@ -116,8 +101,16 @@ parseDeclaration = P.choice
, 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
diff --git a/src/Language/PureScript/Parser/State.hs b/src/Language/PureScript/Parser/State.hs
index 94cf567..e20cb1d 100644
--- a/src/Language/PureScript/Parser/State.hs
+++ b/src/Language/PureScript/Parser/State.hs
@@ -14,11 +14,7 @@
module Language.PureScript.Parser.State where
-import Language.PureScript.Names
-import Language.PureScript.Declarations
-
import qualified Text.Parsec as P
-import qualified Data.Map as M
data ParseState = ParseState
{ indentationLevel :: P.Column } deriving Show
diff --git a/src/Language/PureScript/Parser/Types.hs b/src/Language/PureScript/Parser/Types.hs
index 6fa2ba4..d2bb873 100644
--- a/src/Language/PureScript/Parser/Types.hs
+++ b/src/Language/PureScript/Parser/Types.hs
@@ -24,7 +24,6 @@ import Language.PureScript.Parser.Common
import Control.Applicative
import qualified Text.Parsec as P
import qualified Text.Parsec.Expr as P
-import Control.Arrow (Arrow(..))
import Control.Monad (unless)
parseNumber :: P.Parsec String ParseState Type
@@ -75,8 +74,8 @@ parseTypeAtom = indented *> P.choice (map P.try
parseAnyType :: P.Parsec String ParseState Type
parseAnyType = (P.buildExpressionParser operators . buildPostfixParser postfixTable $ parseTypeAtom) P.<?> "type"
where
- postfixTable :: [P.Parsec String ParseState (Type -> Type)]
- postfixTable = [ flip TypeApp <$> P.try (indented *> parseTypeAtom) ]
+ postfixTable :: [Type -> P.Parsec String ParseState Type]
+ postfixTable = [ \x -> TypeApp x <$> P.try (indented *> parseTypeAtom) ]
operators = [ [ P.Infix (lexeme (P.try (P.string "->")) >> return (\t1 t2 -> Function [t1] t2)) P.AssocRight ] ]
parseType :: P.Parsec String ParseState Type
diff --git a/src/Language/PureScript/Parser/Values.hs b/src/Language/PureScript/Parser/Values.hs
index d1ae1a8..465b5f2 100644
--- a/src/Language/PureScript/Parser/Values.hs
+++ b/src/Language/PureScript/Parser/Values.hs
@@ -14,25 +14,18 @@
module Language.PureScript.Parser.Values (
parseValue,
- parseBinder
+ parseGuard,
+ parseBinder,
+ parseBinderNoParens
) where
import Language.PureScript.Values
-import Language.PureScript.Names
-import Language.PureScript.Declarations
import Language.PureScript.Parser.State
-import Data.Function (on)
-import Data.List
-import Data.Functor.Identity
-import qualified Data.Map as M
import qualified Language.PureScript.Parser.Common as C
import Control.Applicative
import qualified Text.Parsec as P
import Text.Parsec.Expr
-import Control.Monad
-import Control.Arrow (Arrow(..))
import Language.PureScript.Parser.Types
-import Language.PureScript.Types
booleanLiteral :: P.Parsec String ParseState Bool
booleanLiteral = (C.reserved "true" >> return True) P.<|> (C.reserved "false" >> return False)
@@ -74,10 +67,6 @@ parseAbs = do
toFunction [] value = Abs [] value
toFunction args value = foldr (($)) value args
-parseApp :: P.Parsec String ParseState Value
-parseApp = App <$> parseValue
- <*> (C.indented *> C.parens (C.commaSep parseValue))
-
parseVar :: P.Parsec String ParseState Value
parseVar = Var <$> C.parseQualified C.parseIdent
@@ -85,13 +74,14 @@ parseConstructor :: P.Parsec String ParseState Value
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
+parseCase = Case <$> P.between (P.try (C.reserved "case")) (C.indented *> C.reserved "of") (return <$> parseValue)
<*> (C.indented *> C.mark (P.many (C.same *> C.mark parseCaseAlternative)))
-parseCaseAlternative :: P.Parsec String ParseState (Binder, Value)
-parseCaseAlternative = (,) <$> (parseGuardedBinder <* C.lexeme (P.string "->"))
- <*> parseValue
- P.<?> "case alternative"
+parseCaseAlternative :: P.Parsec String ParseState ([Binder], Maybe Guard, Value)
+parseCaseAlternative = (,,) <$> (return <$> parseBinder)
+ <*> P.optionMaybe parseGuard
+ <*> (C.lexeme (P.string "->") *> parseValue)
+ P.<?> "case alternative"
parseIfThenElse :: P.Parsec String ParseState Value
parseIfThenElse = IfThenElse <$> (P.try (C.reserved "if") *> C.indented *> parseValue)
@@ -99,18 +89,23 @@ parseIfThenElse = IfThenElse <$> (P.try (C.reserved "if") *> C.indented *> parse
<*> (C.indented *> C.reserved "else" *> C.indented *> parseValue)
parseBlock :: P.Parsec String ParseState Value
-parseBlock = Block <$> (P.try (C.reserved "do") *> parseManyStatements)
+parseBlock = Block <$> parseManyStatements
parseManyStatements :: P.Parsec String ParseState [Statement]
-parseManyStatements = C.indented *> C.mark (P.many (C.same *> C.mark parseStatement)) P.<?> "block"
+parseManyStatements = (do
+ C.lexeme $ P.char '{'
+ C.indented
+ sts <- C.mark (P.many (C.same *> C.mark parseStatement))
+ C.lexeme (P.char '}')
+ return sts) P.<?> "block"
parseValueAtom :: P.Parsec String ParseState Value
-parseValueAtom = C.indented *> P.choice
+parseValueAtom = P.choice
[ P.try parseNumericLiteral
, P.try parseStringLiteral
, P.try parseBooleanLiteral
, parseArrayLiteral
- , parseObjectLiteral
+ , P.try parseObjectLiteral
, parseAbs
, P.try parseConstructor
, P.try parseVar
@@ -126,6 +121,10 @@ parsePropertyUpdate = do
value <- C.indented *> parseValue
return (name, value)
+parseAccessor :: Value -> P.Parsec String ParseState Value
+parseAccessor (Constructor _) = P.unexpected "constructor"
+parseAccessor obj = P.try $ Accessor <$> (C.indented *> C.dot *> P.notFollowedBy C.opLetter *> C.indented *> C.identifier) <*> pure obj
+
parseValue :: P.Parsec String ParseState Value
parseValue =
(buildExpressionParser operators
@@ -133,11 +132,11 @@ parseValue =
$ indexersAndAccessors) P.<?> "expression"
where
indexersAndAccessors = C.buildPostfixParser postfixTable1 parseValueAtom
- postfixTable1 = [ Accessor <$> (C.indented *> C.dot *> C.indented *> C.identifier)
- , P.try $ flip ObjectUpdate <$> (C.indented *> C.braces (C.commaSep1 (C.indented *> parsePropertyUpdate))) ]
- postfixTable2 = [ P.try (C.indented *> indexersAndAccessors >>= \t2 -> return (\t1 -> App t1 [t2]))
- , P.try $ flip App <$> (C.indented *> C.parens (C.commaSep parseValue))
- , flip TypedValue <$> (P.try (C.lexeme (C.indented *> P.string "::")) *> parsePolyType) ]
+ postfixTable1 = [ parseAccessor
+ , \v -> P.try $ flip ObjectUpdate <$> (C.indented *> C.braces (C.commaSep1 (C.indented *> parsePropertyUpdate))) <*> pure v ]
+ postfixTable2 = [ \v -> P.try (C.indented *> indexersAndAccessors >>= \t2 -> return (\t1 -> App t1 [t2])) <*> pure v
+ , \v -> P.try $ flip App <$> (C.indented *> C.parens (C.commaSep parseValue)) <*> pure v
+ , \v -> flip TypedValue <$> (P.try (C.lexeme (C.indented *> P.string "::")) *> parsePolyType) <*> pure v ]
operators = [ [ Prefix $ C.lexeme (P.try $ C.indented *> C.reservedOp "!") >> return (Unary Not)
, Prefix $ C.lexeme (P.try $ C.indented *> C.reservedOp "~") >> return (Unary BitwiseNot)
, Prefix $ C.lexeme (P.try $ C.indented *> C.reservedOp "-") >> return (Unary Negate)
@@ -152,28 +151,32 @@ parseVariableIntroduction = do
name <- C.indented *> C.parseIdent
C.lexeme $ C.indented *> P.char '='
value <- parseValue
+ C.indented *> C.semi
return $ VariableIntroduction name value
parseAssignment :: P.Parsec String ParseState Statement
parseAssignment = do
- tgt <- C.parseIdent
- C.lexeme $ C.indented *> P.char '='
+ tgt <- P.try $ do
+ tgt <- C.parseIdent
+ C.lexeme $ C.indented *> P.char '='
+ return tgt
value <- parseValue
+ C.indented *> C.semi
return $ Assignment tgt value
parseWhile :: P.Parsec String ParseState Statement
-parseWhile = While <$> (C.reserved "while" *> C.indented *> parseValue <* C.indented <* C.colon)
- <*> parseManyStatements
+parseWhile = While <$> (C.reserved "while" *> C.indented *> C.parens parseValue)
+ <*> (C.indented *> parseManyStatements)
parseFor :: P.Parsec String ParseState Statement
-parseFor = For <$> (C.reserved "for" *> C.indented *> C.parseIdent)
+parseFor = For <$> (C.reserved "for" *> C.indented *> C.lexeme (P.char '(') *> C.indented *> C.parseIdent)
<*> (C.indented *> C.lexeme (P.string "<-") *> parseValue)
- <*> (C.indented *> C.reserved "until" *> parseValue <* C.colon)
+ <*> (C.indented *> C.reserved "until" *> parseValue <* C.indented <* C.lexeme (P.char ')'))
<*> parseManyStatements
parseForEach :: P.Parsec String ParseState Statement
-parseForEach = ForEach <$> (C.reserved "foreach" *> C.indented *> C.parseIdent)
- <*> (C.indented *> C.reserved "in" *> parseValue <* C.colon)
+parseForEach = ForEach <$> (C.reserved "foreach" *> C.indented *> C.lexeme (P.char '(') *> C.indented *> C.parseIdent)
+ <*> (C.indented *> C.reserved "in" *> parseValue <* C.lexeme (P.char ')'))
<*> parseManyStatements
parseIf :: P.Parsec String ParseState Statement
@@ -181,26 +184,30 @@ parseIf = If <$> parseIfStatement
parseIfStatement :: P.Parsec String ParseState IfStatement
parseIfStatement =
- IfStatement <$> (C.reserved "if" *> C.indented *> parseValue <* C.indented <* C.colon)
+ IfStatement <$> (C.reserved "if" *> C.indented *> C.parens parseValue)
<*> parseManyStatements
- <*> P.optionMaybe (C.same *> parseElseStatement)
+ <*> P.optionMaybe parseElseStatement
parseElseStatement :: P.Parsec String ParseState ElseStatement
-parseElseStatement = C.reserved "else" >> (ElseIf <$> (C.indented *> parseIfStatement)
- <|> Else <$> (C.indented *> C.colon *> parseManyStatements))
+parseElseStatement = C.reserved "else" >> (ElseIf <$> parseIfStatement
+ <|> Else <$> parseManyStatements)
+
+parseValueStatement :: P.Parsec String ParseState Statement
+parseValueStatement = ValueStatement <$> (parseValue <* C.semi)
parseReturn :: P.Parsec String ParseState Statement
-parseReturn = Return <$> (C.reserved "return" *> parseValue)
+parseReturn = Return <$> (C.reserved "return" *> parseValue <* C.indented <* C.semi)
parseStatement :: P.Parsec String ParseState Statement
-parseStatement = P.choice (map P.try
+parseStatement = P.choice
[ parseVariableIntroduction
, parseAssignment
, parseWhile
, parseFor
, parseForEach
, parseIf
- , parseReturn ]) P.<?> "statement"
+ , parseValueStatement
+ , parseReturn ] P.<?> "statement"
parseStringBinder :: P.Parsec String ParseState Binder
parseStringBinder = StringBinder <$> C.stringLiteral
@@ -225,7 +232,6 @@ parseObjectBinder = ObjectBinder <$> C.braces (C.commaSep (C.indented *> parseId
parseArrayBinder :: P.Parsec String ParseState Binder
parseArrayBinder = C.squares $ ArrayBinder <$> (C.commaSep (C.indented *> parseBinder))
- <*> P.optionMaybe (C.indented *> C.colon *> C.indented *> parseBinder)
parseNamedBinder :: P.Parsec String ParseState Binder
parseNamedBinder = NamedBinder <$> (C.parseIdent <* C.indented <* C.lexeme (P.char '@'))
@@ -241,8 +247,8 @@ parseIdentifierAndBinder = do
binder <- C.indented *> parseBinder
return (name, binder)
-parseBinder :: P.Parsec String ParseState Binder
-parseBinder = P.choice (map P.try
+parseBinderAtom :: P.Parsec String ParseState Binder
+parseBinderAtom = P.choice (map P.try
[ parseNullBinder
, parseStringBinder
, parseBooleanBinder
@@ -255,5 +261,24 @@ parseBinder = P.choice (map P.try
, parseArrayBinder
, C.parens parseBinder ]) P.<?> "binder"
-parseGuardedBinder :: P.Parsec String ParseState Binder
-parseGuardedBinder = flip ($) <$> parseBinder <*> P.option id (GuardedBinder <$> (C.indented *> C.lexeme (P.char '|') *> C.indented *> parseValue))
+parseBinder :: P.Parsec String ParseState Binder
+parseBinder = (buildExpressionParser operators parseBinderAtom) P.<?> "expression"
+ where
+ operators = [ [ Infix ( C.lexeme (P.try $ C.indented *> C.reservedOp ":") >> return ConsBinder) AssocRight ] ]
+
+parseBinderNoParens :: P.Parsec String ParseState Binder
+parseBinderNoParens = P.choice (map P.try
+ [ parseNullBinder
+ , parseStringBinder
+ , parseBooleanBinder
+ , parseNumberBinder
+ , parseNamedBinder
+ , parseVarBinder
+ , parseNullaryBinder
+ , parseObjectBinder
+ , parseArrayBinder
+ , C.parens parseBinder ]) P.<?> "binder"
+
+parseGuard :: P.Parsec String ParseState Guard
+parseGuard = C.indented *> C.pipe *> C.indented *> parseValue
+
diff --git a/src/Language/PureScript/Pretty/Common.hs b/src/Language/PureScript/Pretty/Common.hs
index 602e5b6..d9cf69d 100644
--- a/src/Language/PureScript/Pretty/Common.hs
+++ b/src/Language/PureScript/Pretty/Common.hs
@@ -17,20 +17,13 @@
module Language.PureScript.Pretty.Common where
import Data.Char
-import Data.Maybe (fromMaybe)
-import Data.List (nub, intersperse, intercalate)
-import Data.Function (fix)
import Control.Monad.State
-import Control.Applicative (Applicative(..), Alternative(..))
import qualified Control.Category as C
import Control.Category ((>>>))
import qualified Control.Arrow as A
import Control.Arrow ((***), (<+>))
import Language.PureScript.Names
-import Language.PureScript.Values
-import Language.PureScript.Types
-import Language.PureScript.Declarations
identToJs :: Ident -> String
identToJs (Ident name) = name
@@ -57,16 +50,16 @@ parens :: String -> String
parens s = ('(':s) ++ ")"
chainl :: Pattern u a (a, a) -> (r -> r -> r) -> Pattern u a r -> Pattern u a r
-chainl split f p = fix $ \c -> split >>> ((c <+> p) *** p) >>> A.arr (uncurry f)
+chainl g f p = fix $ \c -> g >>> ((c <+> p) *** p) >>> A.arr (uncurry f)
chainr :: Pattern u a (a, a) -> (r -> r -> r) -> Pattern u a r -> Pattern u a r
-chainr split f p = fix $ \c -> split >>> (p *** (c <+> p)) >>> A.arr (uncurry f)
+chainr g f p = fix $ \c -> g >>> (p *** (c <+> p)) >>> A.arr (uncurry f)
wrap :: Pattern u a (s, a) -> (s -> r -> r) -> Pattern u a r -> Pattern u a r
-wrap split f p = fix $ \c -> split >>> (C.id *** (c <+> p)) >>> A.arr (uncurry f)
+wrap g f p = fix $ \c -> g >>> (C.id *** (c <+> p)) >>> A.arr (uncurry f)
-split :: Pattern u a (s, t) -> (s -> t -> r) -> Pattern u a r -> Pattern u a r
-split s f p = s >>> A.arr (uncurry f)
+split :: Pattern u a (s, t) -> (s -> t -> r) -> Pattern u a r
+split s f = s >>> A.arr (uncurry f)
data OperatorTable u a r = OperatorTable { runOperatorTable :: [ [Operator u a r] ] }
@@ -82,5 +75,5 @@ buildPrettyPrinter table p = foldl (\p' ops -> foldl1 (<+>) (flip map ops $ \op
AssocL pat g -> chainl pat g p'
AssocR pat g -> chainr pat g p'
Wrap pat g -> wrap pat g p'
- Split pat g -> split pat g p'
+ Split pat g -> split pat g
) <+> p') p $ runOperatorTable table
diff --git a/src/Language/PureScript/Pretty/JS.hs b/src/Language/PureScript/Pretty/JS.hs
index 5d33ab1..1f07652 100644
--- a/src/Language/PureScript/Pretty/JS.hs
+++ b/src/Language/PureScript/Pretty/JS.hs
@@ -24,7 +24,7 @@ import Language.PureScript.CodeGen.JS.AST
import Data.List
import Data.Maybe (fromMaybe)
import qualified Control.Arrow as A
-import Control.Arrow ((***), (<+>), first, second)
+import Control.Arrow ((<+>))
import Control.Applicative
import Control.Monad.State
@@ -34,11 +34,10 @@ blockIndent :: Int
blockIndent = 4
withIndent :: StateT PrinterState Maybe String -> StateT PrinterState Maybe String
-withIndent s = do
- current <- get
- modify $ \s -> s { indent = indent s + blockIndent }
- result <- s
- modify $ \s -> s { indent = indent s - blockIndent }
+withIndent action = do
+ modify $ \st -> st { indent = indent st + blockIndent }
+ result <- action
+ modify $ \st -> st { indent = indent st - blockIndent }
return result
currentIndent :: StateT PrinterState Maybe String
@@ -158,22 +157,22 @@ app = mkPattern' match
match _ = mzero
unary :: UnaryOperator -> String -> Operator PrinterState JS String
-unary op str = Wrap pattern (++)
+unary op str = Wrap match (++)
where
- pattern :: Pattern PrinterState JS (String, JS)
- pattern = mkPattern match
+ match :: Pattern PrinterState JS (String, JS)
+ match = mkPattern match'
where
- match (JSUnary op' val) | op' == op = Just (str, val)
- match _ = Nothing
+ match' (JSUnary op' val) | op' == op = Just (str, val)
+ match' _ = Nothing
binary :: BinaryOperator -> String -> Operator PrinterState JS String
-binary op str = AssocR pattern (\v1 v2 -> v1 ++ " " ++ str ++ " " ++ v2)
+binary op str = AssocR match (\v1 v2 -> v1 ++ " " ++ str ++ " " ++ v2)
where
- pattern :: Pattern PrinterState JS (JS, JS)
- pattern = mkPattern match
+ match :: Pattern PrinterState JS (JS, JS)
+ match = mkPattern match'
where
- match (JSBinary op' v1 v2) | op' == op = Just (v1, v2)
- match _ = Nothing
+ match' (JSBinary op' v1 v2) | op' == op = Just (v1, v2)
+ match' _ = Nothing
prettyPrintJS1 :: JS -> String
prettyPrintJS1 = fromMaybe (error "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyPrintJS'
diff --git a/src/Language/PureScript/Pretty/Kinds.hs b/src/Language/PureScript/Pretty/Kinds.hs
index a1c9883..822d6a1 100644
--- a/src/Language/PureScript/Pretty/Kinds.hs
+++ b/src/Language/PureScript/Pretty/Kinds.hs
@@ -17,15 +17,11 @@ module Language.PureScript.Pretty.Kinds (
) where
import Data.Maybe (fromMaybe)
-import Data.List (intersperse, intercalate)
-import qualified Control.Arrow as A
-import Control.Arrow ((<+>))
-import qualified Data.Map as M
-import Control.Applicative
import Language.PureScript.Kinds
import Language.PureScript.Pretty.Common
import Language.PureScript.Unknown
+import Control.Arrow (ArrowPlus(..))
typeLiterals :: Pattern () Kind String
typeLiterals = mkPattern match
diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs
index 1babcc0..bd93195 100644
--- a/src/Language/PureScript/Pretty/Types.hs
+++ b/src/Language/PureScript/Pretty/Types.hs
@@ -18,17 +18,10 @@ module Language.PureScript.Pretty.Types (
) where
import Data.Maybe (fromMaybe)
-import Data.List (intersperse, intercalate)
-import qualified Control.Arrow as A
+import Data.List (intercalate)
import Control.Arrow ((<+>))
-import qualified Data.Map as M
-import Control.Applicative
-import Language.PureScript.Values
import Language.PureScript.Types
-import Language.PureScript.Names
-import Language.PureScript.Declarations
-import Language.PureScript.TypeChecker.Monad
import Language.PureScript.Pretty.Common
import Language.PureScript.Unknown
@@ -49,7 +42,7 @@ typeLiterals = mkPattern match
match _ = Nothing
prettyPrintRow :: Row -> String
-prettyPrintRow = (\(tys, tail) -> intercalate ", " (map (uncurry nameAndTypeToPs) tys) ++ tailToPs tail) . toList []
+prettyPrintRow = (\(tys, rest) -> intercalate ", " (map (uncurry nameAndTypeToPs) tys) ++ tailToPs rest) . toList []
where
nameAndTypeToPs :: String -> Type -> String
nameAndTypeToPs name ty = name ++ " :: " ++ prettyPrintType ty
@@ -58,6 +51,7 @@ prettyPrintRow = (\(tys, tail) -> intercalate ", " (map (uncurry nameAndTypeToPs
tailToPs (RUnknown (Unknown u)) = " | u" ++ show u
tailToPs (RowVar var) = " | " ++ var
tailToPs (RSkolem s) = " | s" ++ show s
+ tailToPs _ = error "Invalid row tail"
toList :: [(String, Type)] -> Row -> ([(String, Type)], Row)
toList tys (RCons name ty row) = toList ((name, ty):tys) row
toList tys r = (tys, r)
diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs
index f37c29a..f9c6d81 100644
--- a/src/Language/PureScript/Pretty/Values.hs
+++ b/src/Language/PureScript/Pretty/Values.hs
@@ -17,16 +17,12 @@ module Language.PureScript.Pretty.Values (
prettyPrintBinder
) where
-import Data.Char
import Data.Maybe (fromMaybe)
import Data.List (intercalate)
-import qualified Control.Arrow as A
import Control.Arrow ((<+>))
-import Control.Applicative
import Language.PureScript.Types
import Language.PureScript.Values
-import Language.PureScript.Names
import Language.PureScript.Pretty.Common
import Language.PureScript.Pretty.Types
@@ -41,12 +37,14 @@ literals = mkPattern match
match (ObjectLiteral ps) = Just $ "{" ++ intercalate ", " (map (uncurry prettyPrintObjectProperty) ps) ++ "}"
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 (Case values binders) = Just $ "case " ++ intercalate " " (map prettyPrintValue values) ++
+ " of { " ++ intercalate " ; " (map prettyPrintCaseAlternative binders) ++ " }"
match (Var ident) = Just $ show ident
match _ = Nothing
-prettyPrintCaseAlternative :: Binder -> Value -> String
-prettyPrintCaseAlternative binder val = prettyPrintBinder binder ++ " -> " ++ prettyPrintValue val
+prettyPrintCaseAlternative :: ([Binder], Maybe Guard, Value) -> String
+prettyPrintCaseAlternative (binders, grd, val) = "(" ++ intercalate ", " (map prettyPrintBinder binders) ++ ") " ++
+ (maybe "" (("| " ++) . prettyPrintValue) grd) ++ " -> " ++ prettyPrintValue val
ifThenElse :: Pattern () Value ((Value, Value), Value)
ifThenElse = mkPattern match
@@ -91,22 +89,22 @@ typed = mkPattern match
match _ = Nothing
unary :: UnaryOperator -> String -> Operator () Value String
-unary op str = Wrap pattern (++)
+unary op str = Wrap match (++)
where
- pattern :: Pattern () Value (String, Value)
- pattern = mkPattern match
+ match :: Pattern () Value (String, Value)
+ match = mkPattern match'
where
- match (Unary op' val) | op' == op = Just (str, val)
- match _ = Nothing
+ match' (Unary op' val) | op' == op = Just (str, val)
+ match' _ = Nothing
binary :: BinaryOperator -> String -> Operator () Value String
-binary op str = AssocR pattern (\v1 v2 -> v1 ++ " " ++ str ++ " " ++ v2)
+binary op str = AssocR match (\v1 v2 -> v1 ++ " " ++ str ++ " " ++ v2)
where
- pattern :: Pattern () Value (Value, Value)
- pattern = mkPattern match
+ match :: Pattern () Value (Value, Value)
+ match = mkPattern match'
where
- match (Binary op' v1 v2) | op' == op = Just (v1, v2)
- match _ = Nothing
+ match' (Binary op' v1 v2) | op' == op = Just (v1, v2)
+ match' _ = Nothing
prettyPrintValue :: Value -> String
prettyPrintValue = fromMaybe (error "Incomplete pattern") . pattern matchValue ()
@@ -147,19 +145,37 @@ prettyPrintValue = fromMaybe (error "Incomplete pattern") . pattern matchValue (
, [ binary Or "||" ]
]
+prettyPrintBinderAtom :: Pattern () Binder String
+prettyPrintBinderAtom = mkPattern match
+ where
+ match :: Binder -> Maybe String
+ match NullBinder = Just "_"
+ match (StringBinder str) = Just $ show str
+ match (NumberBinder num) = Just $ either show show num
+ match (BooleanBinder True) = Just "true"
+ match (BooleanBinder False) = Just "false"
+ match (VarBinder ident) = Just $ show ident
+ match (NullaryBinder ctor) = Just $ show ctor
+ match (UnaryBinder ctor b) = Just $ show ctor ++ " " ++ prettyPrintBinder b
+ match (ObjectBinder bs) = Just $ "{ " ++ intercalate ", " (map (uncurry prettyPrintObjectPropertyBinder) bs) ++ " }"
+ match (ArrayBinder bs) = Just $ "[ " ++ intercalate ", " (map prettyPrintBinder bs) ++ " ]"
+ match (NamedBinder ident binder) = Just $ show ident ++ "@" ++ prettyPrintBinder binder
+ match _ = Nothing
+
prettyPrintBinder :: Binder -> String
-prettyPrintBinder NullBinder = "_"
-prettyPrintBinder (StringBinder str) = show str
-prettyPrintBinder (NumberBinder num) = either show show num
-prettyPrintBinder (BooleanBinder True) = "true"
-prettyPrintBinder (BooleanBinder False) = "false"
-prettyPrintBinder (VarBinder ident) = show ident
-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
-prettyPrintBinder (GuardedBinder cond binder) = prettyPrintBinder binder ++ " | " ++ prettyPrintValue cond
+prettyPrintBinder = fromMaybe (error "Incomplete pattern") . pattern matchBinder ()
+ where
+ matchBinder :: Pattern () Binder String
+ matchBinder = buildPrettyPrinter operators (prettyPrintBinderAtom <+> fmap parens matchBinder)
+ operators :: OperatorTable () Binder String
+ operators =
+ OperatorTable [ [ AssocR matchConsBinder (\b1 b2 -> b1 ++ " : " ++ b2) ] ]
+
+matchConsBinder :: Pattern () Binder (Binder, Binder)
+matchConsBinder = mkPattern match'
+ where
+ match' (ConsBinder b1 b2) = Just (b1, b2)
+ match' _ = Nothing
prettyPrintObjectPropertyBinder :: String -> Binder -> String
prettyPrintObjectPropertyBinder key binder = key ++ ": " ++ prettyPrintBinder binder
@@ -179,6 +195,7 @@ prettyPrintStatement (ForEach ident arr sts) = "foreach " ++ show ident
++ " in " ++ prettyPrintValue arr ++ ": {"
++ intercalate "; " (map prettyPrintStatement sts) ++ " }"
prettyPrintStatement (If ifst) = prettyPrintIfStatement ifst
+prettyPrintStatement (ValueStatement val) = prettyPrintValue val
prettyPrintStatement (Return value) = "return " ++ prettyPrintValue value
prettyPrintIfStatement :: IfStatement -> String
diff --git a/src/Language/PureScript/Scope.hs b/src/Language/PureScript/Scope.hs
new file mode 100644
index 0000000..af6eaa3
--- /dev/null
+++ b/src/Language/PureScript/Scope.hs
@@ -0,0 +1,75 @@
+-----------------------------------------------------------------------------
+--
+-- Module : Language.PureScript.Scope
+-- Copyright : (c) Phil Freeman 2013
+-- License : MIT
+--
+-- Maintainer : Phil Freeman <paf31@cantab.net>
+-- Stability : experimental
+-- Portability :
+--
+-- |
+--
+-----------------------------------------------------------------------------
+
+module Language.PureScript.Scope (
+ usedNames,
+ unusedNames,
+ firstUnusedName
+) where
+
+import Data.Data
+import Data.List ((\\), nub)
+import Data.Generics (extQ, mkQ, everything)
+
+import Language.PureScript.Values
+import Language.PureScript.Names
+import Language.PureScript.CodeGen.JS.AST
+import Data.Maybe (mapMaybe)
+
+usedNames :: (Data d) => d -> [Ident]
+usedNames val = nub $ everything (++) (mkQ [] namesV `extQ` namesS `extQ` namesB `extQ` namesJS) val
+ where
+ namesV :: Value -> [Ident]
+ namesV (Abs args _) = args
+ namesV (Var (Qualified Nothing name)) = [name]
+ namesV _ = []
+ namesS :: Statement -> [Ident]
+ namesS (VariableIntroduction name _) = [name]
+ namesS (For name _ _ _) = [name]
+ namesS _ = []
+ namesB :: Binder -> [Ident]
+ namesB (VarBinder name) = [name]
+ namesB _ = []
+ namesJS :: JS -> [Ident]
+ namesJS (JSVar name) = [name]
+ namesJS (JSFunction (Just name) args _) = name : args
+ namesJS (JSFunction Nothing args _) = args
+ namesJS (JSVariableIntroduction name _) = [name]
+ namesJS (JSFor name _ _ _) = [name]
+ namesJS _ = []
+
+unusedNames :: (Data d) => d -> [Ident]
+unusedNames val =
+ let
+ allNames = usedNames val
+ varNames = map (Ident . ('_' :) . show) ([1..] :: [Int])
+ in
+ varNames \\ allNames
+
+firstUnusedName :: (Data d) => d -> Int
+firstUnusedName val =
+ let
+ allNames = usedNames val
+ varNames = mapMaybe toUnknown allNames
+ in
+ 1 + maximum (0 : varNames)
+ where
+ toUnknown :: Ident -> Maybe Int
+ toUnknown (Ident ('_' : s)) = readMaybe s
+ toUnknown _ = Nothing
+
+readMaybe :: String -> Maybe Int
+readMaybe s = case reads s of
+ [(n, "")] -> Just n
+ _ -> Nothing
diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs
index eff76f7..01526bd 100644
--- a/src/Language/PureScript/TypeChecker.hs
+++ b/src/Language/PureScript/TypeChecker.hs
@@ -24,118 +24,175 @@ import Language.PureScript.TypeChecker.Kinds as T
import Language.PureScript.TypeChecker.Types as T
import Language.PureScript.TypeChecker.Synonyms as T
-import Data.List
import Data.Maybe
-import Data.Function
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 (forM_)
-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
+
+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) }
-typeCheckAll :: [Declaration] -> Check ()
-typeCheckAll [] = return ()
-typeCheckAll (DataDeclaration name args dctors : rest) = do
+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' val : rest) | name == name' =
- typeCheckAll (ValueDeclaration name (TypedValue val ty) : rest)
-typeCheckAll (TypeDeclaration name _ : _) = throwError $ "Orphan type declaration for " ++ show name
-typeCheckAll (ValueDeclaration name 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 ty -> 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 (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 _ ty) = isSingleArgumentFunction ty
+ 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 =
- forM_ idents $ \ident -> do
+ 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
+
diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs
index 94f4600..5b468ac 100644
--- a/src/Language/PureScript/TypeChecker/Kinds.hs
+++ b/src/Language/PureScript/TypeChecker/Kinds.hs
@@ -15,29 +15,23 @@
{-# LANGUAGE DeriveDataTypeable #-}
module Language.PureScript.TypeChecker.Kinds (
+ kindOf,
kindsOf,
- kindOf
+ kindsOfAll
) where
-import Data.List
-import Data.Maybe (fromMaybe)
-import Data.Function
-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
import Language.PureScript.Unknown
import Control.Monad.State
import Control.Monad.Error
+import Control.Monad.Reader
import Control.Applicative
-import Control.Arrow (Kleisli(..), (***))
-import qualified Control.Category as C
import qualified Data.Map as M
@@ -61,14 +55,31 @@ instance Unifiable Kind where
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
@@ -78,55 +89,51 @@ starIfUnknown (KUnknown _) = Star
starIfUnknown (FunKind k1 k2) = FunKind (starIfUnknown k1) (starIfUnknown k2)
starIfUnknown k = k
-inferAll :: Maybe (ProperName, Kind) -> M.Map String Kind -> [Type] -> Subst Check [Kind]
-inferAll name m = mapM (infer name m)
-
-infer :: Maybe (ProperName, Kind) -> M.Map String Kind -> Type -> Subst Check 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 $ \k -> 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)) m c@(TypeConstructor v@(Qualified (ModulePath []) pn)) | name == pn = return k
-infer name m (TypeConstructor v) = do
- env <- lift getEnv
- modulePath <- checkModulePath `fmap` lift get
- case M.lookup (qualify modulePath v) (types env) of
+infer (TypeVar v) = do
+ moduleName <- substCurrentModule <$> ask
+ lookupTypeVariable moduleName (Qualified Nothing (ProperName v))
+infer (TypeConstructor v) = do
+ env <- liftCheck getEnv
+ 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 _ m t = 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 Check Kind
-inferRow _ m (RowVar v) = do
- case M.lookup v m of
- Just k -> return k
- Nothing -> throwError $ "Unbound row variable " ++ v
-inferRow _ m r@REmpty = return Row
-inferRow name m r@(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"
diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs
index 213708b..700754a 100644
--- a/src/Language/PureScript/TypeChecker/Monad.hs
+++ b/src/Language/PureScript/TypeChecker/Monad.hs
@@ -25,53 +25,97 @@ import Language.PureScript.Unknown
import Data.Data
import Data.Maybe
import Data.Monoid
-import Data.Typeable
import Control.Applicative
import Control.Monad.State
import Control.Monad.Error
-
-import Control.Arrow ((***), first, second)
+import Control.Monad.Reader
import qualified Data.Map as M
-data NameKind = Value | Extern | Alias ModulePath Ident 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 (ModuleName, Ident) (Type, NameKind) -> m a -> m a
+bindNames newNames action = do
+ 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
+
+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
+
+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
+ 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 }
deriving (Functor, Monad, Applicative, MonadPlus, MonadState CheckState, MonadError String)
-getEnv :: Check Environment
-getEnv = fmap checkEnv get
+getEnv :: (Functor m, MonadState CheckState m) => m Environment
+getEnv = checkEnv <$> get
-putEnv :: Environment -> Check ()
+putEnv :: (MonadState CheckState m) => Environment -> m ()
putEnv env = modify (\s -> s { checkEnv = env })
-modifyEnv :: (Environment -> Environment) -> Check ()
+modifyEnv :: (MonadState CheckState m) => (Environment -> Environment) -> m ()
modifyEnv f = modify (\s -> s { checkEnv = f (checkEnv s) })
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 ()
@@ -81,14 +125,6 @@ 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
-
newtype Substitution = Substitution { runSubstitution :: forall t. (Unifiable t) => Unknown t -> t }
instance Monoid Substitution where
@@ -98,14 +134,23 @@ instance Monoid Substitution where
data SubstState = SubstState { substSubst :: Substitution
, substFutureEscapeChecks :: [AnyUnifiable] }
-newtype Subst m a = Subst { unSubst :: StateT SubstState m a }
- deriving (Functor, Monad, Applicative, MonadPlus, MonadTrans)
+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)
-deriving instance (MonadError String m) => MonadError String (Subst m)
+instance MonadState CheckState Subst where
+ get = Subst . lift . lift $ get
+ put = Subst . lift . lift . put
-runSubst :: (Unifiable a, Monad m) => Subst m a -> m (a, Substitution, [AnyUnifiable])
-runSubst subst = do
- (a, s) <- flip runStateT (SubstState mempty []) . unSubst $ subst
+deriving instance MonadError String Subst
+
+liftCheck :: Check a -> Subst a
+liftCheck = Subst . lift . lift
+
+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
@@ -119,7 +164,7 @@ substituteOne u t = substituteWith $ \u1 ->
u2 | u2 == u -> t
| otherwise -> unknown u2
-replace :: (Unifiable t) => Unknown t -> t -> Subst Check ()
+replace :: (Unifiable t) => Unknown t -> t -> Subst ()
replace u t' = do
sub <- substSubst <$> Subst get
let t = apply sub t'
@@ -132,25 +177,32 @@ replace u t' = do
class (Typeable t, Data t, Show t) => Unifiable t where
unknown :: Unknown t -> t
- (~~) :: t -> t -> Subst Check ()
+ (~~) :: t -> t -> Subst ()
isUnknown :: t -> Maybe (Unknown t)
apply :: Substitution -> t -> t
unknowns :: t -> [Int]
-occursCheck :: (Unifiable t) => Unknown s -> t -> Subst Check ()
+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 =
case isUnknown t of
Nothing -> guardWith "Occurs check fails" (u `notElem` unknowns t)
_ -> return ()
-fresh' :: Subst Check Int
+fresh' :: Subst Int
fresh' = do
- n <- lift $ checkNextVar <$> get
- lift . modify $ \s -> s { checkNextVar = succ (checkNextVar s) }
+ n <- checkNextVar <$> get
+ modify $ \s -> s { checkNextVar = succ (checkNextVar s) }
return n
-fresh :: (Unifiable t) => Subst Check t
+fresh :: (Unifiable t) => Subst t
fresh = unknown . Unknown <$> fresh'
-escapeCheckLater :: (Unifiable t) => t -> Subst Check ()
+escapeCheckLater :: (Unifiable t) => t -> Subst ()
escapeCheckLater t = Subst . modify $ \s -> s { substFutureEscapeChecks = AnyUnifiable t : substFutureEscapeChecks s }
diff --git a/src/Language/PureScript/TypeChecker/Synonyms.hs b/src/Language/PureScript/TypeChecker/Synonyms.hs
index 0c990b7..a415f20 100644
--- a/src/Language/PureScript/TypeChecker/Synonyms.hs
+++ b/src/Language/PureScript/TypeChecker/Synonyms.hs
@@ -18,34 +18,31 @@ module Language.PureScript.TypeChecker.Synonyms (
) where
import Language.PureScript.Types
-import Language.PureScript.Declarations
import Language.PureScript.Names
import Data.Maybe (fromMaybe)
import Data.Data
import Data.Generics
import Data.Generics.Extras
-import Control.Arrow
import Control.Monad.Writer
import Control.Monad.Error
-import qualified Data.Map as M
-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 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 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 (\d (name, n) -> saturateTypeSynonym name n d) 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
diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
index 8f5b2f2..36c2b73 100644
--- a/src/Language/PureScript/TypeChecker/Types.hs
+++ b/src/Language/PureScript/TypeChecker/Types.hs
@@ -12,19 +12,18 @@
--
-----------------------------------------------------------------------------
-{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveDataTypeable, FlexibleContexts #-}
module Language.PureScript.TypeChecker.Types (
- typeOf
+ typesOf
) where
import Data.List
-import Data.Maybe (isJust, fromMaybe)
-import Data.Function
+import Data.Maybe (fromMaybe)
+import Data.Either (lefts, rights)
import qualified Data.Data as D
import Data.Generics
- (something, everywhere, everywhereM, everything, everywhereBut,
- mkT, mkM, mkQ, extM, extQ)
+ (mkT, something, everywhere, everywhereBut, mkQ, extQ)
import Language.PureScript.Values
import Language.PureScript.Types
@@ -38,10 +37,10 @@ import Language.PureScript.Unknown
import Control.Monad.State
import Control.Monad.Error
+import Control.Monad.Reader
import Control.Applicative
-import Control.Arrow (Arrow(..), Kleisli(..), (***), (&&&), second)
-import qualified Control.Category as C
+import Control.Arrow (Arrow(..))
import qualified Data.Map as M
@@ -60,7 +59,7 @@ instance Unifiable Type where
apply _ t = t
unknowns (TUnknown (Unknown u)) = [u]
unknowns (SaturatedTypeSynonym _ tys) = concatMap unknowns tys
- unknowns (ForAll idents ty) = unknowns ty
+ unknowns (ForAll _ ty) = unknowns ty
unknowns (Array t) = unknowns t
unknowns (Object r) = unknowns r
unknowns (Function args ret) = concatMap unknowns args ++ unknowns ret
@@ -82,19 +81,19 @@ instance Unifiable Row where
forM_ int (uncurry (~~))
unifyRows sd1 r1' sd2 r2'
where
- unifyRows :: [(String, Type)] -> Row -> [(String, Type)] -> Row -> Subst Check ()
+ unifyRows :: [(String, Type)] -> Row -> [(String, Type)] -> Row -> Subst ()
unifyRows [] (RUnknown u) sd r = replace u (rowFromList (sd, r))
unifyRows sd r [] (RUnknown u) = replace u (rowFromList (sd, r))
- unifyRows ns@((name, ty):row) r others u@(RUnknown un) = do
+ unifyRows ((name, ty):row) r others u@(RUnknown un) = do
occursCheck un ty
- forM row $ \(_, ty) -> occursCheck un ty
+ forM row $ \(_, t) -> occursCheck un t
u' <- fresh
u ~~ RCons name ty u'
unifyRows row r others u'
unifyRows [] REmpty [] REmpty = return ()
unifyRows [] (RowVar v1) [] (RowVar v2) | v1 == v2 = return ()
unifyRows [] (RSkolem s1) [] (RSkolem s2) | s1 == s2 = return ()
- unifyRows sd1 r1 sd2 r2 = throwError $ "Cannot unify " ++ prettyPrintRow (rowFromList (sd1, r1)) ++ " with " ++ prettyPrintRow (rowFromList (sd2, r2)) ++ "."
+ unifyRows sd3 r3 sd4 r4 = throwError $ "Cannot unify " ++ prettyPrintRow (rowFromList (sd3, r3)) ++ " with " ++ prettyPrintRow (rowFromList (sd4, r4)) ++ "."
apply s (RUnknown u) = runSubstitution s u
apply s (RCons name ty r) = RCons name (apply s ty) (apply s r)
apply _ r = r
@@ -102,7 +101,7 @@ instance Unifiable Row where
unknowns (RCons _ ty r) = unknowns ty ++ unknowns r
unknowns _ = []
-unifyTypes :: Type -> Type -> Subst Check ()
+unifyTypes :: Type -> Type -> Subst ()
unifyTypes t1 t2 = rethrow (\e -> "Error unifying type " ++ prettyPrintType t1 ++ " with type " ++ prettyPrintType t2 ++ ":\n" ++ e) $ do
unifyTypes' t1 t2
where
@@ -117,7 +116,7 @@ unifyTypes t1 t2 = rethrow (\e -> "Error unifying type " ++ prettyPrintType t1 +
unifyTypes' ty s@(SaturatedTypeSynonym _ _) = s `unifyTypes` ty
unifyTypes' (ForAll ident1 ty1) (ForAll ident2 ty2) = do
sk <- skolemize ident1 ty1
- replaced <- replaceVarsWithUnknowns [ident2] ty2
+ replaced <- replaceVarWithUnknown ident2 ty2
sk `unifyTypes` replaced
unifyTypes' (ForAll ident ty1) ty2 = do
sk <- skolemize ident ty1
@@ -134,46 +133,64 @@ unifyTypes t1 t2 = rethrow (\e -> "Error unifying type " ++ prettyPrintType t1 +
ret1 `unifyTypes` ret2
unifyTypes' (TypeVar v1) (TypeVar v2) | v1 == v2 = return ()
unifyTypes' (TypeConstructor c1) (TypeConstructor c2) = do
- modulePath <- checkModulePath `fmap` lift get
- guardWith ("Cannot unify " ++ show c1 ++ " with " ++ show c2 ++ ".") (qualify modulePath c1 == qualify modulePath c2)
- unifyTypes' (TypeApp t1 t2) (TypeApp t3 t4) = do
- t1 `unifyTypes` t3
- t2 `unifyTypes` t4
+ 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' t1 t2 = throwError $ "Cannot unify " ++ prettyPrintType t1 ++ " with " ++ prettyPrintType t2 ++ "."
-
-isFunction :: Value -> Bool
-isFunction (Abs _ _) = True
-isFunction (TypedValue untyped _) = isFunction untyped
-isFunction _ = False
-
-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 val ty -> do
- kind <- lift $ kindOf ty
- guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star
- ty' <- lift $ replaceAllTypeSynonyms ty
- check (M.singleton ident ty) val ty'
- return ty'
- _ -> do
- me <- fresh
- ty <- infer (M.singleton ident me) val
- ty ~~ me
- return ty
- _ -> infer M.empty val
- escapeCheck checks ty sub
- skolemEscapeCheck ty
- return $ varIfUnknown $ desaturateAllTypeSynonyms $ setifyAll ty
+ unifyTypes' t3 t4 = throwError $ "Cannot unify " ++ prettyPrintType t3 ++ " with " ++ prettyPrintType t4 ++ "."
+
+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
+
+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
visibleUnknowns = nub $ unknowns ty
in
- forM_ checks $ \check -> case check of
+ forM_ checks $ \c -> case c of
AnyUnifiable t -> do
let unsolvedUnknowns = nub . unknowns $ apply sub t
guardWith "Escape check fails" $ null $ unsolvedUnknowns \\ visibleUnknowns
@@ -196,120 +213,110 @@ setifyAll :: (D.Data d) => d -> d
setifyAll = everywhere (mkT setify)
varIfUnknown :: Type -> Type
-varIfUnknown ty = mkForAll (sort . map ((:) 'u' . show) . nub $ unknowns ty) ty
+varIfUnknown ty =
+ let unks = nub $ unknowns ty
+ toName = (:) 't' . show
+ ty' = everywhere (mkT rowToVar) . everywhere (mkT typeToVar) $ ty
+ typeToVar :: Type -> Type
+ typeToVar (TUnknown (Unknown u)) = TypeVar (toName u)
+ typeToVar t = t
+ rowToVar :: Row -> Row
+ rowToVar (RUnknown (Unknown u)) = RowVar (toName u)
+ rowToVar t = t
+ in mkForAll (sort . map toName $ unks) ty'
replaceAllTypeVars :: (D.Data d) => [(String, Type)] -> d -> d
replaceAllTypeVars = foldl' (\f (name, ty) -> replaceTypeVars name ty . f) id
replaceTypeVars :: (D.Data d) => String -> Type -> d -> d
-replaceTypeVars name t = everywhereBut (mkQ False isShadowed) (mkT replace)
+replaceTypeVars name t = everywhereBut (mkQ False isShadowed) (mkT replaceTypeVar)
where
- replace (TypeVar v) | v == name = t
- replace t = t
+ replaceTypeVar (TypeVar v) | v == name = t
+ replaceTypeVar other = other
isShadowed (ForAll v _) | v == name = True
isShadowed _ = False
replaceRowVars :: (D.Data d) => String -> Row -> d -> d
-replaceRowVars name r = everywhere (mkT replace)
+replaceRowVars name r = everywhere (mkT replaceRowVar)
where
- replace (RowVar v) | v == name = r
- replace t = t
+ replaceRowVar (RowVar v) | v == name = r
+ replaceRowVar other = other
-replaceAllVarsWithUnknowns :: Type -> Subst Check Type
-replaceAllVarsWithUnknowns (ForAll ident ty) = replaceVarsWithUnknowns [ident] ty >>= replaceAllVarsWithUnknowns
+replaceAllVarsWithUnknowns :: Type -> Subst Type
+replaceAllVarsWithUnknowns (ForAll ident ty) = replaceVarWithUnknown ident ty >>= replaceAllVarsWithUnknowns
replaceAllVarsWithUnknowns ty = return ty
-replaceVarsWithUnknowns :: [String] -> Type -> Subst Check Type
-replaceVarsWithUnknowns idents = flip evalStateT M.empty . everywhereM (flip extM f $ mkM g)
- where
- f :: Type -> StateT (M.Map String Int) (Subst Check) Type
- f (TypeVar var) | var `elem` idents = do
- m <- get
- n <- lift fresh'
- case M.lookup var m of
- Nothing -> do
- put (M.insert var n m)
- return $ TUnknown (Unknown n)
- Just u -> return $ TUnknown (Unknown u)
- f t = return t
- g :: Row -> StateT (M.Map String Int) (Subst Check) Row
- g (RowVar var) | var `elem` idents = do
- m <- get
- n <- lift fresh'
- case M.lookup var m of
- Nothing -> do
- put (M.insert var n m)
- return $ RUnknown (Unknown n)
- Just u -> return $ RUnknown (Unknown u)
- g r = return r
+replaceVarWithUnknown :: String -> Type -> Subst Type
+replaceVarWithUnknown ident ty = do
+ tu <- fresh
+ ru <- fresh
+ return $ replaceRowVars ident ru . replaceTypeVars ident tu $ ty
-replaceAllTypeSynonyms :: (D.Data d) => d -> Check 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 replace)
+desaturateAllTypeSynonyms = everywhere (mkT replaceSaturatedTypeSynonym)
where
- replace (SaturatedTypeSynonym name args) = foldl TypeApp (TypeConstructor name) args
- replace t = t
-
-expandAllTypeSynonyms :: Type -> Subst Check Type
-expandAllTypeSynonyms (SaturatedTypeSynonym name args) = expandTypeSynonym name args >>= expandAllTypeSynonyms
-expandAllTypeSynonyms ty = return ty
+ replaceSaturatedTypeSynonym (SaturatedTypeSynonym name args) = foldl TypeApp (TypeConstructor name) args
+ replaceSaturatedTypeSynonym t = t
-expandTypeSynonym :: Qualified ProperName -> [Type] -> Subst Check Type
+expandTypeSynonym :: Qualified ProperName -> [Type] -> Subst Type
expandTypeSynonym name args = do
- env <- lift getEnv
- modulePath <- checkModulePath `fmap` lift get
- case M.lookup (qualify modulePath name) (typeSynonyms env) of
+ env <- getEnv
+ 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"
-ensureNoDuplicateProperties :: [(String, Value)] -> Check ()
+ensureNoDuplicateProperties :: (MonadError String m) => [(String, Value)] -> m ()
ensureNoDuplicateProperties ps = guardWith "Duplicate property names" $ length (nub . map fst $ ps) == length ps
-infer :: M.Map Ident Type -> Value -> Subst Check Type
-infer m val = rethrow (\e -> "Error inferring type of term " ++ prettyPrintValue val ++ ":\n" ++ e) $ do
- ty <- infer' m val
+infer :: Value -> Subst Type
+infer val = rethrow (\e -> "Error inferring type of term " ++ prettyPrintValue val ++ ":\n" ++ e) $ do
+ ty <- infer' val
escapeCheckLater ty
return ty
-infer' _ (NumericLiteral _) = return Number
-infer' _ (StringLiteral _) = return String
-infer' _ (BooleanLiteral _) = return Boolean
-infer' m (ArrayLiteral vals) = do
- ts <- mapM (infer m) vals
- arr <- fresh
- forM_ ts $ \t -> arr ~~ Array t
- return arr
-infer' m (Unary op val) = do
- t <- infer m val
+infer' :: Value -> Subst Type
+infer' (NumericLiteral _) = return Number
+infer' (StringLiteral _) = return String
+infer' (BooleanLiteral _) = return Boolean
+infer' (ArrayLiteral vals) = do
+ ts <- mapM (infer) vals
+ els <- fresh
+ forM_ ts $ \t -> els ~~ Array t
+ return els
+infer' (Unary op val) = do
+ t <- infer val
inferUnary op t
-infer' m (Binary op left right) = do
- t1 <- infer m left
- t2 <- infer m right
+infer' (Binary op left right) = do
+ t1 <- infer left
+ t2 <- infer right
inferBinary op t1 t2
-infer' m (ObjectLiteral ps) = do
- lift $ ensureNoDuplicateProperties ps
- ts <- mapM (infer m . snd) ps
+infer' (ObjectLiteral ps) = do
+ ensureNoDuplicateProperties ps
+ ts <- mapM (infer . snd) ps
let fields = zipWith (\(name, _) t -> (name, t)) ps ts
return $ Object $ rowFromList (fields, REmpty)
-infer' m (ObjectUpdate o ps) = do
- lift $ ensureNoDuplicateProperties ps
+infer' (ObjectUpdate o ps) = do
+ ensureNoDuplicateProperties ps
row <- fresh
- newTys <- zipWith (\(name, _) t -> (name, t)) ps <$> mapM (infer m . snd) ps
+ newTys <- zipWith (\(name, _) t -> (name, t)) ps <$> mapM (infer . snd) ps
oldTys <- zip (map fst ps) <$> replicateM (length ps) fresh
- check m o $ Object $ rowFromList (oldTys, row)
+ check o $ Object $ rowFromList (oldTys, row)
return $ Object $ rowFromList (newTys, row)
-infer' m (Indexer index val) = do
+infer' (Indexer index val) = do
el <- fresh
- check m index Number
- check m val (Array el)
+ check index Number
+ check val (Array el)
return el
-infer' m (Accessor prop val) = do
- obj <- infer m val
+infer' (Accessor prop val) = do
+ obj <- infer val
propTy <- inferProperty obj prop
case propTy of
Nothing -> do
@@ -318,61 +325,54 @@ infer' m (Accessor prop val) = do
obj `subsumes` Object (RCons prop field rest)
return field
Just ty -> return ty
-infer' m (Abs args ret) = do
+infer' (Abs args ret) = do
ts <- replicateM (length args) fresh
- let m' = m `M.union` M.fromList (zip args ts)
- body <- infer m' ret
- return $ Function ts body
-infer' m app@(App _ _) = do
+ moduleName <- substCurrentModule <$> ask
+ bindLocalVariables moduleName (zip args ts) $ do
+ body <- infer' ret
+ return $ Function ts body
+infer' app@(App _ _) = do
let (f, argss) = unfoldApplication app
- ft <- infer m f
+ ft <- infer f
ret <- fresh
- checkFunctionApplications m ft argss ret
+ checkFunctionApplications ft argss ret
return ret
-infer' m (Var var@(Qualified mp name)) = do
- case mp of
- ModulePath [] ->
- case M.lookup name m of
- Just ty -> lift $ replaceAllTypeSynonyms ty
- Nothing -> lookupGlobal
- _ -> lookupGlobal
- where
- lookupGlobal = do
- env <- lift getEnv
- modulePath <- checkModulePath `fmap` lift get
- case M.lookup (qualify modulePath var) (names env) of
- Nothing -> throwError $ show var ++ " is undefined"
- Just (ty, _) -> lift $ replaceAllTypeSynonyms ty
-infer' m (Block ss) = do
+infer' (Var var) = do
+ moduleName <- substCurrentModule <$> ask
+ ty <- lookupVariable moduleName var
+ replaceAllTypeSynonyms ty
+infer' (Block ss) = do
ret <- fresh
- (allCodePathsReturn, _) <- checkBlock m M.empty ret ss
+ (allCodePathsReturn, _) <- checkBlock M.empty ret ss
guardWith "Block is missing a return statement" allCodePathsReturn
return ret
-infer' m (Constructor c) = do
- env <- lift getEnv
- modulePath <- checkModulePath `fmap` lift get
- case M.lookup (qualify modulePath c) (dataConstructors env) of
+infer' (Constructor c) = do
+ env <- getEnv
+ moduleName <- substCurrentModule `fmap` ask
+ case M.lookup (qualify moduleName c) (dataConstructors env) of
Nothing -> throwError $ "Constructor " ++ show c ++ " is undefined"
- Just ty -> lift $ replaceAllTypeSynonyms ty
-infer' m (Case val binders) = do
- t1 <- infer m val
+ Just ty -> replaceAllTypeSynonyms ty
+infer' (Case vals binders) = do
+ ts <- mapM infer vals
ret <- fresh
- checkBinders m t1 ret binders
+ checkBinders ts ret binders
return ret
-infer' m (IfThenElse cond th el) = do
- check m cond Boolean
- t2 <- infer m th
- t3 <- infer m el
+infer' (IfThenElse cond th el) = do
+ check cond Boolean
+ t2 <- infer th
+ t3 <- infer el
t2 ~~ t3
return t2
-infer' m (TypedValue val ty) = do
- kind <- lift $ kindOf ty
+infer' (TypedValue val ty) = do
+ moduleName <- substCurrentModule <$> ask
+ kind <- liftCheck $ kindOf moduleName ty
guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star
- ty' <- lift $ replaceAllTypeSynonyms ty
- check m val ty'
+ ty' <- replaceAllTypeSynonyms ty
+ check val ty'
return ty'
+infer' _ = error "Invalid argument to infer"
-inferProperty :: Type -> String -> Subst Check (Maybe Type)
+inferProperty :: Type -> String -> Subst (Maybe Type)
inferProperty (Object row) prop = do
let (props, _) = rowToList row
return $ lookup prop props
@@ -380,23 +380,23 @@ inferProperty (SaturatedTypeSynonym name args) prop = do
replaced <- expandTypeSynonym name args
inferProperty replaced prop
inferProperty (ForAll ident ty) prop = do
- replaced <- replaceVarsWithUnknowns [ident] ty
+ replaced <- replaceVarWithUnknown ident ty
inferProperty replaced prop
-inferProperty _ prop = return Nothing
+inferProperty _ _ = return Nothing
-inferUnary :: UnaryOperator -> Type -> Subst Check Type
+inferUnary :: UnaryOperator -> Type -> Subst Type
inferUnary op val =
case fromMaybe (error "Invalid operator") $ lookup op unaryOps of
(valTy, resTy) -> do
val ~~ valTy
return resTy
-checkUnary :: M.Map Ident Type -> UnaryOperator -> Value -> Type -> Subst Check ()
-checkUnary m op val res =
+checkUnary :: UnaryOperator -> Value -> Type -> Subst ()
+checkUnary op val res =
case fromMaybe (error "Invalid operator") $ lookup op unaryOps of
(valTy, resTy) -> do
res ~~ resTy
- check m val valTy
+ check val valTy
unaryOps :: [(UnaryOperator, (Type, Type))]
unaryOps = [ (Negate, (Number, Number))
@@ -404,7 +404,7 @@ unaryOps = [ (Negate, (Number, Number))
, (BitwiseNot, (Number, Number))
]
-inferBinary :: BinaryOperator -> Type -> Type -> Subst Check Type
+inferBinary :: BinaryOperator -> Type -> Type -> Subst Type
inferBinary op left right | isEqualityTest op = do
left ~~ right
return Boolean
@@ -415,18 +415,18 @@ inferBinary op left right =
right ~~ valTy
return resTy
-checkBinary :: M.Map Ident Type -> BinaryOperator -> Value -> Value -> Type -> Subst Check ()
-checkBinary m op left right res | isEqualityTest op = do
+checkBinary :: BinaryOperator -> Value -> Value -> Type -> Subst ()
+checkBinary op left right res | isEqualityTest op = do
res ~~ Boolean
- t1 <- infer m left
- t2 <- infer m right
+ t1 <- infer left
+ t2 <- infer right
t1 ~~ t2
-checkBinary m op left right res =
+checkBinary op left right res =
case fromMaybe (error "Invalid operator") $ lookup op binaryOps of
(valTy, resTy) -> do
res ~~ resTy
- check m left valTy
- check m right valTy
+ check left valTy
+ check right valTy
isEqualityTest :: BinaryOperator -> Bool
isEqualityTest EqualTo = True
@@ -454,28 +454,31 @@ binaryOps = [ (Add, (Number, Number))
, (GreaterThanOrEqualTo, (Number, Boolean))
]
-inferBinder :: Type -> Binder -> Subst Check (M.Map Ident Type)
+inferBinder :: Type -> Binder -> Subst (M.Map Ident Type)
inferBinder _ NullBinder = return M.empty
inferBinder val (StringBinder _) = val ~~ String >> return M.empty
inferBinder val (NumberBinder _) = val ~~ Number >> return M.empty
inferBinder val (BooleanBinder _) = val ~~ Boolean >> return M.empty
inferBinder val (VarBinder name) = return $ M.singleton name val
inferBinder val (NullaryBinder ctor) = do
- env <- lift getEnv
- modulePath <- checkModulePath `fmap` lift get
- case M.lookup (qualify modulePath ctor) (dataConstructors env) of
+ env <- getEnv
+ 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 <- lift getEnv
- modulePath <- checkModulePath `fmap` lift get
- case M.lookup (qualify modulePath ctor) (dataConstructors env) of
+ env <- getEnv
+ moduleName <- substCurrentModule <$> ask
+ case M.lookup (qualify moduleName ctor) (dataConstructors env) of
Just ty -> do
- Function [obj] ret <- replaceAllVarsWithUnknowns ty
- val `subsumes` ret
- inferBinder obj binder
+ fn <- replaceAllVarsWithUnknowns ty
+ case fn of
+ Function [obj] ret -> do
+ val `subsumes` ret
+ inferBinder obj binder
+ _ -> throwError $ "Constructor " ++ show ctor ++ " is not a unary constructor"
_ -> throwError $ "Constructor " ++ show ctor ++ " is not defined"
inferBinder val (ObjectBinder props) = do
row <- fresh
@@ -484,117 +487,121 @@ inferBinder val (ObjectBinder props) = do
val ~~ Object row
return m1
where
- inferRowProperties :: Row -> Row -> [(String, Binder)] -> Subst Check (M.Map Ident Type)
+ inferRowProperties :: Row -> Row -> [(String, Binder)] -> Subst (M.Map Ident Type)
inferRowProperties nrow row [] = nrow ~~ row >> return M.empty
inferRowProperties nrow row ((name, binder):binders) = do
propTy <- fresh
m1 <- inferBinder propTy binder
m2 <- inferRowProperties nrow (RCons name propTy row) binders
return $ m1 `M.union` m2
-inferBinder val (ArrayBinder binders rest) = do
+inferBinder val (ArrayBinder binders) = do
el <- fresh
m1 <- M.unions <$> mapM (inferBinder el) binders
val ~~ Array el
- case rest of
- Nothing -> return m1
- Just binder -> do
- m2 <- inferBinder val binder
- return $ m1 `M.union` m2
+ return m1
+inferBinder val (ConsBinder headBinder tailBinder) = do
+ el <- fresh
+ m1 <- inferBinder el headBinder
+ m2 <- inferBinder val tailBinder
+ val ~~ Array el
+ return $ m1 `M.union` m2
inferBinder val (NamedBinder name binder) = do
m <- inferBinder val binder
return $ M.insert name val m
-inferGuardedBinder :: M.Map Ident Type -> Type -> Binder -> Subst Check (M.Map Ident Type)
-inferGuardedBinder m val (GuardedBinder cond binder) = do
- m1 <- inferBinder val binder
- check (m1 `M.union` m) cond Boolean
- return m1
-inferGuardedBinder m val b = inferBinder val b
-
-checkBinders :: M.Map Ident Type -> Type -> Type -> [(Binder, Value)] -> Subst Check ()
-checkBinders _ _ _ [] = return ()
-checkBinders m nval ret ((binder, val):bs) = do
- m1 <- inferGuardedBinder m nval binder
- check (m1 `M.union` m) val ret
- checkBinders m nval ret bs
-
-assignVariable :: Ident -> M.Map Ident Type -> Subst Check ()
-assignVariable name m =
- case M.lookup name m of
- Nothing -> return ()
- Just _ -> throwError $ "Variable with name " ++ show name ++ " already exists."
-
-checkStatement :: M.Map Ident Type -> M.Map Ident Type -> Type -> Statement -> Subst Check (Bool, M.Map Ident Type)
-checkStatement m mass ret (VariableIntroduction name val) = do
- assignVariable name (m `M.union` mass)
- t <- infer m val
+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 moduleName (M.toList m1) $ do
+ check val ret
+ case grd of
+ Nothing -> return ()
+ Just g -> check g Boolean
+ checkBinders nvals ret bs
+
+assignVariable :: Ident -> Subst ()
+assignVariable name = do
+ env <- checkEnv <$> get
+ moduleName <- substCurrentModule <$> ask
+ case M.lookup (moduleName, name) (names env) of
+ Just (_, LocalVariable) -> throwError $ "Variable with name " ++ show name ++ " already exists."
+ _ -> return ()
+
+checkStatement :: M.Map Ident Type -> Type -> Statement -> Subst (Bool, M.Map Ident Type)
+checkStatement mass _ (VariableIntroduction name val) = do
+ assignVariable name
+ t <- infer val
return (False, M.insert name t mass)
-checkStatement m mass ret (Assignment ident val) = do
- t <- infer m val
+checkStatement mass _ (Assignment ident val) = do
+ t <- infer val
case M.lookup ident mass of
Nothing -> throwError $ "No local variable with name " ++ show ident
Just ty -> do t ~~ ty
return (False, mass)
-checkStatement m mass ret (While val inner) = do
- check m val Boolean
- (allCodePathsReturn, _) <- checkBlock m mass ret inner
+checkStatement mass ret (While val inner) = do
+ check val Boolean
+ (allCodePathsReturn, _) <- checkBlock mass ret inner
return (allCodePathsReturn, mass)
-checkStatement m mass ret (If ifst) = do
- allCodePathsReturn <- checkIfStatement m mass ret ifst
+checkStatement mass ret (If ifst) = do
+ allCodePathsReturn <- checkIfStatement mass ret ifst
return (allCodePathsReturn, mass)
-checkStatement m mass ret (For ident start end inner) = do
- assignVariable ident (m `M.union` mass)
- check (m `M.union` mass) start Number
- check (m `M.union` mass) end Number
- let mass1 = M.insert ident Number mass
- (allCodePathsReturn, _) <- checkBlock (m `M.union` mass1) mass1 ret inner
+checkStatement mass ret (For ident start end inner) = do
+ moduleName <- substCurrentModule <$> ask
+ assignVariable ident
+ check start Number
+ check end Number
+ (allCodePathsReturn, _) <- bindLocalVariables moduleName [(ident, Number)] $ checkBlock mass ret inner
return (allCodePathsReturn, mass)
-checkStatement m mass ret (ForEach ident vals inner) = do
- assignVariable ident (m `M.union` mass)
+checkStatement mass ret (ForEach ident vals inner) = do
+ moduleName <- substCurrentModule <$> ask
+ assignVariable ident
val <- fresh
- check (m `M.union` mass) vals (Array val)
- let mass1 = M.insert ident val mass
- (allCodePathsReturn, _) <- checkBlock (m `M.union` mass1) mass1 ret inner
+ check vals (Array val)
+ (allCodePathsReturn, _) <- bindLocalVariables moduleName [(ident, val)] $ checkBlock mass ret inner
guardWith "Cannot return from within a foreach block" $ not allCodePathsReturn
return (False, mass)
-checkStatement m mass ret (Return val) = do
- check (m `M.union` mass) val ret
+checkStatement mass _ (ValueStatement val) = do
+ check val unit
+ return (False, mass)
+checkStatement mass ret (Return val) = do
+ check val ret
return (True, mass)
-checkIfStatement :: M.Map Ident Type -> M.Map Ident Type -> Type -> IfStatement -> Subst Check Bool
-checkIfStatement m mass ret (IfStatement val thens Nothing) = do
- check m val Boolean
- _ <- checkBlock m mass ret thens
+checkIfStatement :: M.Map Ident Type -> Type -> IfStatement -> Subst Bool
+checkIfStatement mass ret (IfStatement val thens Nothing) = do
+ check val Boolean
+ _ <- checkBlock mass ret thens
return False
-checkIfStatement m mass ret (IfStatement val thens (Just elses)) = do
- check m val Boolean
- (allCodePathsReturn1, _) <- checkBlock m mass ret thens
- allCodePathsReturn2 <- checkElseStatement m mass ret elses
+checkIfStatement mass ret (IfStatement val thens (Just elses)) = do
+ check val Boolean
+ (allCodePathsReturn1, _) <- checkBlock mass ret thens
+ allCodePathsReturn2 <- checkElseStatement mass ret elses
return $ allCodePathsReturn1 && allCodePathsReturn2
-checkElseStatement :: M.Map Ident Type -> M.Map Ident Type -> Type -> ElseStatement -> Subst Check Bool
-checkElseStatement m mass ret (Else elses) = fst <$> checkBlock m mass ret elses
-checkElseStatement m mass ret (ElseIf ifst) = checkIfStatement m mass ret ifst
+checkElseStatement :: M.Map Ident Type -> Type -> ElseStatement -> Subst Bool
+checkElseStatement mass ret (Else elses) = fst <$> checkBlock mass ret elses
+checkElseStatement mass ret (ElseIf ifst) = checkIfStatement mass ret ifst
-checkBlock :: M.Map Ident Type -> M.Map Ident Type -> Type -> [Statement] -> Subst Check (Bool, M.Map Ident Type)
-checkBlock _ mass _ [] = return (False, mass)
-checkBlock m mass ret (s:ss) = do
- (b1, mass1) <- checkStatement (m `M.union` mass) mass ret s
- case (b1, ss) of
+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 moduleName (M.toList mass1) $ case (b1, ss) of
(True, []) -> return (True, mass1)
(True, _) -> throwError "Unreachable code"
- (False, ss) -> do
- (b2, mass2) <- checkBlock m mass1 ret ss
- return (b2, mass2)
+ (False, ss') -> checkBlock mass1 ret ss'
-skolemize :: String -> Type -> Subst Check Type
+skolemize :: String -> Type -> Subst Type
skolemize ident ty = do
tsk <- Skolem <$> fresh'
rsk <- RSkolem <$> fresh'
return $ replaceRowVars ident rsk $ replaceTypeVars ident tsk ty
-check :: M.Map Ident Type -> Value -> Type -> Subst Check ()
-check m val ty = rethrow errorMessage $ check' m val ty
+check :: Value -> Type -> Subst ()
+check val ty = rethrow errorMessage $ check' val ty
where
errorMessage msg =
"Error checking type of term " ++
@@ -604,113 +611,101 @@ check m val ty = rethrow errorMessage $ check' m val ty
":\n" ++
msg
-check' :: M.Map Ident Type -> Value -> Type -> Subst Check ()
-check' m val (ForAll idents ty) = do
+check' :: Value -> Type -> Subst ()
+check' val (ForAll idents ty) = do
sk <- skolemize idents ty
- check m val sk
-check' m val u@(TUnknown _) = do
- ty <- infer m val
+ check val sk
+check' val u@(TUnknown _) = do
+ ty <- infer val
-- Don't unify an unknown with an inferred polytype
ty' <- replaceAllVarsWithUnknowns ty
ty' ~~ u
-check' m (NumericLiteral _) Number = return ()
-check' m (StringLiteral _) String = return ()
-check' m (BooleanLiteral _) Boolean = return ()
-check' m (Unary op val) ty = checkUnary m op val ty
-check' m (Binary op left right) ty = checkBinary m op left right ty
-check' m (ArrayLiteral vals) (Array ty) = forM_ vals (\val -> check m val ty)
-check' m (Indexer index vals) ty = check m index Number >> check m vals (Array ty)
-check' m (Abs args ret) (Function argTys retTy) = do
+check' (NumericLiteral _) Number = return ()
+check' (StringLiteral _) String = return ()
+check' (BooleanLiteral _) Boolean = return ()
+check' (Unary op val) ty = checkUnary op val ty
+check' (Binary op left right) ty = checkBinary op left right ty
+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)
- let bindings = M.fromList (zip args argTys)
- check (bindings `M.union` m) ret retTy
-check' m app@(App _ _) ret = do
+ bindLocalVariables moduleName (zip args argTys) $ check ret retTy
+check' app@(App _ _) ret = do
let (f, argss) = unfoldApplication app
- ft <- infer m f
- checkFunctionApplications m ft argss ret
-check' m v@(Var var@(Qualified mp name)) ty = do
- case mp of
- ModulePath [] ->
- case M.lookup name m of
- Just ty1 -> do
- repl <- lift $ replaceAllTypeSynonyms ty1
- repl `subsumes` ty
- Nothing -> lookupGlobal
- _ -> lookupGlobal
- where
- lookupGlobal = do
- env <- lift getEnv
- modulePath <- checkModulePath `fmap` lift get
- case M.lookup (qualify modulePath var) (names env) of
- Nothing -> throwError $ show var ++ " is undefined"
- Just (ty1, _) -> do
- repl <- lift $ replaceAllTypeSynonyms ty1
- repl `subsumes` ty
-check' m (TypedValue val ty1) ty2 = do
- kind <- lift $ kindOf ty1
+ ft <- infer f
+ checkFunctionApplications ft argss ret
+check' (Var var) ty = do
+ moduleName <- substCurrentModule <$> ask
+ ty1 <- lookupVariable moduleName var
+ repl <- replaceAllTypeSynonyms ty1
+ repl `subsumes` ty
+check' (TypedValue val ty1) ty2 = do
+ moduleName <- substCurrentModule <$> ask
+ kind <- liftCheck $ kindOf moduleName ty1
guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star
ty1 `subsumes` ty2
- check m val ty1
-check' m (Case val binders) ret = do
- t1 <- infer m val
- checkBinders m t1 ret binders
-check' m (IfThenElse cond th el) ty = do
- check m cond Boolean
- check m th ty
- check m el ty
-check' m (ObjectLiteral ps) (Object row) = do
- lift $ ensureNoDuplicateProperties ps
- checkProperties m ps row False
-check' m (ObjectUpdate obj ps) (Object row) = do
- lift $ ensureNoDuplicateProperties ps
+ check val ty1
+check' (Case vals binders) ret = do
+ ts <- mapM infer vals
+ checkBinders ts ret binders
+check' (IfThenElse cond th el) ty = do
+ check cond Boolean
+ check th ty
+ check el ty
+check' (ObjectLiteral ps) (Object row) = do
+ ensureNoDuplicateProperties ps
+ checkProperties ps row False
+check' (ObjectUpdate obj ps) (Object row) = do
+ ensureNoDuplicateProperties ps
us <- zip (map fst ps) <$> replicateM (length ps) fresh
let (propsToCheck, rest) = rowToList row
propsToRemove = map fst ps
remainingProps = filter (\(p, _) -> p `notElem` propsToRemove) propsToCheck
- check m obj (Object (rowFromList (us ++ remainingProps, rest)))
- checkProperties m ps row True
-check' m (Accessor prop val) ty = do
+ check obj (Object (rowFromList (us ++ remainingProps, rest)))
+ checkProperties ps row True
+check' (Accessor prop val) ty = do
rest <- fresh
- check m val (Object (RCons prop ty rest))
-check' m (Block ss) ret = do
- (allCodePathsReturn, _) <- checkBlock m M.empty ret ss
+ check val (Object (RCons prop ty rest))
+check' (Block ss) ret = do
+ (allCodePathsReturn, _) <- checkBlock M.empty ret ss
guardWith "Block is missing a return statement" allCodePathsReturn
-check' m (Constructor c) ty = do
- env <- lift getEnv
- modulePath <- checkModulePath `fmap` lift get
- case M.lookup (qualify modulePath c) (dataConstructors env) of
+check' (Constructor c) ty = do
+ env <- getEnv
+ moduleName <- substCurrentModule <$> ask
+ case M.lookup (qualify moduleName c) (dataConstructors env) of
Nothing -> throwError $ "Constructor " ++ show c ++ " is undefined"
Just ty1 -> do
- repl <- lift $ replaceAllTypeSynonyms ty1
+ repl <- replaceAllTypeSynonyms ty1
repl `subsumes` ty
-check' m val (SaturatedTypeSynonym name args) = do
+check' val (SaturatedTypeSynonym name args) = do
ty <- expandTypeSynonym name args
- check m val ty
-check' _ val ty = throwError $ prettyPrintValue val ++ " does not have type " ++ prettyPrintType ty
+ check val ty
+check' val ty = throwError $ prettyPrintValue val ++ " does not have type " ++ prettyPrintType ty
-checkProperties :: M.Map Ident Type -> [(String, Value)] -> Row -> Bool -> Subst Check ()
-checkProperties m ps row lax = let (ts, r') = rowToList row in go ps ts r' where
+checkProperties :: [(String, Value)] -> Row -> Bool -> Subst ()
+checkProperties ps row lax = let (ts, r') = rowToList row in go ps ts r' where
go [] [] REmpty = return ()
go [] [] u@(RUnknown _) = u ~~ REmpty
go [] [] (RSkolem _) | lax = return ()
go [] ((p, _): _) _ | lax = return ()
| otherwise = throwError $ prettyPrintValue (ObjectLiteral ps) ++ " does not have property " ++ p
go ((p,_):_) [] REmpty = throwError $ "Property " ++ p ++ " is not present in closed object type " ++ prettyPrintRow row
- go ((p,v):ps) [] u@(RUnknown _) = do
- ty <- infer m v
+ go ((p,v):ps') [] u@(RUnknown _) = do
+ ty <- infer v
rest <- fresh
u ~~ RCons p ty rest
- go ps [] rest
- go ((p,v):ps) ts r =
+ go ps' [] rest
+ go ((p,v):ps') ts r =
case lookup p ts of
Nothing -> do
- ty <- infer m v
+ ty <- infer v
rest <- fresh
r ~~ RCons p ty rest
- go ps ts rest
+ go ps' ts rest
Just ty -> do
- check m v ty
- go ps (delete (p, ty) ts) r
+ check v ty
+ go ps' (delete (p, ty) ts) r
go _ _ _ = throwError $ prettyPrintValue (ObjectLiteral ps) ++ " does not have type " ++ prettyPrintType (Object row)
unfoldApplication :: Value -> (Value, [[Value]])
@@ -719,16 +714,16 @@ unfoldApplication = go []
go argss (App f args) = go (args:argss) f
go argss f = (f, argss)
-checkFunctionApplications :: M.Map Ident Type -> Type -> [[Value]] -> Type -> Subst Check ()
-checkFunctionApplications _ _ [] _ = error "Nullary function application"
-checkFunctionApplications m fnTy [args] ret = checkFunctionApplication m fnTy args ret
-checkFunctionApplications m fnTy (args:argss) ret = do
- f <- fresh
- checkFunctionApplication m fnTy args f
- checkFunctionApplications m f argss ret
+checkFunctionApplications :: Type -> [[Value]] -> Type -> Subst ()
+checkFunctionApplications _ [] _ = error "Nullary function application"
+checkFunctionApplications fnTy [args] ret = checkFunctionApplication fnTy args ret
+checkFunctionApplications fnTy (args:argss) ret = do
+ argTys <- mapM (infer) args
+ f <- inferFunctionApplication fnTy argTys
+ checkFunctionApplications f argss ret
-checkFunctionApplication :: M.Map Ident Type -> Type -> [Value] -> Type -> Subst Check ()
-checkFunctionApplication m fnTy args ret = rethrow errorMessage $ checkFunctionApplication' m fnTy args ret
+checkFunctionApplication :: Type -> [Value] -> Type -> Subst ()
+checkFunctionApplication fnTy args ret = rethrow errorMessage $ checkFunctionApplication' fnTy args ret
where
errorMessage msg = "Error applying function of type "
++ prettyPrintType fnTy
@@ -736,28 +731,49 @@ checkFunctionApplication m fnTy args ret = rethrow errorMessage $ checkFunctionA
++ ", expecting value of type "
++ prettyPrintType ret ++ ":\n" ++ msg
-checkFunctionApplication' :: M.Map Ident Type -> Type -> [Value] -> Type -> Subst Check ()
-checkFunctionApplication' m (Function argTys retTy) args ret = do
+inferFunctionApplication :: Type -> [Type] -> Subst Type
+inferFunctionApplication (Function argTys retTy) args = do
+ guardWith "Incorrect number of function arguments" (length args == length argTys)
+ zipWithM subsumes args argTys
+ return retTy
+inferFunctionApplication (ForAll ident ty) args = do
+ replaced <- replaceVarWithUnknown ident ty
+ inferFunctionApplication replaced args
+inferFunctionApplication u@(TUnknown _) args = do
+
+ ret <- fresh
+ args' <- mapM replaceAllVarsWithUnknowns args
+ u ~~ Function args' ret
+ return ret
+inferFunctionApplication (SaturatedTypeSynonym name tyArgs) args = do
+ ty <- expandTypeSynonym name tyArgs
+ inferFunctionApplication ty args
+inferFunctionApplication fnTy args = throwError $ "Cannot apply function of type "
+ ++ prettyPrintType fnTy
+ ++ " to argument(s) of type(s) " ++ intercalate ", " (map prettyPrintType args)
+
+checkFunctionApplication' :: Type -> [Value] -> Type -> Subst ()
+checkFunctionApplication' (Function argTys retTy) args ret = do
guardWith "Incorrect number of function arguments" (length args == length argTys)
- zipWithM (check m) args argTys
+ zipWithM (check) args argTys
retTy `subsumes` ret
-checkFunctionApplication' m (ForAll ident ty) args ret = do
- replaced <- replaceVarsWithUnknowns [ident] ty
- checkFunctionApplication m replaced args ret
-checkFunctionApplication' m u@(TUnknown _) args ret = do
- tyArgs <- mapM (\arg -> infer m arg >>= replaceAllVarsWithUnknowns) args
+checkFunctionApplication' (ForAll ident ty) args ret = do
+ replaced <- replaceVarWithUnknown ident ty
+ checkFunctionApplication replaced args ret
+checkFunctionApplication' u@(TUnknown _) args ret = do
+ tyArgs <- mapM (\arg -> infer arg >>= replaceAllVarsWithUnknowns) args
u ~~ Function tyArgs ret
-checkFunctionApplication' m (SaturatedTypeSynonym name tyArgs) args ret = do
+checkFunctionApplication' (SaturatedTypeSynonym name tyArgs) args ret = do
ty <- expandTypeSynonym name tyArgs
- checkFunctionApplication' m ty args ret
-checkFunctionApplication' _ fnTy args ret = throwError $ "Cannot apply function of type "
+ checkFunctionApplication' ty args ret
+checkFunctionApplication' fnTy args ret = throwError $ "Applying a function of type "
++ prettyPrintType fnTy
- ++ " to arguments " ++ intercalate ", " (map prettyPrintValue args)
- ++ ". Expecting value of type " ++ prettyPrintType ret ++ "."
+ ++ " to argument(s) " ++ intercalate ", " (map prettyPrintValue args)
+ ++ " does not yield a value of type " ++ prettyPrintType ret ++ "."
-subsumes :: Type -> Type -> Subst Check ()
+subsumes :: Type -> Type -> Subst ()
subsumes (ForAll ident ty1) ty2 = do
- replaced <- replaceVarsWithUnknowns [ident] ty1
+ replaced <- replaceVarWithUnknown ident ty1
replaced `subsumes` ty2
subsumes (Function args1 ret1) (Function args2 ret2) = do
zipWithM subsumes args2 args1
diff --git a/src/Language/PureScript/TypeDeclarations.hs b/src/Language/PureScript/TypeDeclarations.hs
new file mode 100644
index 0000000..4c84088
--- /dev/null
+++ b/src/Language/PureScript/TypeDeclarations.hs
@@ -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 []
diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs
index d3af5f1..8028109 100644
--- a/src/Language/PureScript/Types.hs
+++ b/src/Language/PureScript/Types.hs
@@ -63,8 +63,11 @@ isPolyType (Object ps) = all isPolyType (map snd . fst $ rowToList ps)
isPolyType (Function args ret) = all isPolyType args && isPolyType ret
isPolyType (TypeApp t1 t2) = isMonoType t1 && isMonoType t2
isPolyType (SaturatedTypeSynonym _ args) = all isPolyType args
-isPolyType (ForAll idents ty) = isPolyType ty
+isPolyType (ForAll _ ty) = isPolyType ty
isPolyType _ = True
mkForAll :: [String] -> Type -> Type
mkForAll = flip . foldl . flip $ ForAll
+
+unit :: Type
+unit = Object REmpty
diff --git a/src/Language/PureScript/Unknown.hs b/src/Language/PureScript/Unknown.hs
index 9f40ab9..96e102b 100644
--- a/src/Language/PureScript/Unknown.hs
+++ b/src/Language/PureScript/Unknown.hs
@@ -17,7 +17,6 @@
module Language.PureScript.Unknown where
import Data.Data
-import Data.Typeable
newtype Unknown t = Unknown { runUnknown :: Int } deriving (Show, Eq, Ord, Data, Typeable)
diff --git a/src/Language/PureScript/Values.hs b/src/Language/PureScript/Values.hs
index 402ec1b..1e57a74 100644
--- a/src/Language/PureScript/Values.hs
+++ b/src/Language/PureScript/Values.hs
@@ -21,6 +21,8 @@ import Language.PureScript.Names
import Data.Data
+type Guard = Value
+
data UnaryOperator
= Negate
| Not
@@ -67,7 +69,7 @@ data Value
| IfThenElse Value Value Value
| Block [Statement]
| Constructor (Qualified ProperName)
- | Case Value [(Binder, Value)]
+ | Case [Value] [([Binder], Maybe Guard, Value)]
| TypedValue Value PolyType deriving (Show, Data, Typeable)
data Statement
@@ -77,6 +79,7 @@ data Statement
| For Ident Value Value [Statement]
| ForEach Ident Value [Statement]
| If IfStatement
+ | ValueStatement Value
| Return Value deriving (Show, Data, Typeable)
data IfStatement = IfStatement Value [Statement] (Maybe ElseStatement) deriving (Show, Data, Typeable)
@@ -94,6 +97,6 @@ data Binder
| NullaryBinder (Qualified ProperName)
| UnaryBinder (Qualified ProperName) Binder
| ObjectBinder [(String, Binder)]
- | ArrayBinder [Binder] (Maybe Binder)
- | NamedBinder Ident Binder
- | GuardedBinder Value Binder deriving (Show, Data, Typeable)
+ | ArrayBinder [Binder]
+ | ConsBinder Binder Binder
+ | NamedBinder Ident Binder deriving (Show, Data, Typeable)
diff --git a/src/Main.hs b/src/Main.hs
index adada98..13bcee5 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -15,41 +15,46 @@
module Main where
import qualified Language.PureScript as P
-import Data.Maybe (mapMaybe)
-import Data.List (intercalate)
import System.Console.CmdTheLine
import Control.Applicative
import Control.Monad (forM)
import System.Exit (exitSuccess, exitFailure)
-import qualified Text.Parsec as P
import qualified System.IO.UTF8 as U
-import qualified Data.Map as M
+import Text.Parsec (ParseError)
-compile :: [FilePath] -> Maybe FilePath -> Maybe FilePath -> IO ()
-compile inputFiles outputFile externsFile = do
- asts <- fmap (fmap concat . sequence) $ forM inputFiles $ \inputFile -> do
- text <- U.readFile inputFile
- return $ P.runIndentParser P.parseDeclarations text
- case asts of
+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.parseModules text
+
+compile :: Maybe [FilePath] -> Maybe FilePath -> Maybe FilePath -> IO ()
+compile input output externs = do
+ modules <- readInput input
+ case modules of
Left err -> do
U.print err
exitFailure
- Right decls ->
- case P.compile decls of
- Left error -> do
- U.putStrLn error
+ Right ms ->
+ case P.compile ms of
+ Left err -> do
+ U.putStrLn err
exitFailure
Right (js, exts, _) -> do
- case outputFile of
+ case output of
Just path -> U.writeFile path js
Nothing -> U.putStrLn js
- case externsFile of
+ case externs of
Nothing -> return ()
Just filePath -> U.writeFile filePath exts
exitSuccess
+useStdIn :: Term Bool
+useStdIn = value . flag $ (optInfo [ "s", "stdin" ])
+ { optDoc = "Read from standard input" }
+
inputFiles :: Term [FilePath]
-inputFiles = nonEmpty $ posAny [] $ posInfo
+inputFiles = value $ posAny [] $ posInfo
{ posDoc = "The input .ps files" }
outputFile :: Term (Maybe FilePath)
@@ -60,8 +65,14 @@ externsFile :: Term (Maybe FilePath)
externsFile = value $ opt Nothing $ (optInfo [ "e", "externs" ])
{ optDoc = "The output .e.ps file" }
+stdInOrInputFiles :: Term (Maybe [FilePath])
+stdInOrInputFiles = combine <$> useStdIn <*> inputFiles
+ where
+ combine False input = Just input
+ combine True _ = Nothing
+
term :: Term (IO ())
-term = compile <$> inputFiles <*> outputFile <*> externsFile
+term = compile <$> stdInOrInputFiles <*> outputFile <*> externsFile
termInfo :: TermInfo
termInfo = defTI
@@ -70,4 +81,5 @@ termInfo = defTI
, termDoc = "Compiles PureScript to Javascript"
}
+main :: IO ()
main = run (term, termInfo)
diff --git a/tests/Main.hs b/tests/Main.hs
index 74dfd19..e165933 100644
--- a/tests/Main.hs
+++ b/tests/Main.hs
@@ -27,12 +27,12 @@ import qualified Data.Map as M
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
@@ -58,13 +58,14 @@ assertDoesNotCompile inputFile = do
main :: IO ()
main = do
cd <- getCurrentDirectory
+ putStrLn $ cd
let examples = cd ++ pathSeparator : "examples"
let passing = examples ++ pathSeparator : "passing"
passingTestCases <- getDirectoryContents passing
- forM_ passingTestCases $ \inputFile -> when (".ps" `isSuffixOf` inputFile) $
+ forM_ passingTestCases $ \inputFile -> when (".purs" `isSuffixOf` inputFile) $
assertCompiles (passing ++ pathSeparator : inputFile)
let failing = examples ++ pathSeparator : "failing"
failingTestCases <- getDirectoryContents failing
- forM_ failingTestCases $ \inputFile -> when (".ps" `isSuffixOf` inputFile) $
+ forM_ failingTestCases $ \inputFile -> when (".purs" `isSuffixOf` inputFile) $
assertDoesNotCompile (failing ++ pathSeparator : inputFile)
exitSuccess