summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPhilFreeman <>2013-11-28 01:06:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2013-11-28 01:06:00 (GMT)
commite6d0781a40183b957bf09d0ae5493bfc27be72af (patch)
tree5f74121d6730bf8c1b5698c9f05c7128c8c14b8a
parent77baf77dcf786d88e44810a2421d88678d99c2eb (diff)
version 0.1.110.1.11
-rw-r--r--purescript.cabal46
-rw-r--r--src/Data/Generics/Extras.hs2
-rw-r--r--src/Language/PureScript.hs8
-rw-r--r--src/Language/PureScript/CaseDeclarations.hs65
-rw-r--r--src/Language/PureScript/CodeGen/Externs.hs9
-rw-r--r--src/Language/PureScript/CodeGen/JS.hs203
-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.hs2
-rw-r--r--src/Language/PureScript/Names.hs8
-rw-r--r--src/Language/PureScript/Operators.hs5
-rw-r--r--src/Language/PureScript/Optimize.hs12
-rw-r--r--src/Language/PureScript/Parser/Common.hs108
-rw-r--r--src/Language/PureScript/Parser/Declarations.hs20
-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.hs20
-rw-r--r--src/Language/PureScript/TypeChecker/Kinds.hs31
-rw-r--r--src/Language/PureScript/TypeChecker/Monad.hs66
-rw-r--r--src/Language/PureScript/TypeChecker/Synonyms.hs9
-rw-r--r--src/Language/PureScript/TypeChecker/Types.hs658
-rw-r--r--src/Language/PureScript/Types.hs9
-rw-r--r--src/Language/PureScript/Unknown.hs1
-rw-r--r--src/Language/PureScript/Values.hs11
-rw-r--r--src/Main.hs42
-rw-r--r--tests/Main.hs5
33 files changed, 724 insertions, 974 deletions
diff --git a/purescript.cabal b/purescript.cabal
index 2d03365..c36b879 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -1,5 +1,5 @@
name: purescript
-version: 0.2.2
+version: 0.1.11
cabal-version: >=1.8
build-type: Simple
license: MIT
@@ -14,48 +14,46 @@ author: Phil Freeman <paf31@cantab.net>
data-dir: ""
library
- build-depends: base >=4 && <5, cmdtheline -any, containers -any,
- directory -any, filepath -any, mtl -any, parsec -any, syb -any,
- transformers -any, utf8-string -any
- exposed-modules: Language.PureScript.Scope Data.Generics.Extras
- Language.PureScript Language.PureScript.CodeGen
- Language.PureScript.CodeGen.Externs Language.PureScript.CodeGen.JS
- Language.PureScript.CodeGen.JS.AST
- Language.PureScript.CodeGen.Monad Language.PureScript.Declarations
- Language.PureScript.Kinds Language.PureScript.Names
- Language.PureScript.Operators Language.PureScript.Optimize
+ 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
+ Language.PureScript.CodeGen Language.PureScript.CodeGen.Externs
+ Language.PureScript.CodeGen.JS Language.PureScript.CodeGen.Monad
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.Pretty Language.PureScript.Pretty.Common
- Language.PureScript.Pretty.JS Language.PureScript.Pretty.Kinds
- Language.PureScript.Pretty.Types Language.PureScript.Pretty.Values
+ Language.PureScript.Parser.State Language.PureScript.Parser.Kinds
Language.PureScript.TypeChecker
Language.PureScript.TypeChecker.Kinds
Language.PureScript.TypeChecker.Monad
+ Language.PureScript.TypeChecker.Types
Language.PureScript.TypeChecker.Synonyms
- Language.PureScript.TypeChecker.Types Language.PureScript.Types
- Language.PureScript.Unknown Language.PureScript.Values Main
- Language.PureScript.CaseDeclarations
+ Language.PureScript.Unknown
exposed: True
buildable: True
hs-source-dirs: src
executable psc
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
+ mtl -any, transformers -any, parsec -any, utf8-string -any,
+ syb -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, cmdtheline -any, containers -any,
- directory -any, filepath -any, mtl -any, parsec -any,
- purescript -any, syb -any, transformers -any, utf8-string -any
+ build-depends: base >=4 && <5, syb -any, directory -any,
+ filepath -any, containers -any, mtl -any, transformers -any,
+ parsec -any, utf8-string -any, purescript -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 02db199..89d05f0 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 d1. (Data d1) => d1 -> m d1) -> d -> m d
+everywhereM' :: (Monad m, Data d) => (forall d. (Data d) => d -> m d) -> 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 4df2b55..9a40e30 100644
--- a/src/Language/PureScript.hs
+++ b/src/Language/PureScript.hs
@@ -25,7 +25,6 @@ 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 Data.List (intercalate)
import Data.Maybe (mapMaybe)
@@ -33,8 +32,7 @@ import Data.Maybe (mapMaybe)
compile :: [Declaration] -> Either String (String, String, Environment)
compile decls = do
bracketted <- rebracket decls
- desugared <- desugarCases bracketted
- (_, env) <- runCheck (typeCheckAll desugared)
- let js = prettyPrintJS . map optimize . concat . mapMaybe (\decl -> declToJs Nothing global decl env) $ desugared
- let exts = intercalate "\n" . mapMaybe (externToPs 0 global env) $ desugared
+ (_, 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
return (js, exts, env)
diff --git a/src/Language/PureScript/CaseDeclarations.hs b/src/Language/PureScript/CaseDeclarations.hs
deleted file mode 100644
index 5e597cf..0000000
--- a/src/Language/PureScript/CaseDeclarations.hs
+++ /dev/null
@@ -1,65 +0,0 @@
------------------------------------------------------------------------------
---
--- 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
-) where
-
-import Data.List (groupBy)
-import Control.Monad (join, unless)
-import Control.Monad.Error.Class
-
-import Language.PureScript.Names
-import Language.PureScript.Values
-import Language.PureScript.Declarations
-import Language.PureScript.Scope
-
-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 [ModuleDeclaration name decls] = do
- desugared <- desugarCases decls
- return [ModuleDeclaration name desugared]
-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 global 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 1375d85..eacd224 100644
--- a/src/Language/PureScript/CodeGen/Externs.hs
+++ b/src/Language/PureScript/CodeGen/Externs.hs
@@ -16,6 +16,7 @@ module Language.PureScript.CodeGen.Externs (
externToPs
) where
+import Data.List (intercalate)
import Data.Maybe (mapMaybe)
import qualified Data.Map as M
import Language.PureScript.Declarations
@@ -24,17 +25,17 @@ import Language.PureScript.Pretty
import Language.PureScript.Names
externToPs :: Int -> ModulePath -> Environment -> Declaration -> Maybe String
-externToPs indent path env (ValueDeclaration name _ _ _) = do
+externToPs indent path env (ValueDeclaration name _) = do
(ty, _) <- M.lookup (path, name) $ names env
return $ replicate indent ' ' ++ "foreign import " ++ show name ++ " :: " ++ prettyPrintType ty
externToPs indent path env (DataDeclaration name _ _) = do
(kind, _) <- M.lookup (path, name) $ types env
return $ replicate indent ' ' ++ "foreign import data " ++ show name ++ " :: " ++ prettyPrintKind kind
-externToPs indent _ _ (ExternMemberDeclaration member name ty) =
+externToPs indent path env (ExternMemberDeclaration member name ty) =
return $ replicate indent ' ' ++ "foreign import member " ++ show member ++ " " ++ show name ++ " :: " ++ prettyPrintType ty
-externToPs indent _ _ (ExternDataDeclaration name kind) =
+externToPs indent path env (ExternDataDeclaration name kind) =
return $ replicate indent ' ' ++ "foreign import data " ++ show name ++ " :: " ++ prettyPrintKind kind
-externToPs indent _ _ (TypeSynonymDeclaration name args ty) =
+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)
diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs
index 9fbbfe4..720d197 100644
--- a/src/Language/PureScript/CodeGen/JS.hs
+++ b/src/Language/PureScript/CodeGen/JS.hs
@@ -17,32 +17,35 @@ module Language.PureScript.CodeGen.JS (
declToJs
) where
-import Data.Maybe (mapMaybe)
+import Data.Char
+import Data.Maybe (fromMaybe, mapMaybe)
+import Data.List (intercalate)
import qualified Data.Map as M
-import Control.Arrow (second)
-import Control.Monad (replicateM, forM)
+import qualified Control.Arrow as A
+import Control.Arrow ((<+>), second)
+import Control.Monad (forM)
+import Control.Applicative
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 curMod mp (ValueDeclaration ident _ _ (Abs args ret)) e =
- Just $ JSFunction (Just ident) args (JSBlock [JSReturn (valueToJs mp e ret)]) :
- maybe [] (return . setProperty (identToJs ident) (JSVar ident)) curMod
-declToJs curMod mp (ValueDeclaration ident _ _ val) e =
- Just $ JSVariableIntroduction ident (Just (valueToJs mp e val)) :
- maybe [] (return . setProperty (identToJs ident) (JSVar ident)) curMod
-declToJs curMod _ (ExternMemberDeclaration member ident _) _ =
+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)) curMod
-declToJs curMod mp (DataDeclaration _ _ ctors) _ =
+ maybe [] (return . setProperty (show ident) (JSVar ident)) mod
+declToJs mod mp (DataDeclaration _ _ ctors) _ =
Just $ flip concatMap ctors $ \(pn@(ProperName ctor), maybeTy) ->
let
ctorJs =
@@ -52,129 +55,121 @@ declToJs curMod mp (DataDeclaration _ _ ctors) _ =
(JSBlock [JSReturn
(JSObjectLiteral [ ("ctor", JSStringLiteral (show (Qualified mp pn)))
, ("value", JSVar (Ident "value")) ])])
- in ctorJs : maybe [] (return . setProperty ctor (JSVar (Ident ctor))) curMod
-declToJs curMod mp (ModuleDeclaration pn@(ProperName name) decls) env =
+ 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))) curMod
+ 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
setProperty :: String -> JS -> Ident -> JS
-setProperty prop val curMod = JSAssignment (JSAssignProperty prop (JSAssignVariable curMod)) val
+setProperty prop val mod = JSAssignment (JSAssignProperty prop (JSAssignVariable mod)) val
-valueToJs :: ModulePath -> 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) = case M.lookup (qualify m ident) (names e) of
- Just (_, Alias aliasModule aliasIdent) -> qualifiedToJS identToJs (Qualified aliasModule aliasIdent)
- _ -> qualifiedToJS identToJs 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
qualifiedToJS :: (a -> String) -> Qualified a -> JS
qualifiedToJS f (Qualified (ModulePath parts) a) =
delimited (f a : reverse (map show parts))
where delimited [part] = JSVar (Ident (part))
- delimited (part:parts') = JSAccessor part (delimited parts')
- delimited _ = error "Invalid argument to delimited"
+ delimited (part:parts) = JSAccessor part (delimited parts)
-bindersToJs :: ModulePath -> 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"
+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]
-binderToJs :: ModulePath -> Environment -> String -> [JS] -> Binder -> Gen [JS]
-binderToJs _ _ _ done NullBinder = return done
-binderToJs _ _ varName done (StringBinder str) =
+binderToJs :: ModulePath -> String -> [JS] -> Binder -> Gen [JS]
+binderToJs _ varName done NullBinder = return done
+binderToJs _ varName done (StringBinder str) =
return [JSIfElse (JSBinary EqualTo (JSVar (Ident varName)) (JSStringLiteral str)) (JSBlock done) Nothing]
-binderToJs _ _ varName done (NumberBinder num) =
+binderToJs _ varName done (NumberBinder num) =
return [JSIfElse (JSBinary EqualTo (JSVar (Ident varName)) (JSNumericLiteral num)) (JSBlock done) Nothing]
-binderToJs _ _ varName done (BooleanBinder True) =
+binderToJs _ varName done (BooleanBinder True) =
return [JSIfElse (JSVar (Ident varName)) (JSBlock done) Nothing]
-binderToJs _ _ varName done (BooleanBinder False) =
+binderToJs _ varName done (BooleanBinder False) =
return [JSIfElse (JSUnary Not (JSVar (Ident varName))) (JSBlock done) Nothing]
-binderToJs _ _ varName done (VarBinder ident) =
+binderToJs _ varName done (VarBinder ident) =
return (JSVariableIntroduction ident (Just (JSVar (Ident varName))) : done)
-binderToJs m _ varName done (NullaryBinder ctor) =
+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 e varName done (UnaryBinder ctor b) = do
+binderToJs m varName done (UnaryBinder ctor b) = do
value <- fresh
- js <- binderToJs m e value done b
+ 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 e varName done (ObjectBinder bs) = go done bs
+binderToJs m varName done (ObjectBinder bs) = go done bs
where
go :: [JS] -> [(String, Binder)] -> Gen [JS]
- go done' [] = return done'
- go done' ((prop, binder):bs') = do
+ go done [] = return done
+ go done ((prop, binder):bs) = do
propVar <- fresh
- done'' <- go done' bs'
- js <- binderToJs m e propVar done'' binder
+ done' <- go done bs
+ js <- binderToJs m propVar done' binder
return (JSVariableIntroduction (Ident propVar) (Just (JSAccessor prop (JSVar (Ident varName)))) : js)
-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]
+binderToJs m varName done (ArrayBinder bs rest) = do
+ js <- go done rest 0 bs
+ return [JSIfElse (JSBinary cmp (JSAccessor "length" (JSVar (Ident varName))) (JSNumericLiteral (Left (fromIntegral $ length bs)))) (JSBlock js) Nothing]
where
- go :: [JS] -> Integer -> [Binder] -> Gen [JS]
- go done' _ [] = return done'
- go done' index (binder:bs') = do
+ 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
elVar <- fresh
- done'' <- go done' (index + 1) bs'
- js <- binderToJs m e elVar done'' binder
+ done' <- go done rest (index + 1) bs
+ js <- binderToJs m elVar done' binder
return (JSVariableIntroduction (Ident elVar) (Just (JSIndexer (JSNumericLiteral (Left index)) (JSVar (Ident varName)))) : js)
-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
+binderToJs m varName done (NamedBinder ident binder) = do
+ js <- binderToJs m varName done binder
return (JSVariableIntroduction ident (Just (JSVar (Ident varName))) : js)
+binderToJs m varName done (GuardedBinder cond binder) = binderToJs m varName done' binder
+ where
+ done' = [JSIfElse (valueToJs m cond) (JSBlock done) Nothing]
-statementToJs :: ModulePath -> 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
+statementToJs :: ModulePath -> Statement -> JS
+statementToJs m (VariableIntroduction ident value) = JSVariableIntroduction ident (Just (valueToJs m value))
+statementToJs m (Assignment target value) = JSAssignment (JSAssignVariable target) (valueToJs m value)
+statementToJs m (While cond sts) = JSWhile (valueToJs m cond) (JSBlock (map (statementToJs m) sts))
+statementToJs m (For ident start end sts) = JSFor ident (valueToJs m start) (valueToJs m end) (JSBlock (map (statementToJs m) sts))
+statementToJs m (ForEach ident arr sts) = JSApp (JSAccessor "forEach" (valueToJs m arr)) [JSFunction Nothing [ident] (JSBlock (map (statementToJs m) sts))]
+statementToJs m (If ifst) = ifToJs ifst
where
ifToJs :: IfStatement -> JS
- ifToJs (IfStatement cond thens elses) = JSIfElse (valueToJs m e cond) (JSBlock (map (statementToJs m e) thens)) (fmap elseToJs elses)
+ ifToJs (IfStatement cond thens elses) = JSIfElse (valueToJs m cond) (JSBlock (map (statementToJs m) thens)) (fmap elseToJs elses)
elseToJs :: ElseStatement -> JS
- elseToJs (Else sts) = JSBlock (map (statementToJs 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)
+ elseToJs (Else sts) = JSBlock (map (statementToJs m) sts)
+ elseToJs (ElseIf ifst) = ifToJs ifst
+statementToJs m (Return value) = JSReturn (valueToJs m value)
diff --git a/src/Language/PureScript/CodeGen/JS/AST.hs b/src/Language/PureScript/CodeGen/JS/AST.hs
index ee8ad50..59d34b5 100644
--- a/src/Language/PureScript/CodeGen/JS/AST.hs
+++ b/src/Language/PureScript/CodeGen/JS/AST.hs
@@ -47,5 +47,3 @@ 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 0ea9f5d..5cf876e 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, MonadFix)
+newtype Gen a = Gen { unGen :: State Int a } deriving (Functor, Applicative, Monad, MonadState Int)
runGen :: Gen a -> a
runGen = flip evalState 0 . unGen
@@ -29,9 +29,3 @@ 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 21242d2..5457a73 100644
--- a/src/Language/PureScript/Declarations.hs
+++ b/src/Language/PureScript/Declarations.hs
@@ -33,7 +33,7 @@ data Declaration
= DataDeclaration ProperName [String] [(ProperName, Maybe PolyType)]
| TypeSynonymDeclaration ProperName [String] PolyType
| TypeDeclaration Ident PolyType
- | ValueDeclaration Ident [[Binder]] (Maybe Guard) Value
+ | ValueDeclaration Ident Value
| ExternDeclaration Ident PolyType
| ExternMemberDeclaration String Ident PolyType
| ExternDataDeclaration ProperName Kind
diff --git a/src/Language/PureScript/Names.hs b/src/Language/PureScript/Names.hs
index 714a027..7bb47b3 100644
--- a/src/Language/PureScript/Names.hs
+++ b/src/Language/PureScript/Names.hs
@@ -17,7 +17,7 @@
module Language.PureScript.Names where
import Data.Data
-import Data.List (inits, intercalate)
+import Data.List (intercalate)
data Ident = Ident String | Op String deriving (Eq, Ord, Data, Typeable)
@@ -44,12 +44,8 @@ global = ModulePath []
data Qualified a = Qualified ModulePath a deriving (Eq, Ord, Data, Typeable)
instance (Show a) => Show (Qualified a) where
- show (Qualified (ModulePath names) a) = intercalate "." (map show names ++ [show a])
+ show (Qualified (ModulePath names) a) = intercalate ":" (map show names ++ [show a])
qualify :: ModulePath -> Qualified a -> (ModulePath, a)
qualify mp (Qualified (ModulePath []) a) = (mp, a)
qualify _ (Qualified mp a) = (mp, a)
-
-nameResolution :: ModulePath -> Qualified a -> [(ModulePath, a)]
-nameResolution (ModulePath mp) (Qualified (ModulePath []) a) = [ (ModulePath mp', a) | mp' <- reverse $ inits mp ]
-nameResolution _ (Qualified mp a) = [(mp, a)]
diff --git a/src/Language/PureScript/Operators.hs b/src/Language/PureScript/Operators.hs
index 295f775..f957315 100644
--- a/src/Language/PureScript/Operators.hs
+++ b/src/Language/PureScript/Operators.hs
@@ -22,6 +22,7 @@ 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
@@ -61,10 +62,10 @@ matchOperators ops val = G.everywhereM' (G.mkM parseChains) val
where
parseChains :: Value -> Either String Value
parseChains b@(BinaryNoParens _ _ _) = bracketChain (extendChain b)
- parseChains other = return other
+ parseChains val = return val
extendChain :: Value -> Chain
extendChain (BinaryNoParens name l r) = Left l : Right name : extendChain r
- extendChain other = [Left other]
+ extendChain val = [Left val]
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
diff --git a/src/Language/PureScript/Optimize.hs b/src/Language/PureScript/Optimize.hs
index b9e2790..c14034c 100644
--- a/src/Language/PureScript/Optimize.hs
+++ b/src/Language/PureScript/Optimize.hs
@@ -17,7 +17,6 @@ module Language.PureScript.Optimize (
) where
import Data.Data
-import Data.Maybe (fromMaybe)
import Data.Generics
import Language.PureScript.Names
@@ -30,13 +29,7 @@ replaceIdent :: (Data d) => Ident -> JS -> d -> d
replaceIdent var1 js = everywhere (mkT replace)
where
replace (JSVar var2) | var1 == var2 = 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
+ replace js = js
isReassigned :: (Data d) => Ident -> d -> Bool
isReassigned var1 = everything (||) (mkQ False check)
@@ -91,8 +84,7 @@ etaConvert :: JS -> JS
etaConvert = everywhere (mkT convert)
where
convert :: JS -> JS
- convert (JSBlock [JSReturn (JSApp (JSFunction Nothing idents (JSBlock body)) args)])
- | all shouldInline args = JSBlock (replaceIdents (zip idents args) body)
+ convert (JSBlock [JSReturn (JSApp (JSFunction Nothing [ident] (JSBlock body)) [arg])]) | shouldInline arg = JSBlock (replaceIdent ident arg body)
convert js = js
unThunk :: JS -> JS
diff --git a/src/Language/PureScript/Parser/Common.hs b/src/Language/PureScript/Parser/Common.hs
index c21fa56..7f202de 100644
--- a/src/Language/PureScript/Parser/Common.hs
+++ b/src/Language/PureScript/Parser/Common.hs
@@ -16,11 +16,14 @@
module Language.PureScript.Parser.Common where
-import Data.Functor.Identity
+import Data.Char (isSpace)
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
@@ -77,7 +80,7 @@ builtInOperators = [ "~", "-", "<=", ">=", "<", ">", "*", "/", "%", "++", "+", "
, "==", "!=", "&&", "||", "&", "^", "|", "!!", "!" ]
reservedOpNames :: [String]
-reservedOpNames = builtInOperators ++ [ "->", "=", "." ]
+reservedOpNames = builtInOperators ++ [ "->" ]
identStart :: P.Parsec String u Char
identStart = P.lower <|> P.oneOf "_$"
@@ -89,12 +92,11 @@ 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
@@ -109,80 +111,36 @@ langDef = PT.LanguageDef
, PT.caseSensitive = True
}
-tokenParser :: PT.GenTokenParser String u Identity
tokenParser = PT.makeTokenParser langDef
-lexeme :: P.Parsec String u a -> P.Parsec String u a
-lexeme = PT.lexeme tokenParser
+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
-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 :: P.Parsec String ParseState a -> P.Parsec String ParseState [a]
-semiSep = flip sepBy semi
+semiSep = flip sepBy semi
+semiSep1 = flip sepBy1 semi
+commaSep = flip sepBy comma
+commaSep1 = flip sepBy1 comma
-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
+tick = lexeme $ P.char '`'
+pipe = lexeme $ P.char '|'
properName :: P.Parsec String u ProperName
properName = lexeme $ ProperName <$> P.try ((:) <$> P.upper <*> many (PT.identLetter langDef) P.<?> "name")
@@ -193,7 +151,7 @@ parseQualified parser = part global
part path = (do name <- P.try (properName <* delimiter)
part (subModule path name))
<|> (Qualified path <$> P.try parser)
- delimiter = indented *> dot
+ delimiter = indented *> colon <* P.notFollowedBy colon
integerOrFloat :: P.Parsec String u (Either Integer Double)
integerOrFloat = (Left <$> P.try (PT.natural tokenParser) <|>
@@ -208,16 +166,8 @@ fold first more combine = do
bs <- P.many more
return $ foldl combine a bs
-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'
+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 ($))
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 751d185..d8c270b 100644
--- a/src/Language/PureScript/Parser/Declarations.hs
+++ b/src/Language/PureScript/Parser/Declarations.hs
@@ -17,17 +17,26 @@ module Language.PureScript.Parser.Declarations (
parseDeclarations
) 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
@@ -51,13 +60,8 @@ parseTypeSynonymDeclaration =
parseValueDeclaration :: P.Parsec String ParseState Declaration
parseValueDeclaration =
- 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)
+ ValueDeclaration <$> P.try (parseIdent <* lexeme (indented *> P.char '='))
+ <*> parseValue
parseExternDeclaration :: P.Parsec String ParseState Declaration
parseExternDeclaration = P.try (reserved "foreign") *> indented *> (reserved "import") *> indented *>
diff --git a/src/Language/PureScript/Parser/State.hs b/src/Language/PureScript/Parser/State.hs
index e20cb1d..94cf567 100644
--- a/src/Language/PureScript/Parser/State.hs
+++ b/src/Language/PureScript/Parser/State.hs
@@ -14,7 +14,11 @@
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 d2bb873..6fa2ba4 100644
--- a/src/Language/PureScript/Parser/Types.hs
+++ b/src/Language/PureScript/Parser/Types.hs
@@ -24,6 +24,7 @@ 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
@@ -74,8 +75,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 :: [Type -> P.Parsec String ParseState Type]
- postfixTable = [ \x -> TypeApp x <$> P.try (indented *> parseTypeAtom) ]
+ postfixTable :: [P.Parsec String ParseState (Type -> Type)]
+ postfixTable = [ flip TypeApp <$> 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 465b5f2..d1ae1a8 100644
--- a/src/Language/PureScript/Parser/Values.hs
+++ b/src/Language/PureScript/Parser/Values.hs
@@ -14,18 +14,25 @@
module Language.PureScript.Parser.Values (
parseValue,
- parseGuard,
- parseBinder,
- parseBinderNoParens
+ parseBinder
) 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)
@@ -67,6 +74,10 @@ 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
@@ -74,14 +85,13 @@ 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") (return <$> parseValue)
+parseCase = Case <$> P.between (P.try (C.reserved "case")) (C.indented *> C.reserved "of") parseValue
<*> (C.indented *> C.mark (P.many (C.same *> C.mark parseCaseAlternative)))
-parseCaseAlternative :: P.Parsec String ParseState ([Binder], Maybe Guard, Value)
-parseCaseAlternative = (,,) <$> (return <$> parseBinder)
- <*> P.optionMaybe parseGuard
- <*> (C.lexeme (P.string "->") *> parseValue)
- P.<?> "case alternative"
+parseCaseAlternative :: P.Parsec String ParseState (Binder, Value)
+parseCaseAlternative = (,) <$> (parseGuardedBinder <* C.lexeme (P.string "->"))
+ <*> parseValue
+ P.<?> "case alternative"
parseIfThenElse :: P.Parsec String ParseState Value
parseIfThenElse = IfThenElse <$> (P.try (C.reserved "if") *> C.indented *> parseValue)
@@ -89,23 +99,18 @@ 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 <$> parseManyStatements
+parseBlock = Block <$> (P.try (C.reserved "do") *> parseManyStatements)
parseManyStatements :: P.Parsec String ParseState [Statement]
-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"
+parseManyStatements = C.indented *> C.mark (P.many (C.same *> C.mark parseStatement)) P.<?> "block"
parseValueAtom :: P.Parsec String ParseState Value
-parseValueAtom = P.choice
+parseValueAtom = C.indented *> P.choice
[ P.try parseNumericLiteral
, P.try parseStringLiteral
, P.try parseBooleanLiteral
, parseArrayLiteral
- , P.try parseObjectLiteral
+ , parseObjectLiteral
, parseAbs
, P.try parseConstructor
, P.try parseVar
@@ -121,10 +126,6 @@ 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
@@ -132,11 +133,11 @@ parseValue =
$ indexersAndAccessors) P.<?> "expression"
where
indexersAndAccessors = C.buildPostfixParser postfixTable1 parseValueAtom
- 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 ]
+ 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) ]
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)
@@ -151,32 +152,28 @@ 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 <- P.try $ do
- tgt <- C.parseIdent
- C.lexeme $ C.indented *> P.char '='
- return tgt
+ tgt <- C.parseIdent
+ C.lexeme $ C.indented *> P.char '='
value <- parseValue
- C.indented *> C.semi
return $ Assignment tgt value
parseWhile :: P.Parsec String ParseState Statement
-parseWhile = While <$> (C.reserved "while" *> C.indented *> C.parens parseValue)
- <*> (C.indented *> parseManyStatements)
+parseWhile = While <$> (C.reserved "while" *> C.indented *> parseValue <* C.indented <* C.colon)
+ <*> parseManyStatements
parseFor :: P.Parsec String ParseState Statement
-parseFor = For <$> (C.reserved "for" *> C.indented *> C.lexeme (P.char '(') *> C.indented *> C.parseIdent)
+parseFor = For <$> (C.reserved "for" *> C.indented *> C.parseIdent)
<*> (C.indented *> C.lexeme (P.string "<-") *> parseValue)
- <*> (C.indented *> C.reserved "until" *> parseValue <* C.indented <* C.lexeme (P.char ')'))
+ <*> (C.indented *> C.reserved "until" *> parseValue <* C.colon)
<*> parseManyStatements
parseForEach :: P.Parsec String ParseState Statement
-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 ')'))
+parseForEach = ForEach <$> (C.reserved "foreach" *> C.indented *> C.parseIdent)
+ <*> (C.indented *> C.reserved "in" *> parseValue <* C.colon)
<*> parseManyStatements
parseIf :: P.Parsec String ParseState Statement
@@ -184,30 +181,26 @@ parseIf = If <$> parseIfStatement
parseIfStatement :: P.Parsec String ParseState IfStatement
parseIfStatement =
- IfStatement <$> (C.reserved "if" *> C.indented *> C.parens parseValue)
+ IfStatement <$> (C.reserved "if" *> C.indented *> parseValue <* C.indented <* C.colon)
<*> parseManyStatements
- <*> P.optionMaybe parseElseStatement
+ <*> P.optionMaybe (C.same *> parseElseStatement)
parseElseStatement :: P.Parsec String ParseState ElseStatement
-parseElseStatement = C.reserved "else" >> (ElseIf <$> parseIfStatement
- <|> Else <$> parseManyStatements)
-
-parseValueStatement :: P.Parsec String ParseState Statement
-parseValueStatement = ValueStatement <$> (parseValue <* C.semi)
+parseElseStatement = C.reserved "else" >> (ElseIf <$> (C.indented *> parseIfStatement)
+ <|> Else <$> (C.indented *> C.colon *> parseManyStatements))
parseReturn :: P.Parsec String ParseState Statement
-parseReturn = Return <$> (C.reserved "return" *> parseValue <* C.indented <* C.semi)
+parseReturn = Return <$> (C.reserved "return" *> parseValue)
parseStatement :: P.Parsec String ParseState Statement
-parseStatement = P.choice
+parseStatement = P.choice (map P.try
[ parseVariableIntroduction
, parseAssignment
, parseWhile
, parseFor
, parseForEach
, parseIf
- , parseValueStatement
- , parseReturn ] P.<?> "statement"
+ , parseReturn ]) P.<?> "statement"
parseStringBinder :: P.Parsec String ParseState Binder
parseStringBinder = StringBinder <$> C.stringLiteral
@@ -232,6 +225,7 @@ 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 '@'))
@@ -247,38 +241,19 @@ parseIdentifierAndBinder = do
binder <- C.indented *> parseBinder
return (name, binder)
-parseBinderAtom :: P.Parsec String ParseState Binder
-parseBinderAtom = P.choice (map P.try
- [ parseNullBinder
- , parseStringBinder
- , parseBooleanBinder
- , parseNumberBinder
- , parseNamedBinder
- , parseVarBinder
- , parseUnaryBinder
- , parseNullaryBinder
- , parseObjectBinder
- , parseArrayBinder
- , C.parens parseBinder ]) P.<?> "binder"
-
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
+parseBinder = P.choice (map P.try
[ parseNullBinder
, parseStringBinder
, parseBooleanBinder
, parseNumberBinder
, parseNamedBinder
, parseVarBinder
+ , parseUnaryBinder
, parseNullaryBinder
, parseObjectBinder
, parseArrayBinder
, C.parens parseBinder ]) P.<?> "binder"
-parseGuard :: P.Parsec String ParseState Guard
-parseGuard = C.indented *> C.pipe *> C.indented *> parseValue
-
+parseGuardedBinder :: P.Parsec String ParseState Binder
+parseGuardedBinder = flip ($) <$> parseBinder <*> P.option id (GuardedBinder <$> (C.indented *> C.lexeme (P.char '|') *> C.indented *> parseValue))
diff --git a/src/Language/PureScript/Pretty/Common.hs b/src/Language/PureScript/Pretty/Common.hs
index d9cf69d..602e5b6 100644
--- a/src/Language/PureScript/Pretty/Common.hs
+++ b/src/Language/PureScript/Pretty/Common.hs
@@ -17,13 +17,20 @@
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
@@ -50,16 +57,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 g f p = fix $ \c -> g >>> ((c <+> p) *** p) >>> A.arr (uncurry f)
+chainl split f p = fix $ \c -> split >>> ((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 g f p = fix $ \c -> g >>> (p *** (c <+> p)) >>> A.arr (uncurry f)
+chainr split f p = fix $ \c -> split >>> (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 g f p = fix $ \c -> g >>> (C.id *** (c <+> p)) >>> A.arr (uncurry f)
+wrap split f p = fix $ \c -> split >>> (C.id *** (c <+> p)) >>> 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)
+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)
data OperatorTable u a r = OperatorTable { runOperatorTable :: [ [Operator u a r] ] }
@@ -75,5 +82,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
+ Split pat g -> split pat g p'
) <+> p') p $ runOperatorTable table
diff --git a/src/Language/PureScript/Pretty/JS.hs b/src/Language/PureScript/Pretty/JS.hs
index 1f07652..5d33ab1 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 ((<+>))
+import Control.Arrow ((***), (<+>), first, second)
import Control.Applicative
import Control.Monad.State
@@ -34,10 +34,11 @@ blockIndent :: Int
blockIndent = 4
withIndent :: StateT PrinterState Maybe String -> StateT PrinterState Maybe String
-withIndent action = do
- modify $ \st -> st { indent = indent st + blockIndent }
- result <- action
- modify $ \st -> st { indent = indent st - blockIndent }
+withIndent s = do
+ current <- get
+ modify $ \s -> s { indent = indent s + blockIndent }
+ result <- s
+ modify $ \s -> s { indent = indent s - blockIndent }
return result
currentIndent :: StateT PrinterState Maybe String
@@ -157,22 +158,22 @@ app = mkPattern' match
match _ = mzero
unary :: UnaryOperator -> String -> Operator PrinterState JS String
-unary op str = Wrap match (++)
+unary op str = Wrap pattern (++)
where
- match :: Pattern PrinterState JS (String, JS)
- match = mkPattern match'
+ pattern :: Pattern PrinterState JS (String, JS)
+ pattern = 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 match (\v1 v2 -> v1 ++ " " ++ str ++ " " ++ v2)
+binary op str = AssocR pattern (\v1 v2 -> v1 ++ " " ++ str ++ " " ++ v2)
where
- match :: Pattern PrinterState JS (JS, JS)
- match = mkPattern match'
+ pattern :: Pattern PrinterState JS (JS, JS)
+ pattern = 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 822d6a1..a1c9883 100644
--- a/src/Language/PureScript/Pretty/Kinds.hs
+++ b/src/Language/PureScript/Pretty/Kinds.hs
@@ -17,11 +17,15 @@ 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 bd93195..1babcc0 100644
--- a/src/Language/PureScript/Pretty/Types.hs
+++ b/src/Language/PureScript/Pretty/Types.hs
@@ -18,10 +18,17 @@ module Language.PureScript.Pretty.Types (
) where
import Data.Maybe (fromMaybe)
-import Data.List (intercalate)
+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.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
@@ -42,7 +49,7 @@ typeLiterals = mkPattern match
match _ = Nothing
prettyPrintRow :: Row -> String
-prettyPrintRow = (\(tys, rest) -> intercalate ", " (map (uncurry nameAndTypeToPs) tys) ++ tailToPs rest) . toList []
+prettyPrintRow = (\(tys, tail) -> intercalate ", " (map (uncurry nameAndTypeToPs) tys) ++ tailToPs tail) . toList []
where
nameAndTypeToPs :: String -> Type -> String
nameAndTypeToPs name ty = name ++ " :: " ++ prettyPrintType ty
@@ -51,7 +58,6 @@ prettyPrintRow = (\(tys, rest) -> 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 f9c6d81..f37c29a 100644
--- a/src/Language/PureScript/Pretty/Values.hs
+++ b/src/Language/PureScript/Pretty/Values.hs
@@ -17,12 +17,16 @@ 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
@@ -37,14 +41,12 @@ 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 values binders) = Just $ "case " ++ intercalate " " (map prettyPrintValue values) ++
- " of { " ++ intercalate " ; " (map prettyPrintCaseAlternative binders) ++ " }"
+ match (Case value binders) = Just $ "case " ++ prettyPrintValue value ++ " of { " ++ intercalate " ; " (map (uncurry prettyPrintCaseAlternative) binders) ++ " }"
match (Var ident) = Just $ show ident
match _ = Nothing
-prettyPrintCaseAlternative :: ([Binder], Maybe Guard, Value) -> String
-prettyPrintCaseAlternative (binders, grd, val) = "(" ++ intercalate ", " (map prettyPrintBinder binders) ++ ") " ++
- (maybe "" (("| " ++) . prettyPrintValue) grd) ++ " -> " ++ prettyPrintValue val
+prettyPrintCaseAlternative :: Binder -> Value -> String
+prettyPrintCaseAlternative binder val = prettyPrintBinder binder ++ " -> " ++ prettyPrintValue val
ifThenElse :: Pattern () Value ((Value, Value), Value)
ifThenElse = mkPattern match
@@ -89,22 +91,22 @@ typed = mkPattern match
match _ = Nothing
unary :: UnaryOperator -> String -> Operator () Value String
-unary op str = Wrap match (++)
+unary op str = Wrap pattern (++)
where
- match :: Pattern () Value (String, Value)
- match = mkPattern match'
+ pattern :: Pattern () Value (String, Value)
+ pattern = 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 match (\v1 v2 -> v1 ++ " " ++ str ++ " " ++ v2)
+binary op str = AssocR pattern (\v1 v2 -> v1 ++ " " ++ str ++ " " ++ v2)
where
- match :: Pattern () Value (Value, Value)
- match = mkPattern match'
+ pattern :: Pattern () Value (Value, Value)
+ pattern = 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 ()
@@ -145,37 +147,19 @@ 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 = 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
+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
prettyPrintObjectPropertyBinder :: String -> Binder -> String
prettyPrintObjectPropertyBinder key binder = key ++ ": " ++ prettyPrintBinder binder
@@ -195,7 +179,6 @@ 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
deleted file mode 100644
index 677f79a..0000000
--- a/src/Language/PureScript/Scope.hs
+++ /dev/null
@@ -1,75 +0,0 @@
------------------------------------------------------------------------------
---
--- 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 (ModulePath []) 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 85b48df..eff76f7 100644
--- a/src/Language/PureScript/TypeChecker.hs
+++ b/src/Language/PureScript/TypeChecker.hs
@@ -24,7 +24,9 @@ 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 Language.PureScript.Values
@@ -33,6 +35,7 @@ import Language.PureScript.Names
import Language.PureScript.Kinds
import Language.PureScript.Declarations
+import Control.Monad (forM_)
import Control.Monad.State
import Control.Monad.Error
@@ -63,20 +66,19 @@ typeCheckAll (TypeSynonymDeclaration name args ty : rest) = do
putEnv $ env { types = M.insert (modulePath, name) (kind, TypeSynonym) (types env)
, typeSynonyms = M.insert (modulePath, name) (args, ty) (typeSynonyms env) }
typeCheckAll rest
-typeCheckAll (TypeDeclaration name ty : ValueDeclaration name' [] Nothing val : rest) | name == name' =
- typeCheckAll (ValueDeclaration name [] Nothing (TypedValue val ty) : rest)
+typeCheckAll (TypeDeclaration name 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 [] Nothing val : rest) = do
+typeCheckAll (ValueDeclaration name val : rest) = do
rethrow (("Error in declaration " ++ show name ++ ":\n") ++) $ do
env <- getEnv
modulePath <- checkModulePath `fmap` get
case M.lookup (modulePath, name) (names env) of
- Just _ -> throwError $ show name ++ " is already defined"
+ 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 (ValueDeclaration _ _ _ _ : _) = error "Binders were not desugared"
typeCheckAll (ExternDataDeclaration name kind : rest) = do
env <- getEnv
modulePath <- checkModulePath `fmap` get
@@ -99,7 +101,7 @@ typeCheckAll (ExternMemberDeclaration member name ty : rest) = do
typeCheckAll rest
where
isSingleArgumentFunction (Function [_] _) = True
- isSingleArgumentFunction (ForAll _ t) = isSingleArgumentFunction t
+ isSingleArgumentFunction (ForAll _ ty) = isSingleArgumentFunction ty
isSingleArgumentFunction _ = False
typeCheckAll (ExternDeclaration name ty : rest) = do
rethrow (("Error in foreign import declaration " ++ show name ++ ":\n") ++) $ do
@@ -126,13 +128,13 @@ typeCheckAll (ImportDeclaration modulePath idents : rest) = do
guardWith ("Module " ++ show modulePath ++ " does not exist") $ moduleExists env
case idents of
Nothing -> bindIdents (map snd $ filterModule env) currentModule env
- Just idents' -> bindIdents idents' 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
+ bindIdents idents currentModule 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) })
diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs
index ed64cc5..94f4600 100644
--- a/src/Language/PureScript/TypeChecker/Kinds.hs
+++ b/src/Language/PureScript/TypeChecker/Kinds.hs
@@ -19,9 +19,15 @@ module Language.PureScript.TypeChecker.Kinds (
kindOf
) 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
@@ -30,6 +36,8 @@ import Control.Monad.State
import Control.Monad.Error
import Control.Applicative
+import Control.Arrow (Kleisli(..), (***))
+import qualified Control.Category as C
import qualified Data.Map as M
@@ -70,10 +78,10 @@ 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 [Kind]
+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 Kind
+infer :: Maybe (ProperName, Kind) -> M.Map String Kind -> Type -> Subst Check Kind
infer name m (Array t) = do
k <- infer name m t
k ~~ Star
@@ -86,16 +94,16 @@ infer name m (Function args ret) = do
ks <- inferAll name m args
k <- infer name m ret
k ~~ Star
- forM ks (~~ Star)
+ forM ks $ \k -> k ~~ Star
return Star
infer _ m (TypeVar v) =
case M.lookup v m of
Just k -> return k
Nothing -> throwError $ "Unbound type variable " ++ v
-infer (Just (name, k)) _ (TypeConstructor (Qualified (ModulePath []) pn)) | name == pn = return k
-infer _ _ (TypeConstructor v) = do
- env <- liftCheck getEnv
- modulePath <- checkModulePath `fmap` get
+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
Nothing -> throwError $ "Unknown type constructor '" ++ show v ++ "'"
Just (kind, _) -> return kind
@@ -108,18 +116,17 @@ infer name m (TypeApp t1 t2) = do
infer name m (ForAll ident ty) = do
k <- fresh
infer name (M.insert ident k m) ty
-infer _ _ _ = return Star
+infer _ m t = return Star
-inferRow :: Maybe (ProperName, Kind) -> M.Map String Kind -> Row -> Subst Kind
+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 _ _ REmpty = return Row
-inferRow name m (RCons _ ty row) = do
+inferRow _ m r@REmpty = return Row
+inferRow name m r@(RCons _ ty row) = do
k1 <- infer name m ty
k2 <- inferRow name m 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 6f9edfa..213708b 100644
--- a/src/Language/PureScript/TypeChecker/Monad.hs
+++ b/src/Language/PureScript/TypeChecker/Monad.hs
@@ -25,13 +25,16 @@ 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 qualified Data.Map as M
-data NameKind = Value | Extern | Alias ModulePath Ident | LocalVariable deriving Show
+data NameKind = Value | Extern | Alias ModulePath Ident deriving Show
data TypeDeclarationKind = Data | ExternData | TypeSynonym deriving Show
@@ -46,28 +49,6 @@ data Environment = Environment
emptyEnvironment :: Environment
emptyEnvironment = Environment M.empty M.empty M.empty M.empty M.empty
-bindNames :: (MonadState CheckState m) => M.Map (ModulePath, Ident) (Type, NameKind) -> m a -> m a
-bindNames 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
-
-bindLocalVariables :: (Functor m, MonadState CheckState m) => [(Ident, Type)] -> m a -> m a
-bindLocalVariables bindings action = do
- modulePath <- checkModulePath `fmap` get
- bindNames (M.fromList $ flip map bindings $ \(name, ty) -> ((modulePath, name), (ty, LocalVariable))) action
-
-lookupVariable :: (Functor m, MonadState CheckState m, MonadError String m) => Qualified Ident -> m Type
-lookupVariable var = do
- env <- getEnv
- modulePath <- checkModulePath <$> get
- let tries = map (First . flip M.lookup (names env)) (nameResolution modulePath var)
- case getFirst (mconcat tries) of
- Nothing -> throwError $ show var ++ " is undefined"
- Just (ty, _) -> return ty
-
data AnyUnifiable where
AnyUnifiable :: forall t. (Unifiable t) => t -> AnyUnifiable
@@ -79,13 +60,13 @@ data CheckState = CheckState { checkEnv :: Environment
newtype Check a = Check { unCheck :: StateT CheckState (Either String) a }
deriving (Functor, Monad, Applicative, MonadPlus, MonadState CheckState, MonadError String)
-getEnv :: (Functor m, MonadState CheckState m) => m Environment
-getEnv = checkEnv <$> get
+getEnv :: Check Environment
+getEnv = fmap checkEnv get
-putEnv :: (MonadState CheckState m) => Environment -> m ()
+putEnv :: Environment -> Check ()
putEnv env = modify (\s -> s { checkEnv = env })
-modifyEnv :: (MonadState CheckState m) => (Environment -> Environment) -> m ()
+modifyEnv :: (Environment -> Environment) -> Check ()
modifyEnv f = modify (\s -> s { checkEnv = f (checkEnv s) })
runCheck :: Check a -> Either String (a, Environment)
@@ -117,19 +98,12 @@ instance Monoid Substitution where
data SubstState = SubstState { substSubst :: Substitution
, substFutureEscapeChecks :: [AnyUnifiable] }
-newtype Subst a = Subst { unSubst :: StateT SubstState Check a }
- deriving (Functor, Monad, Applicative, MonadPlus)
-
-instance MonadState CheckState Subst where
- get = Subst . lift $ get
- put = Subst . lift . put
-
-deriving instance MonadError String Subst
+newtype Subst m a = Subst { unSubst :: StateT SubstState m a }
+ deriving (Functor, Monad, Applicative, MonadPlus, MonadTrans)
-liftCheck :: Check a -> Subst a
-liftCheck = Subst . lift
+deriving instance (MonadError String m) => MonadError String (Subst m)
-runSubst :: (Unifiable a) => Subst a -> Check (a, Substitution, [AnyUnifiable])
+runSubst :: (Unifiable a, Monad m) => Subst m a -> m (a, Substitution, [AnyUnifiable])
runSubst subst = do
(a, s) <- flip runStateT (SubstState mempty []) . unSubst $ subst
return (apply (substSubst s) a, substSubst s, substFutureEscapeChecks s)
@@ -145,7 +119,7 @@ substituteOne u t = substituteWith $ \u1 ->
u2 | u2 == u -> t
| otherwise -> unknown u2
-replace :: (Unifiable t) => Unknown t -> t -> Subst ()
+replace :: (Unifiable t) => Unknown t -> t -> Subst Check ()
replace u t' = do
sub <- substSubst <$> Subst get
let t = apply sub t'
@@ -158,25 +132,25 @@ replace u t' = do
class (Typeable t, Data t, Show t) => Unifiable t where
unknown :: Unknown t -> t
- (~~) :: t -> t -> Subst ()
+ (~~) :: t -> t -> Subst Check ()
isUnknown :: t -> Maybe (Unknown t)
apply :: Substitution -> t -> t
unknowns :: t -> [Int]
-occursCheck :: (Unifiable t) => Unknown s -> t -> Subst ()
+occursCheck :: (Unifiable t) => Unknown s -> t -> Subst Check ()
occursCheck (Unknown u) t =
case isUnknown t of
Nothing -> guardWith "Occurs check fails" (u `notElem` unknowns t)
_ -> return ()
-fresh' :: Subst Int
+fresh' :: Subst Check Int
fresh' = do
- n <- checkNextVar <$> get
- modify $ \s -> s { checkNextVar = succ (checkNextVar s) }
+ n <- lift $ checkNextVar <$> get
+ lift . modify $ \s -> s { checkNextVar = succ (checkNextVar s) }
return n
-fresh :: (Unifiable t) => Subst t
+fresh :: (Unifiable t) => Subst Check t
fresh = unknown . Unknown <$> fresh'
-escapeCheckLater :: (Unifiable t) => t -> Subst ()
+escapeCheckLater :: (Unifiable t) => t -> Subst Check ()
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 d480e4a..0c990b7 100644
--- a/src/Language/PureScript/TypeChecker/Synonyms.hs
+++ b/src/Language/PureScript/TypeChecker/Synonyms.hs
@@ -18,22 +18,25 @@ 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 []
where
go :: Int -> [Type] -> Type -> Either String (Maybe Type)
go 0 args (TypeConstructor ctor) | name == 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 n _ (TypeConstructor ctor) | n > 0 && name == ctor = throwError $ "Partially applied type synonym " ++ show name
+ go n args (TypeApp f arg) = go (n - 1) (arg:args) f
go _ _ _ = return Nothing
saturateTypeSynonym :: (Data d) => Qualified ProperName -> Int -> d -> Either String d
@@ -42,7 +45,7 @@ saturateTypeSynonym name n = everywhereM' (mkM replace)
replace t = fmap (fromMaybe t) $ buildTypeSubstitution name n t
saturateAllTypeSynonyms :: (Data d) => [(Qualified ProperName, Int)] -> d -> Either String d
-saturateAllTypeSynonyms syns d = foldM (\result (name, n) -> saturateTypeSynonym name n result) d syns
+saturateAllTypeSynonyms syns d = foldM (\d (name, n) -> saturateTypeSynonym name n d) d syns
diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
index c48804b..02ba0c3 100644
--- a/src/Language/PureScript/TypeChecker/Types.hs
+++ b/src/Language/PureScript/TypeChecker/Types.hs
@@ -12,17 +12,19 @@
--
-----------------------------------------------------------------------------
-{-# LANGUAGE DeriveDataTypeable, FlexibleContexts #-}
+{-# LANGUAGE DeriveDataTypeable #-}
module Language.PureScript.TypeChecker.Types (
typeOf
) where
import Data.List
-import Data.Maybe (fromMaybe)
+import Data.Maybe (isJust, fromMaybe)
+import Data.Function
import qualified Data.Data as D
import Data.Generics
- (mkT, something, everywhere, everywhereBut, mkQ, extQ)
+ (something, everywhere, everywhereM, everything, everywhereBut,
+ mkT, mkM, mkQ, extM, extQ)
import Language.PureScript.Values
import Language.PureScript.Types
@@ -38,7 +40,8 @@ import Control.Monad.State
import Control.Monad.Error
import Control.Applicative
-import Control.Arrow (Arrow(..))
+import Control.Arrow (Arrow(..), Kleisli(..), (***), (&&&), second)
+import qualified Control.Category as C
import qualified Data.Map as M
@@ -57,7 +60,7 @@ instance Unifiable Type where
apply _ t = t
unknowns (TUnknown (Unknown u)) = [u]
unknowns (SaturatedTypeSynonym _ tys) = concatMap unknowns tys
- unknowns (ForAll _ ty) = unknowns ty
+ unknowns (ForAll idents ty) = unknowns ty
unknowns (Array t) = unknowns t
unknowns (Object r) = unknowns r
unknowns (Function args ret) = concatMap unknowns args ++ unknowns ret
@@ -79,19 +82,19 @@ instance Unifiable Row where
forM_ int (uncurry (~~))
unifyRows sd1 r1' sd2 r2'
where
- unifyRows :: [(String, Type)] -> Row -> [(String, Type)] -> Row -> Subst ()
+ unifyRows :: [(String, Type)] -> Row -> [(String, Type)] -> Row -> Subst Check ()
unifyRows [] (RUnknown u) sd r = replace u (rowFromList (sd, r))
unifyRows sd r [] (RUnknown u) = replace u (rowFromList (sd, r))
- unifyRows ((name, ty):row) r others u@(RUnknown un) = do
+ unifyRows ns@((name, ty):row) r others u@(RUnknown un) = do
occursCheck un ty
- forM row $ \(_, t) -> occursCheck un t
+ forM row $ \(_, ty) -> occursCheck un ty
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 sd3 r3 sd4 r4 = throwError $ "Cannot unify " ++ prettyPrintRow (rowFromList (sd3, r3)) ++ " with " ++ prettyPrintRow (rowFromList (sd4, r4)) ++ "."
+ unifyRows sd1 r1 sd2 r2 = throwError $ "Cannot unify " ++ prettyPrintRow (rowFromList (sd1, r1)) ++ " with " ++ prettyPrintRow (rowFromList (sd2, r2)) ++ "."
apply s (RUnknown u) = runSubstitution s u
apply s (RCons name ty r) = RCons name (apply s ty) (apply s r)
apply _ r = r
@@ -99,7 +102,7 @@ instance Unifiable Row where
unknowns (RCons _ ty r) = unknowns ty ++ unknowns r
unknowns _ = []
-unifyTypes :: Type -> Type -> Subst ()
+unifyTypes :: Type -> Type -> Subst Check ()
unifyTypes t1 t2 = rethrow (\e -> "Error unifying type " ++ prettyPrintType t1 ++ " with type " ++ prettyPrintType t2 ++ ":\n" ++ e) $ do
unifyTypes' t1 t2
where
@@ -114,7 +117,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 <- replaceVarWithUnknown ident2 ty2
+ replaced <- replaceVarsWithUnknowns [ident2] ty2
sk `unifyTypes` replaced
unifyTypes' (ForAll ident ty1) ty2 = do
sk <- skolemize ident ty1
@@ -131,13 +134,13 @@ 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` get
+ modulePath <- checkModulePath `fmap` lift get
guardWith ("Cannot unify " ++ show c1 ++ " with " ++ show c2 ++ ".") (qualify modulePath c1 == qualify modulePath c2)
- unifyTypes' (TypeApp t3 t4) (TypeApp t5 t6) = do
- t3 `unifyTypes` t5
- t4 `unifyTypes` t6
+ unifyTypes' (TypeApp t1 t2) (TypeApp t3 t4) = do
+ t1 `unifyTypes` t3
+ t2 `unifyTypes` t4
unifyTypes' (Skolem s1) (Skolem s2) | s1 == s2 = return ()
- unifyTypes' t3 t4 = throwError $ "Cannot unify " ++ prettyPrintType t3 ++ " with " ++ prettyPrintType t4 ++ "."
+ unifyTypes' t1 t2 = throwError $ "Cannot unify " ++ prettyPrintType t1 ++ " with " ++ prettyPrintType t2 ++ "."
isFunction :: Value -> Bool
isFunction (Abs _ _) = True
@@ -149,20 +152,18 @@ typeOf name val = do
(ty, sub, checks) <- runSubst $ case name of
Just ident | isFunction val ->
case val of
- TypedValue value ty -> do
- kind <- liftCheck $ kindOf ty
+ TypedValue val ty -> do
+ kind <- lift $ kindOf ty
guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star
- ty' <- replaceAllTypeSynonyms ty
- modulePath <- checkModulePath <$> get
- bindNames (M.singleton (modulePath, ident) (ty, LocalVariable)) $ check value ty'
+ ty' <- lift $ replaceAllTypeSynonyms ty
+ check (M.singleton ident ty) val ty'
return ty'
_ -> do
me <- fresh
- modulePath <- checkModulePath <$> get
- ty <- bindNames (M.singleton (modulePath, ident) (me, LocalVariable)) $ infer val
+ ty <- infer (M.singleton ident me) val
ty ~~ me
return ty
- _ -> infer val
+ _ -> infer M.empty val
escapeCheck checks ty sub
skolemEscapeCheck ty
return $ varIfUnknown $ desaturateAllTypeSynonyms $ setifyAll ty
@@ -172,7 +173,7 @@ escapeCheck checks ty sub =
let
visibleUnknowns = nub $ unknowns ty
in
- forM_ checks $ \c -> case c of
+ forM_ checks $ \check -> case check of
AnyUnifiable t -> do
let unsolvedUnknowns = nub . unknowns $ apply sub t
guardWith "Escape check fails" $ null $ unsolvedUnknowns \\ visibleUnknowns
@@ -195,109 +196,121 @@ setifyAll :: (D.Data d) => d -> d
setifyAll = everywhere (mkT setify)
varIfUnknown :: Type -> Type
-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'
+varIfUnknown ty = mkForAll (sort . map ((:) 'u' . show) . nub $ unknowns ty) 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 replaceTypeVar)
+replaceTypeVars name t = everywhereBut (mkQ False isShadowed) (mkT replace)
where
- replaceTypeVar (TypeVar v) | v == name = t
- replaceTypeVar other = other
+ replace (TypeVar v) | v == name = t
+ replace t = t
isShadowed (ForAll v _) | v == name = True
isShadowed _ = False
replaceRowVars :: (D.Data d) => String -> Row -> d -> d
-replaceRowVars name r = everywhere (mkT replaceRowVar)
+replaceRowVars name r = everywhere (mkT replace)
where
- replaceRowVar (RowVar v) | v == name = r
- replaceRowVar other = other
+ replace (RowVar v) | v == name = r
+ replace t = t
-replaceAllVarsWithUnknowns :: Type -> Subst Type
-replaceAllVarsWithUnknowns (ForAll ident ty) = replaceVarWithUnknown ident ty >>= replaceAllVarsWithUnknowns
+replaceAllVarsWithUnknowns :: Type -> Subst Check Type
+replaceAllVarsWithUnknowns (ForAll ident ty) = replaceVarsWithUnknowns [ident] ty >>= replaceAllVarsWithUnknowns
replaceAllVarsWithUnknowns ty = return ty
-replaceVarWithUnknown :: String -> Type -> Subst Type
-replaceVarWithUnknown ident ty = do
- tu <- fresh
- ru <- fresh
- return $ replaceRowVars ident ru . replaceTypeVars ident tu $ 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
-replaceAllTypeSynonyms :: (Functor m, MonadState CheckState m, MonadError String m) => (D.Data d) => d -> m d
+replaceAllTypeSynonyms :: (D.Data d) => d -> Check 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
desaturateAllTypeSynonyms :: (D.Data d) => d -> d
-desaturateAllTypeSynonyms = everywhere (mkT replaceSaturatedTypeSynonym)
+desaturateAllTypeSynonyms = everywhere (mkT replace)
where
- replaceSaturatedTypeSynonym (SaturatedTypeSynonym name args) = foldl TypeApp (TypeConstructor name) args
- replaceSaturatedTypeSynonym t = t
+ 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
-expandTypeSynonym :: Qualified ProperName -> [Type] -> Subst Type
+expandTypeSynonym :: Qualified ProperName -> [Type] -> Subst Check Type
expandTypeSynonym name args = do
- env <- getEnv
- modulePath <- checkModulePath `fmap` get
+ env <- lift getEnv
+ modulePath <- checkModulePath `fmap` lift get
case M.lookup (qualify modulePath name) (typeSynonyms env) of
Just (synArgs, body) -> return $ replaceAllTypeVars (zip synArgs args) body
Nothing -> error "Type synonym was not defined"
-ensureNoDuplicateProperties :: (MonadError String m) => [(String, Value)] -> m ()
+ensureNoDuplicateProperties :: [(String, Value)] -> Check ()
ensureNoDuplicateProperties ps = guardWith "Duplicate property names" $ length (nub . map fst $ ps) == length ps
-infer :: Value -> Subst Type
-infer val = rethrow (\e -> "Error inferring type of term " ++ prettyPrintValue val ++ ":\n" ++ e) $ do
- ty <- infer' val
+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
escapeCheckLater ty
return ty
-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
+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
inferUnary op t
-infer' (Binary op left right) = do
- t1 <- infer left
- t2 <- infer right
+infer' m (Binary op left right) = do
+ t1 <- infer m left
+ t2 <- infer m right
inferBinary op t1 t2
-infer' (ObjectLiteral ps) = do
- ensureNoDuplicateProperties ps
- ts <- mapM (infer . snd) ps
+infer' m (ObjectLiteral ps) = do
+ lift $ ensureNoDuplicateProperties ps
+ ts <- mapM (infer m . snd) ps
let fields = zipWith (\(name, _) t -> (name, t)) ps ts
- return $ Object $ rowFromList (fields, REmpty)
-infer' (ObjectUpdate o ps) = do
- ensureNoDuplicateProperties ps
+ return $ Object $ typesToRow fields
+infer' m (ObjectUpdate o ps) = do
+ lift $ ensureNoDuplicateProperties ps
+ obj <- infer m o
row <- fresh
- newTys <- zipWith (\(name, _) t -> (name, t)) ps <$> mapM (infer . snd) ps
- oldTys <- zip (map fst ps) <$> replicateM (length ps) fresh
- check o $ Object $ rowFromList (oldTys, row)
- return $ Object $ rowFromList (newTys, row)
-infer' (Indexer index val) = do
+ ts <- mapM (infer m . snd) ps
+ let tys = zipWith (\(name, _) t -> (name, t)) ps ts
+ obj ~~ Object (rowFromList (tys, row))
+ return obj
+infer' m (Indexer index val) = do
el <- fresh
- check index Number
- check val (Array el)
+ check m index Number
+ check m val (Array el)
return el
-infer' (Accessor prop val) = do
- obj <- infer val
+infer' m (Accessor prop val) = do
+ obj <- infer m val
propTy <- inferProperty obj prop
case propTy of
Nothing -> do
@@ -306,51 +319,61 @@ infer' (Accessor prop val) = do
obj `subsumes` Object (RCons prop field rest)
return field
Just ty -> return ty
-infer' (Abs args ret) = do
+infer' m (Abs args ret) = do
ts <- replicateM (length args) fresh
- bindLocalVariables (zip args ts) $ do
- body <- infer' ret
- return $ Function ts body
-infer' app@(App _ _) = do
+ let m' = m `M.union` M.fromList (zip args ts)
+ body <- infer m' ret
+ return $ Function ts body
+infer' m app@(App _ _) = do
let (f, argss) = unfoldApplication app
- ft <- infer f
+ ft <- infer m f
ret <- fresh
- checkFunctionApplications ft argss ret
+ checkFunctionApplications m ft argss ret
return ret
-infer' (Var var) = do
- ty <- lookupVariable var
- replaceAllTypeSynonyms ty
-infer' (Block ss) = do
+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
ret <- fresh
- (allCodePathsReturn, _) <- checkBlock M.empty ret ss
+ (allCodePathsReturn, _) <- checkBlock m M.empty ret ss
guardWith "Block is missing a return statement" allCodePathsReturn
return ret
-infer' (Constructor c) = do
- env <- getEnv
- modulePath <- checkModulePath `fmap` get
+infer' m (Constructor c) = do
+ env <- lift getEnv
+ modulePath <- checkModulePath `fmap` lift get
case M.lookup (qualify modulePath c) (dataConstructors env) of
Nothing -> throwError $ "Constructor " ++ show c ++ " is undefined"
- Just ty -> replaceAllTypeSynonyms ty
-infer' (Case vals binders) = do
- ts <- mapM infer vals
+ Just ty -> lift $ replaceAllTypeSynonyms ty
+infer' m (Case val binders) = do
+ t1 <- infer m val
ret <- fresh
- checkBinders ts ret binders
+ checkBinders m t1 ret binders
return ret
-infer' (IfThenElse cond th el) = do
- check cond Boolean
- t2 <- infer th
- t3 <- infer el
+infer' m (IfThenElse cond th el) = do
+ check m cond Boolean
+ t2 <- infer m th
+ t3 <- infer m el
t2 ~~ t3
return t2
-infer' (TypedValue val ty) = do
- kind <- liftCheck $ kindOf ty
+infer' m (TypedValue val ty) = do
+ kind <- lift $ kindOf ty
guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star
- ty' <- replaceAllTypeSynonyms ty
- check val ty'
+ ty' <- lift $ replaceAllTypeSynonyms ty
+ check m val ty'
return ty'
-infer' _ = error "Invalid argument to infer"
-inferProperty :: Type -> String -> Subst (Maybe Type)
+inferProperty :: Type -> String -> Subst Check (Maybe Type)
inferProperty (Object row) prop = do
let (props, _) = rowToList row
return $ lookup prop props
@@ -358,23 +381,23 @@ inferProperty (SaturatedTypeSynonym name args) prop = do
replaced <- expandTypeSynonym name args
inferProperty replaced prop
inferProperty (ForAll ident ty) prop = do
- replaced <- replaceVarWithUnknown ident ty
+ replaced <- replaceVarsWithUnknowns [ident] ty
inferProperty replaced prop
-inferProperty _ _ = return Nothing
+inferProperty _ prop = return Nothing
-inferUnary :: UnaryOperator -> Type -> Subst Type
+inferUnary :: UnaryOperator -> Type -> Subst Check Type
inferUnary op val =
case fromMaybe (error "Invalid operator") $ lookup op unaryOps of
(valTy, resTy) -> do
val ~~ valTy
return resTy
-checkUnary :: UnaryOperator -> Value -> Type -> Subst ()
-checkUnary op val res =
+checkUnary :: M.Map Ident Type -> UnaryOperator -> Value -> Type -> Subst Check ()
+checkUnary m op val res =
case fromMaybe (error "Invalid operator") $ lookup op unaryOps of
(valTy, resTy) -> do
res ~~ resTy
- check val valTy
+ check m val valTy
unaryOps :: [(UnaryOperator, (Type, Type))]
unaryOps = [ (Negate, (Number, Number))
@@ -382,7 +405,7 @@ unaryOps = [ (Negate, (Number, Number))
, (BitwiseNot, (Number, Number))
]
-inferBinary :: BinaryOperator -> Type -> Type -> Subst Type
+inferBinary :: BinaryOperator -> Type -> Type -> Subst Check Type
inferBinary op left right | isEqualityTest op = do
left ~~ right
return Boolean
@@ -393,18 +416,18 @@ inferBinary op left right =
right ~~ valTy
return resTy
-checkBinary :: BinaryOperator -> Value -> Value -> Type -> Subst ()
-checkBinary op left right res | isEqualityTest op = do
+checkBinary :: M.Map Ident Type -> BinaryOperator -> Value -> Value -> Type -> Subst Check ()
+checkBinary m op left right res | isEqualityTest op = do
res ~~ Boolean
- t1 <- infer left
- t2 <- infer right
+ t1 <- infer m left
+ t2 <- infer m right
t1 ~~ t2
-checkBinary op left right res =
+checkBinary m op left right res =
case fromMaybe (error "Invalid operator") $ lookup op binaryOps of
(valTy, resTy) -> do
res ~~ resTy
- check left valTy
- check right valTy
+ check m left valTy
+ check m right valTy
isEqualityTest :: BinaryOperator -> Bool
isEqualityTest EqualTo = True
@@ -432,31 +455,28 @@ binaryOps = [ (Add, (Number, Number))
, (GreaterThanOrEqualTo, (Number, Boolean))
]
-inferBinder :: Type -> Binder -> Subst (M.Map Ident Type)
+inferBinder :: Type -> Binder -> Subst Check (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 <- getEnv
- modulePath <- checkModulePath <$> get
+ env <- lift getEnv
+ modulePath <- checkModulePath `fmap` lift get
case M.lookup (qualify modulePath ctor) (dataConstructors env) of
Just ty -> do
ty `subsumes` val
return M.empty
_ -> throwError $ "Constructor " ++ show ctor ++ " is not defined"
inferBinder val (UnaryBinder ctor binder) = do
- env <- getEnv
- modulePath <- checkModulePath <$> get
+ env <- lift getEnv
+ modulePath <- checkModulePath `fmap` lift get
case M.lookup (qualify modulePath ctor) (dataConstructors env) of
Just ty -> do
- 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"
+ Function [obj] ret <- replaceAllVarsWithUnknowns ty
+ val `subsumes` ret
+ inferBinder obj binder
_ -> throwError $ "Constructor " ++ show ctor ++ " is not defined"
inferBinder val (ObjectBinder props) = do
row <- fresh
@@ -465,117 +485,117 @@ inferBinder val (ObjectBinder props) = do
val ~~ Object row
return m1
where
- inferRowProperties :: Row -> Row -> [(String, Binder)] -> Subst (M.Map Ident Type)
+ inferRowProperties :: Row -> Row -> [(String, Binder)] -> Subst Check (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) = do
+inferBinder val (ArrayBinder binders rest) = do
el <- fresh
m1 <- M.unions <$> mapM (inferBinder el) binders
val ~~ Array el
- 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
+ case rest of
+ Nothing -> return m1
+ Just binder -> do
+ m2 <- inferBinder val binder
+ return $ m1 `M.union` m2
inferBinder val (NamedBinder name binder) = do
m <- inferBinder val binder
return $ M.insert name val m
-checkBinders :: [Type] -> Type -> [([Binder], Maybe Guard, Value)] -> Subst ()
-checkBinders _ _ [] = return ()
-checkBinders nvals ret ((binders, grd, val):bs) = do
- m1 <- M.unions <$> zipWithM inferBinder nvals binders
- bindLocalVariables (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
- modulePath <- checkModulePath <$> get
- case M.lookup (modulePath, 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
+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
return (False, M.insert name t mass)
-checkStatement mass _ (Assignment ident val) = do
- t <- infer val
+checkStatement m mass ret (Assignment ident val) = do
+ t <- infer m 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 mass ret (While val inner) = do
- check val Boolean
- (allCodePathsReturn, _) <- checkBlock mass ret inner
+checkStatement m mass ret (While val inner) = do
+ check m val Boolean
+ (allCodePathsReturn, _) <- checkBlock m mass ret inner
return (allCodePathsReturn, mass)
-checkStatement mass ret (If ifst) = do
- allCodePathsReturn <- checkIfStatement mass ret ifst
+checkStatement m mass ret (If ifst) = do
+ allCodePathsReturn <- checkIfStatement m mass ret ifst
return (allCodePathsReturn, mass)
-checkStatement mass ret (For ident start end inner) = do
- assignVariable ident
- check start Number
- check end Number
- (allCodePathsReturn, _) <- bindLocalVariables [(ident, Number)] $ checkBlock mass ret inner
+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
return (allCodePathsReturn, mass)
-checkStatement mass ret (ForEach ident vals inner) = do
- assignVariable ident
+checkStatement m mass ret (ForEach ident vals inner) = do
+ assignVariable ident (m `M.union` mass)
val <- fresh
- check vals (Array val)
- (allCodePathsReturn, _) <- bindLocalVariables [(ident, val)] $ checkBlock mass ret inner
+ check (m `M.union` mass) vals (Array val)
+ let mass1 = M.insert ident val mass
+ (allCodePathsReturn, _) <- checkBlock (m `M.union` mass1) mass1 ret inner
guardWith "Cannot return from within a foreach block" $ not allCodePathsReturn
return (False, mass)
-checkStatement mass _ (ValueStatement val) = do
- check val unit
- return (False, mass)
-checkStatement mass ret (Return val) = do
- check val ret
+checkStatement m mass ret (Return val) = do
+ check (m `M.union` mass) val ret
return (True, mass)
-checkIfStatement :: M.Map Ident Type -> Type -> IfStatement -> Subst Bool
-checkIfStatement mass ret (IfStatement val thens Nothing) = do
- check val Boolean
- _ <- checkBlock mass ret thens
+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
return False
-checkIfStatement mass ret (IfStatement val thens (Just elses)) = do
- check val Boolean
- (allCodePathsReturn1, _) <- checkBlock mass ret thens
- allCodePathsReturn2 <- checkElseStatement mass ret elses
+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
return $ allCodePathsReturn1 && allCodePathsReturn2
-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
+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
-checkBlock :: M.Map Ident Type -> Type -> [Statement] -> Subst (Bool, M.Map Ident Type)
-checkBlock mass _ [] = return (False, mass)
-checkBlock mass ret (s:ss) = do
- (b1, mass1) <- checkStatement mass ret s
- bindLocalVariables (M.toList mass1) $ case (b1, ss) of
+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
(True, []) -> return (True, mass1)
(True, _) -> throwError "Unreachable code"
- (False, ss') -> checkBlock mass1 ret ss'
+ (False, ss) -> do
+ (b2, mass2) <- checkBlock m mass1 ret ss
+ return (b2, mass2)
-skolemize :: String -> Type -> Subst Type
+skolemize :: String -> Type -> Subst Check Type
skolemize ident ty = do
tsk <- Skolem <$> fresh'
rsk <- RSkolem <$> fresh'
return $ replaceRowVars ident rsk $ replaceTypeVars ident tsk ty
-check :: Value -> Type -> Subst ()
-check val ty = rethrow errorMessage $ check' val ty
+check :: M.Map Ident Type -> Value -> Type -> Subst Check ()
+check m val ty = rethrow errorMessage $ check' m val ty
where
errorMessage msg =
"Error checking type of term " ++
@@ -585,98 +605,109 @@ check val ty = rethrow errorMessage $ check' val ty
":\n" ++
msg
-check' :: Value -> Type -> Subst ()
-check' val (ForAll idents ty) = do
+check' :: M.Map Ident Type -> Value -> Type -> Subst Check ()
+check' m val (ForAll idents ty) = do
sk <- skolemize idents ty
- check val sk
-check' val u@(TUnknown _) = do
- ty <- infer val
+ check m val sk
+check' m val u@(TUnknown _) = do
+ ty <- infer m val
-- Don't unify an unknown with an inferred polytype
ty' <- replaceAllVarsWithUnknowns ty
ty' ~~ u
-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
+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
guardWith "Incorrect number of function arguments" (length args == length argTys)
- bindLocalVariables (zip args argTys) $ check ret retTy
-check' app@(App _ _) ret = do
+ let bindings = M.fromList (zip args argTys)
+ check (bindings `M.union` m) ret retTy
+check' m app@(App _ _) ret = do
let (f, argss) = unfoldApplication app
- ft <- infer f
- checkFunctionApplications ft argss ret
-check' (Var var) ty = do
- ty1 <- lookupVariable var
- repl <- replaceAllTypeSynonyms ty1
- repl `subsumes` ty
-check' (TypedValue val ty1) ty2 = do
- kind <- liftCheck $ kindOf ty1
+ 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
guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star
ty1 `subsumes` ty2
- 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 obj (Object (rowFromList (us ++ remainingProps, rest)))
- checkProperties ps row True
-check' (Accessor prop val) ty = do
+ 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) objTy@(Object row) = do
+ lift $ ensureNoDuplicateProperties ps
+ check m obj objTy
+ checkProperties m ps row True
+check' m (Accessor prop val) ty = do
rest <- fresh
- check val (Object (RCons prop ty rest))
-check' (Block ss) ret = do
- (allCodePathsReturn, _) <- checkBlock M.empty ret ss
+ check m val (Object (RCons prop ty rest))
+check' m (Block ss) ret = do
+ (allCodePathsReturn, _) <- checkBlock m M.empty ret ss
guardWith "Block is missing a return statement" allCodePathsReturn
-check' (Constructor c) ty = do
- env <- getEnv
- modulePath <- checkModulePath <$> get
+check' m (Constructor c) ty = do
+ env <- lift getEnv
+ modulePath <- checkModulePath `fmap` lift get
case M.lookup (qualify modulePath c) (dataConstructors env) of
Nothing -> throwError $ "Constructor " ++ show c ++ " is undefined"
Just ty1 -> do
- repl <- replaceAllTypeSynonyms ty1
+ repl <- lift $ replaceAllTypeSynonyms ty1
repl `subsumes` ty
-check' val (SaturatedTypeSynonym name args) = do
+check' m val (SaturatedTypeSynonym name args) = do
ty <- expandTypeSynonym name args
- check val ty
-check' val ty = throwError $ prettyPrintValue val ++ " does not have type " ++ prettyPrintType ty
+ check m val ty
+check' _ val ty = throwError $ prettyPrintValue val ++ " does not have type " ++ prettyPrintType ty
-checkProperties :: [(String, Value)] -> Row -> Bool -> Subst ()
-checkProperties ps row lax = let (ts, r') = rowToList row in go ps ts r' where
+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
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 v
+ go ((p,v):ps) [] u@(RUnknown _) = do
+ ty <- infer m 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 v
+ ty <- infer m v
rest <- fresh
r ~~ RCons p ty rest
- go ps' ts rest
+ go ps ts rest
Just ty -> do
- check v ty
- go ps' (delete (p, ty) ts) r
+ check m 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]])
@@ -685,16 +716,16 @@ unfoldApplication = go []
go argss (App f args) = go (args:argss) f
go argss f = (f, argss)
-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
+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
-checkFunctionApplication :: Type -> [Value] -> Type -> Subst ()
-checkFunctionApplication fnTy args ret = rethrow errorMessage $ checkFunctionApplication' fnTy args ret
+checkFunctionApplication :: M.Map Ident Type -> Type -> [Value] -> Type -> Subst Check ()
+checkFunctionApplication m fnTy args ret = rethrow errorMessage $ checkFunctionApplication' m fnTy args ret
where
errorMessage msg = "Error applying function of type "
++ prettyPrintType fnTy
@@ -702,49 +733,28 @@ checkFunctionApplication fnTy args ret = rethrow errorMessage $ checkFunctionApp
++ ", expecting value of type "
++ prettyPrintType ret ++ ":\n" ++ msg
-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
+checkFunctionApplication' :: M.Map Ident Type -> Type -> [Value] -> Type -> Subst Check ()
+checkFunctionApplication' m (Function argTys retTy) args ret = do
guardWith "Incorrect number of function arguments" (length args == length argTys)
- zipWithM (check) args argTys
+ zipWithM (check m) args argTys
retTy `subsumes` ret
-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
+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
u ~~ Function tyArgs ret
-checkFunctionApplication' (SaturatedTypeSynonym name tyArgs) args ret = do
+checkFunctionApplication' m (SaturatedTypeSynonym name tyArgs) args ret = do
ty <- expandTypeSynonym name tyArgs
- checkFunctionApplication' ty args ret
-checkFunctionApplication' fnTy args ret = throwError $ "Applying a function of type "
+ checkFunctionApplication' m ty args ret
+checkFunctionApplication' _ fnTy args ret = throwError $ "Cannot apply function of type "
++ prettyPrintType fnTy
- ++ " to argument(s) " ++ intercalate ", " (map prettyPrintValue args)
- ++ " does not yield a value of type " ++ prettyPrintType ret ++ "."
+ ++ " to arguments " ++ intercalate ", " (map prettyPrintValue args)
+ ++ ". Expecting value of type " ++ prettyPrintType ret ++ "."
-subsumes :: Type -> Type -> Subst ()
+subsumes :: Type -> Type -> Subst Check ()
subsumes (ForAll ident ty1) ty2 = do
- replaced <- replaceVarWithUnknown ident ty1
+ replaced <- replaceVarsWithUnknowns [ident] ty1
replaced `subsumes` ty2
subsumes (Function args1 ret1) (Function args2 ret2) = do
zipWithM subsumes args2 args1
diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs
index 8028109..f7d57f4 100644
--- a/src/Language/PureScript/Types.hs
+++ b/src/Language/PureScript/Types.hs
@@ -44,6 +44,10 @@ data Row
| RCons String Type Row
| RSkolem Int deriving (Show, Eq, Data, Typeable)
+typesToRow :: [(String, Type)] -> Row
+typesToRow [] = REmpty
+typesToRow ((name, ty):tys) = RCons name ty (typesToRow tys)
+
rowToList :: Row -> ([(String, Type)], Row)
rowToList (RCons name ty row) = let (tys, rest) = rowToList row
in ((name, ty):tys, rest)
@@ -63,11 +67,8 @@ 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 _ ty) = isPolyType ty
+isPolyType (ForAll idents 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 96e102b..9f40ab9 100644
--- a/src/Language/PureScript/Unknown.hs
+++ b/src/Language/PureScript/Unknown.hs
@@ -17,6 +17,7 @@
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 1e57a74..402ec1b 100644
--- a/src/Language/PureScript/Values.hs
+++ b/src/Language/PureScript/Values.hs
@@ -21,8 +21,6 @@ import Language.PureScript.Names
import Data.Data
-type Guard = Value
-
data UnaryOperator
= Negate
| Not
@@ -69,7 +67,7 @@ data Value
| IfThenElse Value Value Value
| Block [Statement]
| Constructor (Qualified ProperName)
- | Case [Value] [([Binder], Maybe Guard, Value)]
+ | Case Value [(Binder, Value)]
| TypedValue Value PolyType deriving (Show, Data, Typeable)
data Statement
@@ -79,7 +77,6 @@ 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)
@@ -97,6 +94,6 @@ data Binder
| NullaryBinder (Qualified ProperName)
| UnaryBinder (Qualified ProperName) Binder
| ObjectBinder [(String, Binder)]
- | ArrayBinder [Binder]
- | ConsBinder Binder Binder
- | NamedBinder Ident Binder deriving (Show, Data, Typeable)
+ | ArrayBinder [Binder] (Maybe Binder)
+ | NamedBinder Ident Binder
+ | GuardedBinder Value Binder deriving (Show, Data, Typeable)
diff --git a/src/Main.hs b/src/Main.hs
index f9ec73a..adada98 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -15,46 +15,41 @@
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 Text.Parsec (ParseError)
+import qualified Data.Map as M
-readInput :: Maybe [FilePath] -> IO (Either ParseError [P.Declaration])
-readInput Nothing = getContents >>= return . P.runIndentParser P.parseDeclarations
-readInput (Just input) = fmap (fmap concat . sequence) $ forM input $ \inputFile -> do
- text <- U.readFile inputFile
- return $ P.runIndentParser P.parseDeclarations text
-
-compile :: Maybe [FilePath] -> Maybe FilePath -> Maybe FilePath -> IO ()
-compile input output externs = do
- asts <- readInput input
+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
Left err -> do
U.print err
exitFailure
Right decls ->
case P.compile decls of
- Left err -> do
- U.putStrLn err
+ Left error -> do
+ U.putStrLn error
exitFailure
Right (js, exts, _) -> do
- case output of
+ case outputFile of
Just path -> U.writeFile path js
Nothing -> U.putStrLn js
- case externs of
+ case externsFile 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 = value $ posAny [] $ posInfo
+inputFiles = nonEmpty $ posAny [] $ posInfo
{ posDoc = "The input .ps files" }
outputFile :: Term (Maybe FilePath)
@@ -65,14 +60,8 @@ 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 <$> stdInOrInputFiles <*> outputFile <*> externsFile
+term = compile <$> inputFiles <*> outputFile <*> externsFile
termInfo :: TermInfo
termInfo = defTI
@@ -81,5 +70,4 @@ termInfo = defTI
, termDoc = "Compiles PureScript to Javascript"
}
-main :: IO ()
main = run (term, termInfo)
diff --git a/tests/Main.hs b/tests/Main.hs
index d14fc7f..74dfd19 100644
--- a/tests/Main.hs
+++ b/tests/Main.hs
@@ -58,14 +58,13 @@ 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 (".purs" `isSuffixOf` inputFile) $
+ forM_ passingTestCases $ \inputFile -> when (".ps" `isSuffixOf` inputFile) $
assertCompiles (passing ++ pathSeparator : inputFile)
let failing = examples ++ pathSeparator : "failing"
failingTestCases <- getDirectoryContents failing
- forM_ failingTestCases $ \inputFile -> when (".purs" `isSuffixOf` inputFile) $
+ forM_ failingTestCases $ \inputFile -> when (".ps" `isSuffixOf` inputFile) $
assertDoesNotCompile (failing ++ pathSeparator : inputFile)
exitSuccess