summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPhilFreeman <>2013-11-01 19:28:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2013-11-01 19:28:00 (GMT)
commit786efea9be659ae84b3de16c1e73f3dcee62a72e (patch)
treec30fa0f22961bb5dd79db446d75fe1d7d2ef5506
version 0.1.00.1.0
-rw-r--r--LICENSE20
-rw-r--r--Setup.lhs6
-rw-r--r--purescript.cabal52
-rw-r--r--src/Main.hs74
-rw-r--r--src/PureScript.hs26
-rw-r--r--src/PureScript/CodeGen.hs21
-rw-r--r--src/PureScript/CodeGen/Common.hs80
-rw-r--r--src/PureScript/CodeGen/Common/Gen.hs31
-rw-r--r--src/PureScript/CodeGen/Externs.hs36
-rw-r--r--src/PureScript/CodeGen/JS.hs232
-rw-r--r--src/PureScript/CodeGen/Pretty/Kinds.hs50
-rw-r--r--src/PureScript/CodeGen/Pretty/Types.hs95
-rw-r--r--src/PureScript/CodeGen/Pretty/Values.hs185
-rw-r--r--src/PureScript/Declarations.hs39
-rw-r--r--src/PureScript/Kinds.hs25
-rw-r--r--src/PureScript/Names.hs26
-rw-r--r--src/PureScript/Parser.hs22
-rw-r--r--src/PureScript/Parser/Common.hs181
-rw-r--r--src/PureScript/Parser/Declarations.hs100
-rw-r--r--src/PureScript/Parser/Kinds.hs41
-rw-r--r--src/PureScript/Parser/State.hs27
-rw-r--r--src/PureScript/Parser/Types.hs91
-rw-r--r--src/PureScript/Parser/Values.hs292
-rw-r--r--src/PureScript/Pretty.hs22
-rw-r--r--src/PureScript/TypeChecker.hs96
-rw-r--r--src/PureScript/TypeChecker/Kinds.hs183
-rw-r--r--src/PureScript/TypeChecker/Monad.hs67
-rw-r--r--src/PureScript/TypeChecker/Synonyms.hs56
-rw-r--r--src/PureScript/TypeChecker/Types.hs626
-rw-r--r--src/PureScript/Types.hs43
-rw-r--r--src/PureScript/Values.hs97
-rw-r--r--tests/Main.hs71
32 files changed, 3013 insertions, 0 deletions
diff --git a/LICENSE b/LICENSE
new file mode 100644
index 0000000..87b8a3c
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,20 @@
+The MIT License (MIT)
+
+Copyright (c) 2013 Phil Freeman
+
+Permission is hereby granted, free of charge, to any person obtaining a copy of
+this software and associated documentation files (the "Software"), to deal in
+the Software without restriction, including without limitation the rights to
+use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of
+the Software, and to permit persons to whom the Software is furnished to do so,
+subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in all
+copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
+FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR
+COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER
+IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
+CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
diff --git a/Setup.lhs b/Setup.lhs
new file mode 100644
index 0000000..a630405
--- /dev/null
+++ b/Setup.lhs
@@ -0,0 +1,6 @@
+#!/usr/bin/runhaskell
+> module Main where
+> import Distribution.Simple
+> main :: IO ()
+> main = defaultMain
+
diff --git a/purescript.cabal b/purescript.cabal
new file mode 100644
index 0000000..bc2c6f1
--- /dev/null
+++ b/purescript.cabal
@@ -0,0 +1,52 @@
+name: purescript
+version: 0.1.0
+cabal-version: >=1.8
+build-type: Simple
+license: MIT
+license-file: LICENSE
+copyright: (c) Phil Freeman 2013
+maintainer: Phil Freeman <paf31@cantab.net>
+stability: experimental
+synopsis: PureScript Programming Language Compiler
+description: A small compile-to-JS language with extensible records and type-safe blocks
+author: Phil Freeman <paf31@cantab.net>
+data-dir: ""
+
+library
+ build-depends: base >=4 && <5, syb -any, cmdtheline -any,
+ containers -any, mtl -any, transformers -any, parsec -any,
+ utf8-string -any
+ exposed-modules: PureScript.CodeGen.Pretty.Values
+ PureScript.CodeGen.Pretty.Types PureScript PureScript.Declarations
+ PureScript.Names PureScript.TypeChecker.Synonyms
+ PureScript.CodeGen.Externs PureScript.CodeGen.JS
+ PureScript.CodeGen.Common.Gen PureScript.CodeGen.Common Main
+ PureScript.CodeGen PureScript.Kinds PureScript.Parser
+ PureScript.TypeChecker PureScript.Types PureScript.Values
+ PureScript.Parser.Common PureScript.Parser.Declarations
+ PureScript.Parser.Types PureScript.Parser.Values
+ PureScript.TypeChecker.Kinds PureScript.TypeChecker.Monad
+ PureScript.TypeChecker.Types PureScript.Parser.State
+ PureScript.Parser.Kinds PureScript.CodeGen.Pretty.Kinds
+ exposed: True
+ buildable: True
+ hs-source-dirs: src
+ other-modules: PureScript.Pretty
+
+executable psc
+ build-depends: base >=4 && <5, cmdtheline -any, containers -any,
+ mtl -any, transformers -any, parsec -any, utf8-string -any,
+ syb -any
+ main-is: Main.hs
+ buildable: True
+ hs-source-dirs: src
+ other-modules: PureScript.Pretty
+
+test-suite tests
+ build-depends: base >=4 && <5, syb -any, directory -any,
+ filepath -any, containers -any, mtl -any, transformers -any,
+ parsec -any, utf8-string -any, purescript -any
+ type: exitcode-stdio-1.0
+ main-is: Main.hs
+ buildable: True
+ hs-source-dirs: tests \ No newline at end of file
diff --git a/src/Main.hs b/src/Main.hs
new file mode 100644
index 0000000..a203c6c
--- /dev/null
+++ b/src/Main.hs
@@ -0,0 +1,74 @@
+-----------------------------------------------------------------------------
+--
+-- Module : Main
+-- Copyright : (c) Phil Freeman 2013
+-- License : MIT
+--
+-- Maintainer : Phil Freeman <paf31@cantab.net>
+-- Stability : experimental
+-- Portability :
+--
+-- |
+--
+-----------------------------------------------------------------------------
+
+module Main where
+
+import PureScript
+import Data.Maybe (mapMaybe)
+import Data.List (intercalate)
+import System.Console.CmdTheLine
+import Control.Applicative
+import Control.Monad (forM)
+import System.Exit (exitSuccess, exitFailure)
+import qualified Text.Parsec as P
+import qualified System.IO.UTF8 as U
+import qualified Data.Map as M
+
+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 $ runIndentParser parseDeclarations text
+ case asts of
+ Left err -> do
+ U.print err
+ exitFailure
+ Right decls ->
+ case check (typeCheckAll decls) of
+ Left typeError -> do
+ U.putStrLn typeError
+ exitFailure
+ Right (_, env) -> do
+ let js = intercalate "\n" $ mapMaybe declToJs decls
+ case outputFile of
+ Just path -> U.writeFile path js
+ Nothing -> U.putStrLn js
+ case externsFile of
+ Nothing -> return ()
+ Just filePath -> U.writeFile filePath $ intercalate "\n" $ mapMaybe (externToPs env) decls
+ exitSuccess
+
+inputFiles :: Term [FilePath]
+inputFiles = nonEmpty $ posAny [] $ posInfo
+ { posDoc = "The input .ps files" }
+
+outputFile :: Term (Maybe FilePath)
+outputFile = value $ opt Nothing $ (optInfo [ "o", "output" ])
+ { optDoc = "The output .js file" }
+
+externsFile :: Term (Maybe FilePath)
+externsFile = value $ opt Nothing $ (optInfo [ "e", "externs" ])
+ { optDoc = "The output .e.ps file" }
+
+term :: Term (IO ())
+term = compile <$> inputFiles <*> outputFile <*> externsFile
+
+termInfo :: TermInfo
+termInfo = defTI
+ { termName = "psc"
+ , version = "1.0"
+ , termDoc = "Compiles PureScript to Javascript"
+ }
+
+main = run (term, termInfo)
diff --git a/src/PureScript.hs b/src/PureScript.hs
new file mode 100644
index 0000000..79336cc
--- /dev/null
+++ b/src/PureScript.hs
@@ -0,0 +1,26 @@
+-----------------------------------------------------------------------------
+--
+-- Module : PureScript
+-- Copyright : (c) Phil Freeman 2013
+-- License : MIT
+--
+-- Maintainer : Phil Freeman <paf31@cantab.net>
+-- Stability : experimental
+-- Portability :
+--
+-- |
+--
+-----------------------------------------------------------------------------
+
+module PureScript (module P) where
+
+import PureScript.Values as P
+import PureScript.Types as P
+import PureScript.Kinds as P
+import PureScript.Declarations as P
+import PureScript.Names as P
+import PureScript.Parser as P
+import PureScript.CodeGen as P
+import PureScript.TypeChecker as P
+import PureScript.Pretty as P
+
diff --git a/src/PureScript/CodeGen.hs b/src/PureScript/CodeGen.hs
new file mode 100644
index 0000000..1045a2a
--- /dev/null
+++ b/src/PureScript/CodeGen.hs
@@ -0,0 +1,21 @@
+-----------------------------------------------------------------------------
+--
+-- Module : PureScript.CodeGen
+-- Copyright : (c) Phil Freeman 2013
+-- License : MIT
+--
+-- Maintainer : Phil Freeman <paf31@cantab.net>
+-- Stability : experimental
+-- Portability :
+--
+-- |
+--
+-----------------------------------------------------------------------------
+
+module PureScript.CodeGen (
+ module PureScript.CodeGen.JS,
+ module PureScript.CodeGen.Externs
+) where
+
+import PureScript.CodeGen.JS
+import PureScript.CodeGen.Externs
diff --git a/src/PureScript/CodeGen/Common.hs b/src/PureScript/CodeGen/Common.hs
new file mode 100644
index 0000000..b2399e0
--- /dev/null
+++ b/src/PureScript/CodeGen/Common.hs
@@ -0,0 +1,80 @@
+-----------------------------------------------------------------------------
+--
+-- Module : PureScript.CodeGen.Common
+-- Copyright : (c) Phil Freeman 2013
+-- License : MIT
+--
+-- Maintainer : Phil Freeman <paf31@cantab.net>
+-- Stability : experimental
+-- Portability :
+--
+-- |
+--
+-----------------------------------------------------------------------------
+
+{-# LANGUAGE GeneralizedNewtypeDeriving, GADTs #-}
+
+module PureScript.CodeGen.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 PureScript.Names
+import PureScript.Values
+import PureScript.Types
+import PureScript.Declarations
+
+identToJs :: Ident -> String
+identToJs (Ident name) = name
+identToJs (Op op) = concatMap opCharToString op
+ where
+ opCharToString :: Char -> String
+ opCharToString = (:) '$'. show . ord
+
+newtype Pattern a b = Pattern { runPattern :: A.Kleisli Maybe a b } deriving (C.Category, A.Arrow, A.ArrowZero, A.ArrowPlus)
+
+instance Functor (Pattern a) where
+ fmap f (Pattern p) = Pattern $ A.Kleisli $ fmap f . A.runKleisli p
+
+pattern :: Pattern a b -> a -> Maybe b
+pattern = A.runKleisli . runPattern
+
+parens :: String -> String
+parens s = ('(':s) ++ ")"
+
+chainl :: Pattern a (a, a) -> (r -> r -> r) -> Pattern a r -> Pattern a r
+chainl split f p = fix $ \c -> split >>> ((c <+> p) *** p) >>> A.arr (uncurry f)
+
+chainr :: Pattern a (a, a) -> (r -> r -> r) -> Pattern a r -> Pattern a r
+chainr split f p = fix $ \c -> split >>> (p *** (c <+> p)) >>> A.arr (uncurry f)
+
+wrap :: Pattern a (s, a) -> (s -> r -> r) -> Pattern a r -> Pattern a r
+wrap split f p = fix $ \c -> split >>> (C.id *** (c <+> p)) >>> A.arr (uncurry f)
+
+split :: Pattern a (s, t) -> (s -> t -> r) -> Pattern a r -> Pattern a r
+split s f p = s >>> A.arr (uncurry f)
+
+data OperatorTable a r = OperatorTable { runOperatorTable :: [ [Operator a r] ] }
+
+data Operator a r where
+ AssocL :: Pattern a (a, a) -> (r -> r -> r) -> Operator a r
+ AssocR :: Pattern a (a, a) -> (r -> r -> r) -> Operator a r
+ Wrap :: Pattern a (s, a) -> (s -> r -> r) -> Operator a r
+ Split :: Pattern a (s, t) -> (s -> t -> r) -> Operator a r
+
+buildPrettyPrinter :: OperatorTable a r -> Pattern a r -> Pattern a r
+buildPrettyPrinter table p = foldl (\p' ops -> foldl1 (<+>) (flip map ops $ \op ->
+ case op of
+ AssocL pat g -> chainl pat g p'
+ AssocR pat g -> chainr pat g p'
+ Wrap pat g -> wrap pat g p'
+ Split pat g -> split pat g p'
+ ) <+> p') p $ runOperatorTable table
diff --git a/src/PureScript/CodeGen/Common/Gen.hs b/src/PureScript/CodeGen/Common/Gen.hs
new file mode 100644
index 0000000..677e0fa
--- /dev/null
+++ b/src/PureScript/CodeGen/Common/Gen.hs
@@ -0,0 +1,31 @@
+-----------------------------------------------------------------------------
+--
+-- Module : PureScript.CodeGen.Common.Gen
+-- Copyright : (c) Phil Freeman 2013
+-- License : MIT
+--
+-- Maintainer : Phil Freeman <paf31@cantab.net>
+-- Stability : experimental
+-- Portability :
+--
+-- |
+--
+-----------------------------------------------------------------------------
+
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+module PureScript.CodeGen.Common.Gen where
+
+import Control.Monad.State
+import Control.Applicative
+
+newtype Gen a = Gen { unGen :: State Int a } deriving (Functor, Applicative, Monad, MonadState Int)
+
+runGen :: Gen a -> a
+runGen = flip evalState 0 . unGen
+
+fresh :: Gen String
+fresh = do
+ n <- get
+ modify (+ 1)
+ return $ '_' : show n
diff --git a/src/PureScript/CodeGen/Externs.hs b/src/PureScript/CodeGen/Externs.hs
new file mode 100644
index 0000000..9c3ae62
--- /dev/null
+++ b/src/PureScript/CodeGen/Externs.hs
@@ -0,0 +1,36 @@
+-----------------------------------------------------------------------------
+--
+-- Module : PureScript.CodeGen.Externs
+-- Copyright : (c) Phil Freeman 2013
+-- License : MIT
+--
+-- Maintainer : Phil Freeman <paf31@cantab.net>
+-- Stability : experimental
+-- Portability :
+--
+-- |
+--
+-----------------------------------------------------------------------------
+
+module PureScript.CodeGen.Externs (
+ externToPs
+) where
+
+import Data.List (intercalate)
+import qualified Data.Map as M
+import PureScript.Declarations
+import PureScript.TypeChecker.Monad
+import PureScript.CodeGen.Pretty.Types
+import PureScript.CodeGen.Pretty.Kinds
+
+externToPs :: Environment -> Declaration -> Maybe String
+externToPs env (ValueDeclaration name _) = do
+ (ty, _) <- M.lookup name $ names env
+ return $ "extern " ++ show name ++ " :: " ++ prettyPrintPolyType ty
+externToPs env (ExternDeclaration name ty) =
+ return $ "extern " ++ show name ++ " :: " ++ prettyPrintPolyType ty
+externToPs env (ExternDataDeclaration name kind) =
+ return $ "extern data " ++ name ++ " :: " ++ prettyPrintKind kind
+externToPs env (TypeSynonymDeclaration name args ty) =
+ return $ "type " ++ name ++ " " ++ unwords args ++ " = " ++ prettyPrintType ty
+externToPs _ _ = Nothing
diff --git a/src/PureScript/CodeGen/JS.hs b/src/PureScript/CodeGen/JS.hs
new file mode 100644
index 0000000..87caf43
--- /dev/null
+++ b/src/PureScript/CodeGen/JS.hs
@@ -0,0 +1,232 @@
+-----------------------------------------------------------------------------
+--
+-- Module : PureScript.CodeGen.JS
+-- Copyright : (c) Phil Freeman 2013
+-- License : MIT
+--
+-- Maintainer : Phil Freeman <paf31@cantab.net>
+-- Stability : experimental
+-- Portability :
+--
+-- |
+--
+-----------------------------------------------------------------------------
+
+module PureScript.CodeGen.JS (
+ declToJs
+) where
+
+import Data.Char
+import Data.Maybe (fromMaybe)
+import Data.List (intercalate)
+import qualified Control.Arrow as A
+import Control.Arrow ((<+>))
+import Control.Monad (forM)
+import Control.Applicative
+
+import PureScript.Types
+import PureScript.Values
+import PureScript.Names
+import PureScript.Declarations
+import PureScript.CodeGen.Common
+import PureScript.CodeGen.Common.Gen
+
+declToJs :: Declaration -> Maybe String
+declToJs (ValueDeclaration ident (Abs args ret)) = Just $ "function " ++ identToJs ident ++ "(" ++ intercalate "," (map identToJs args) ++ ") { return " ++ valueToJs ret ++ "; }"
+declToJs (ValueDeclaration ident val) = Just $ "var " ++ identToJs ident ++ " = " ++ valueToJs val ++ ";"
+declToJs (DataDeclaration _ _ ctors) =
+ Just $ flip concatMap ctors $ \(ctor, maybeTy) ->
+ case maybeTy of
+ Nothing -> "var " ++ ctor ++ " = { ctor: '" ++ ctor ++ "' };"
+ Just _ -> "var " ++ ctor ++ " = function (value) { return { ctor: '" ++ ctor ++ "', value: value }; };"
+declToJs _ = Nothing
+
+literals :: Pattern Value String
+literals = Pattern $ A.Kleisli match
+ where
+ match (NumericLiteral n) = Just $ either show show n
+ match (StringLiteral s) = Just $ show s
+ match (BooleanLiteral True) = Just "true"
+ match (BooleanLiteral False) = Just "false"
+ match (ArrayLiteral xs) = Just $ "[" ++ intercalate "," (map valueToJs xs) ++ "]"
+ match (ObjectLiteral ps) = Just $ "{" ++ intercalate "," (map objectPropertyToJs ps) ++ "}"
+ match (ObjectUpdate o ps) = Just $ "Object.extend("
+ ++ valueToJs o ++ ", { "
+ ++ intercalate ", " (map objectPropertyToJs ps) ++ " }"
+ match (Constructor name) = Just name
+ match (Block sts) = Just $ "(function () {" ++ intercalate ";" (map statementToJs sts) ++ "})()"
+ match (Case value binders) = Just $ "(" ++ runGen (bindersToJs binders) ++ ")(" ++ valueToJs value ++ ")"
+ where
+ bindersToJs :: [(Binder, Value)] -> Gen String
+ bindersToJs binders = do
+ valName <- fresh
+ jss <- forM binders $ \(binder, result) -> do
+ let js = valueToJs result
+ binderToJs valName ("return " ++ js ++ ";") binder
+ return $ "function (" ++ valName ++ ") {" ++ concat jss ++ "throw \"Failed pattern match\"; }"
+ match (Var ident) = Just (identToJs ident)
+ match _ = Nothing
+
+ifThenElse :: Pattern Value ((Value, Value), Value)
+ifThenElse = Pattern $ A.Kleisli match
+ where
+ match (IfThenElse cond th el) = Just ((th, el), cond)
+ match _ = Nothing
+
+accessor :: Pattern Value (String, Value)
+accessor = Pattern $ A.Kleisli match
+ where
+ match (Accessor prop val) = Just (prop, val)
+ match _ = Nothing
+
+indexer :: Pattern Value (String, Value)
+indexer = Pattern $ A.Kleisli match
+ where
+ match (Indexer index val) = Just (valueToJs index, val)
+ match _ = Nothing
+
+app :: Pattern Value (String, Value)
+app = Pattern $ A.Kleisli match
+ where
+ match (App val args) = Just (intercalate "," (map valueToJs args), val)
+ match _ = Nothing
+
+lam :: Pattern Value ([String], Value)
+lam = Pattern $ A.Kleisli match
+ where
+ match (Abs args val) = Just (map identToJs args, val)
+ match _ = Nothing
+
+unary :: UnaryOperator -> String -> Operator Value String
+unary op str = Wrap pattern (++)
+ where
+ pattern :: Pattern Value (String, Value)
+ pattern = Pattern $ A.Kleisli match
+ where
+ match (Unary op' val) | op' == op = Just (str, val)
+ match _ = Nothing
+
+binary :: BinaryOperator -> String -> Operator Value String
+binary op str = AssocR pattern (\v1 v2 -> v1 ++ " " ++ str ++ " " ++ v2)
+ where
+ pattern :: Pattern Value (Value, Value)
+ pattern = Pattern $ A.Kleisli match
+ where
+ match (Binary op' v1 v2) | op' == op = Just (v1, v2)
+ match _ = Nothing
+
+valueToJs :: Value -> String
+valueToJs = fromMaybe (error "Incomplete pattern") . pattern matchValue
+ where
+ matchValue :: Pattern Value String
+ matchValue = buildPrettyPrinter operators (literals <+> fmap parens matchValue)
+ operators :: OperatorTable Value String
+ operators =
+ OperatorTable [ [ Wrap accessor $ \prop val -> val ++ "." ++ prop ]
+ , [ Wrap indexer $ \index val -> val ++ "[" ++ index ++ "]" ]
+ , [ Wrap app $ \args val -> val ++ "(" ++ args ++ ")" ]
+ , [ Split lam $ \args val -> "function (" ++ intercalate "," args ++ ") { return " ++ valueToJs val ++ "; }" ]
+ , [ Wrap ifThenElse $ \(th, el) cond -> cond ++ " ? " ++ valueToJs th ++ " : " ++ valueToJs el ]
+ , [ binary LessThan "<" ]
+ , [ binary LessThanOrEqualTo "<=" ]
+ , [ binary GreaterThan ">" ]
+ , [ binary GreaterThanOrEqualTo ">=" ]
+ , [ unary Not "!" ]
+ , [ unary BitwiseNot "~" ]
+ , [ unary Negate "-" ]
+ , [ binary Multiply "*" ]
+ , [ binary Divide "/" ]
+ , [ binary Modulus "%" ]
+ , [ binary Concat "+" ]
+ , [ binary Add "+" ]
+ , [ binary Subtract "-" ]
+ , [ binary ShiftLeft "<<" ]
+ , [ binary ShiftRight ">>" ]
+ , [ binary ZeroFillShiftRight ">>>" ]
+ , [ binary EqualTo "===" ]
+ , [ binary NotEqualTo "!==" ]
+ , [ binary BitwiseAnd "&" ]
+ , [ binary BitwiseXor "^" ]
+ , [ binary BitwiseOr "|" ]
+ , [ binary And "&&" ]
+ , [ binary Or "||" ]
+ ]
+
+binderToJs :: String -> String -> Binder -> Gen String
+binderToJs varName done NullBinder = return done
+binderToJs varName done (StringBinder str) =
+ return $ "if (" ++ varName ++ " === \"" ++ str ++ "\") {" ++ done ++ " }"
+binderToJs varName done (NumberBinder num) =
+ return $ "if (" ++ varName ++ " === " ++ either show show num ++ ") {" ++ done ++ " }"
+binderToJs varName done (BooleanBinder True) =
+ return $ "if (" ++ varName ++ ") {" ++ done ++ " }"
+binderToJs varName done (BooleanBinder False) =
+ return $ "if (!" ++ varName ++ ") {" ++ done ++ " }"
+binderToJs varName done (VarBinder ident) =
+ return $ "var " ++ identToJs ident ++ " = " ++ varName ++ "; " ++ done
+binderToJs varName done (NullaryBinder ctor) =
+ return $ "if (" ++ varName ++ ".ctor === \"" ++ ctor ++ "\") { " ++ done ++ " }"
+binderToJs varName done (UnaryBinder ctor b) = do
+ value <- fresh
+ js <- binderToJs value done b
+ return $ "if (" ++ varName ++ ".ctor === \"" ++ ctor ++ "\") { " ++ "var " ++ value ++ " = " ++ varName ++ ".value; " ++ js ++ " }"
+binderToJs varName done (ObjectBinder bs) = go done bs
+ where
+ go done [] = return done
+ go done ((prop, binder):bs) = do
+ propVar <- fresh
+ done' <- go done bs
+ js <- binderToJs propVar done' binder
+ return $ "var " ++ propVar ++ " = " ++ varName ++ "." ++ prop ++ ";" ++ js
+binderToJs varName done (ArrayBinder bs rest) = do
+ js <- go done rest 0 bs
+ return $ "if (" ++ varName ++ ".length " ++ cmp ++ " " ++ show (length bs) ++ ") { " ++ js ++ " }"
+ where
+ cmp = maybe "===" (const ">=") rest
+ go done Nothing _ [] = return done
+ go done (Just binder) index [] = do
+ restVar <- fresh
+ js <- binderToJs restVar done binder
+ return $ "var " ++ restVar ++ " = " ++ varName ++ ".slice(" ++ show index ++ "); " ++ js
+ go done rest index (binder:bs) = do
+ elVar <- fresh
+ done' <- go done rest (index + 1) bs
+ js <- binderToJs elVar done' binder
+ return $ "var " ++ elVar ++ " = " ++ varName ++ "[" ++ show index ++ "]; " ++ js
+binderToJs varName done (NamedBinder ident binder) = do
+ js <- binderToJs varName done binder
+ return $ "var " ++ identToJs ident ++ " = " ++ varName ++ "; " ++ js
+binderToJs varName done (GuardedBinder cond binder) = binderToJs varName done' binder
+ where
+ done' = "if (" ++ valueToJs cond ++ ") { " ++ done ++ "}"
+
+objectPropertyToJs :: (String, Value) -> String
+objectPropertyToJs (key, value) = key ++ ": " ++ valueToJs value
+
+statementToJs :: Statement -> String
+statementToJs (VariableIntroduction ident value) = "var " ++ identToJs ident ++ " = " ++ valueToJs value
+statementToJs (Assignment target value) = identToJs target ++ " = " ++ valueToJs value
+statementToJs (While cond sts) = "while ("
+ ++ valueToJs cond ++ ") {"
+ ++ intercalate ";" (map statementToJs sts) ++ "}"
+statementToJs (For ident start end sts) = "for (" ++
+ identToJs ident ++ " = " ++ valueToJs start ++ ";"
+ ++ identToJs ident ++ " < " ++ valueToJs end ++ ";"
+ ++ identToJs ident ++ "++) {"
+ ++ intercalate ";" (map statementToJs sts) ++ "}"
+statementToJs (ForEach ident arr sts) = valueToJs arr
+ ++ ".forEach(function(" ++ identToJs ident ++ ") {"
+ ++ intercalate ";" (map statementToJs sts) ++ "})"
+statementToJs (If ifst) = ifStatementToJs ifst
+statementToJs (Return value) = "return " ++ valueToJs value
+
+ifStatementToJs :: IfStatement -> String
+ifStatementToJs (IfStatement cond thens elst) =
+ "if ("
+ ++ valueToJs cond ++ ") {"
+ ++ intercalate ";" (map statementToJs thens) ++ "}"
+ ++ maybe "" elseStatementToJs elst
+
+elseStatementToJs :: ElseStatement -> String
+elseStatementToJs (Else sts) = " else {" ++ intercalate ";" (map statementToJs sts) ++ "}"
+elseStatementToJs (ElseIf ifst) = " else " ++ ifStatementToJs ifst
diff --git a/src/PureScript/CodeGen/Pretty/Kinds.hs b/src/PureScript/CodeGen/Pretty/Kinds.hs
new file mode 100644
index 0000000..e5af635
--- /dev/null
+++ b/src/PureScript/CodeGen/Pretty/Kinds.hs
@@ -0,0 +1,50 @@
+-----------------------------------------------------------------------------
+--
+-- Module : PureScript.CodeGen.Pretty.Kinds
+-- Copyright : (c) Phil Freeman 2013
+-- License : MIT
+--
+-- Maintainer : Phil Freeman <paf31@cantab.net>
+-- Stability : experimental
+-- Portability :
+--
+-- |
+--
+-----------------------------------------------------------------------------
+
+module PureScript.CodeGen.Pretty.Kinds (
+ prettyPrintKind
+) 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 PureScript.Kinds
+import PureScript.CodeGen.Common
+
+typeLiterals :: Pattern Kind String
+typeLiterals = Pattern $ A.Kleisli match
+ where
+ match Star = Just "*"
+ match Row = Just "#"
+ match (KUnknown u) = Just $ 'u' : show u
+ match _ = Nothing
+
+funKind :: Pattern Kind (Kind, Kind)
+funKind = Pattern $ A.Kleisli match
+ where
+ match (FunKind arg ret) = Just (arg, ret)
+ match _ = Nothing
+
+prettyPrintKind :: Kind -> String
+prettyPrintKind = fromMaybe (error "Incomplete pattern") . pattern matchKind
+ where
+ matchKind :: Pattern Kind String
+ matchKind = buildPrettyPrinter operators (typeLiterals <+> fmap parens matchKind)
+ operators :: OperatorTable Kind String
+ operators =
+ OperatorTable [ [ AssocR funKind $ \arg ret -> arg ++ " -> " ++ ret ] ]
diff --git a/src/PureScript/CodeGen/Pretty/Types.hs b/src/PureScript/CodeGen/Pretty/Types.hs
new file mode 100644
index 0000000..4b7c085
--- /dev/null
+++ b/src/PureScript/CodeGen/Pretty/Types.hs
@@ -0,0 +1,95 @@
+-----------------------------------------------------------------------------
+--
+-- Module : PureScript.CodeGen.Pretty.Types
+-- Copyright : (c) Phil Freeman 2013
+-- License : MIT
+--
+-- Maintainer : Phil Freeman <paf31@cantab.net>
+-- Stability : experimental
+-- Portability :
+--
+-- |
+--
+-----------------------------------------------------------------------------
+
+module PureScript.CodeGen.Pretty.Types (
+ prettyPrintType,
+ prettyPrintRow,
+ prettyPrintPolyType
+) 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 PureScript.Values
+import PureScript.Types
+import PureScript.Names
+import PureScript.Declarations
+import PureScript.TypeChecker.Monad
+import PureScript.CodeGen.Common
+
+typeLiterals :: Pattern Type String
+typeLiterals = Pattern $ A.Kleisli match
+ where
+ match Number = Just "Number"
+ match String = Just "String"
+ match Boolean = Just "Boolean"
+ match (Array ty) = Just $ "[" ++ prettyPrintType ty ++ "]"
+ match (Object row) = Just $ "{ " ++ prettyPrintRow row ++ " }"
+ match (TypeVar var) = Just var
+ match (TypeConstructor ctor) = Just ctor
+ match (TUnknown u) = Just $ 'u' : show u
+ match (SaturatedTypeSynonym name args) = Just $ name ++ "<" ++ intercalate "," (map prettyPrintType args) ++ ">"
+ match _ = Nothing
+
+prettyPrintRow :: Row -> String
+prettyPrintRow = (\(tys, tail) -> intercalate "; " (map (uncurry nameAndTypeToPs) tys) ++ tailToPs tail) . toList []
+ where
+ nameAndTypeToPs :: String -> Type -> String
+ nameAndTypeToPs name ty = name ++ " :: " ++ prettyPrintType ty
+ tailToPs :: Row -> String
+ tailToPs REmpty = ""
+ tailToPs (RUnknown u) = " | " ++ show u
+ tailToPs (RowVar var) = " | " ++ var
+ toList :: [(String, Type)] -> Row -> ([(String, Type)], Row)
+ toList tys (RCons name ty row) = toList ((name, ty):tys) row
+ toList tys r = (tys, r)
+
+typeApp :: Pattern Type (Type, Type)
+typeApp = Pattern $ A.Kleisli match
+ where
+ match (TypeApp f x) = Just (f, x)
+ match _ = Nothing
+
+singleArgumentFunction :: Pattern Type (Type, Type)
+singleArgumentFunction = Pattern $ A.Kleisli match
+ where
+ match (Function [arg] ret) = Just (arg, ret)
+ match _ = Nothing
+
+function :: Pattern Type ([Type], Type)
+function = Pattern $ A.Kleisli match
+ where
+ match (Function args ret) = Just (args, ret)
+ match _ = Nothing
+
+prettyPrintType :: Type -> String
+prettyPrintType = fromMaybe (error "Incomplete pattern") . pattern matchType
+ where
+ matchType :: Pattern Type String
+ matchType = buildPrettyPrinter operators (typeLiterals <+> fmap parens matchType)
+ operators :: OperatorTable Type String
+ operators =
+ OperatorTable [ [ AssocL typeApp $ \f x -> f ++ " " ++ x ]
+ , [ AssocR singleArgumentFunction $ \arg ret -> arg ++ " -> " ++ ret
+ , Wrap function $ \args ret -> "(" ++ intercalate ", " (map prettyPrintType args) ++ ") -> " ++ ret
+ ]
+ ]
+
+prettyPrintPolyType :: PolyType -> String
+prettyPrintPolyType (PolyType [] ty) = prettyPrintType ty
+prettyPrintPolyType (PolyType idents ty) = "forall " ++ unwords idents ++ ". " ++ prettyPrintType ty
diff --git a/src/PureScript/CodeGen/Pretty/Values.hs b/src/PureScript/CodeGen/Pretty/Values.hs
new file mode 100644
index 0000000..5fb79ba
--- /dev/null
+++ b/src/PureScript/CodeGen/Pretty/Values.hs
@@ -0,0 +1,185 @@
+-----------------------------------------------------------------------------
+--
+-- Module : PureScript.CodeGen.Pretty.Values
+-- Copyright : Kinds.hs(c) Phil Freeman 2013
+-- License : MIT
+--
+-- Maintainer : Phil Freeman <paf31@cantab.net>
+-- Stability : experimental
+-- Portability :
+--
+-- |
+--
+-----------------------------------------------------------------------------
+
+module PureScript.CodeGen.Pretty.Values (
+ prettyPrintValue,
+ 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 PureScript.Types
+import PureScript.Values
+import PureScript.Names
+import PureScript.CodeGen.Common
+
+literals :: Pattern Value String
+literals = Pattern $ A.Kleisli match
+ where
+ match (NumericLiteral n) = Just $ either show show n
+ match (StringLiteral s) = Just $ show s
+ match (BooleanLiteral True) = Just "true"
+ match (BooleanLiteral False) = Just "false"
+ match (ArrayLiteral xs) = Just $ "[" ++ intercalate ", " (map prettyPrintValue xs) ++ "]"
+ match (ObjectLiteral ps) = Just $ "{" ++ intercalate ", " (map (uncurry prettyPrintObjectProperty) ps) ++ "}"
+ match (Constructor name) = Just name
+ match (Block sts) = Just $ "do { " ++ intercalate " ; " (map prettyPrintStatement sts) ++ " }"
+ match (Case value binders) = Just $ "case " ++ prettyPrintValue value ++ " of { " ++ intercalate " ; " (map (uncurry prettyPrintCaseAlternative) binders) ++ " }"
+ match (Var ident) = Just $ show ident
+ match _ = Nothing
+
+prettyPrintCaseAlternative :: Binder -> Value -> String
+prettyPrintCaseAlternative binder val = prettyPrintBinder binder ++ " -> " ++ prettyPrintValue val
+
+ifThenElse :: Pattern Value ((Value, Value), Value)
+ifThenElse = Pattern $ A.Kleisli match
+ where
+ match (IfThenElse cond th el) = Just ((th, el), cond)
+ match _ = Nothing
+
+accessor :: Pattern Value (String, Value)
+accessor = Pattern $ A.Kleisli match
+ where
+ match (Accessor prop val) = Just (prop, val)
+ match _ = Nothing
+
+indexer :: Pattern Value (String, Value)
+indexer = Pattern $ A.Kleisli match
+ where
+ match (Indexer index val) = Just (prettyPrintValue index, val)
+ match _ = Nothing
+
+objectUpdate :: Pattern Value ([String], Value)
+objectUpdate = Pattern $ A.Kleisli match
+ where
+ match (ObjectUpdate o ps) = Just (flip map ps $ \(key, val) -> key ++ " = " ++ prettyPrintValue val, o)
+ match _ = Nothing
+
+app :: Pattern Value (String, Value)
+app = Pattern $ A.Kleisli match
+ where
+ match (App val args) = Just (intercalate "," (map prettyPrintValue args), val)
+ match _ = Nothing
+
+lam :: Pattern Value ([String], Value)
+lam = Pattern $ A.Kleisli match
+ where
+ match (Abs args val) = Just (map show args, val)
+ match _ = Nothing
+
+unary :: UnaryOperator -> String -> Operator Value String
+unary op str = Wrap pattern (++)
+ where
+ pattern :: Pattern Value (String, Value)
+ pattern = Pattern $ A.Kleisli match
+ where
+ match (Unary op' val) | op' == op = Just (str, val)
+ match _ = Nothing
+
+binary :: BinaryOperator -> String -> Operator Value String
+binary op str = AssocR pattern (\v1 v2 -> v1 ++ " " ++ str ++ " " ++ v2)
+ where
+ pattern :: Pattern Value (Value, Value)
+ pattern = Pattern $ A.Kleisli match
+ where
+ match (Binary op' v1 v2) | op' == op = Just (v1, v2)
+ match _ = Nothing
+
+prettyPrintValue :: Value -> String
+prettyPrintValue = fromMaybe (error "Incomplete pattern") . pattern matchValue
+ where
+ matchValue :: Pattern Value String
+ matchValue = buildPrettyPrinter operators (literals <+> fmap parens matchValue)
+ operators :: OperatorTable Value String
+ operators =
+ OperatorTable [ [ Wrap accessor $ \prop val -> val ++ "." ++ prop ]
+ , [ Wrap indexer $ \index val -> val ++ "[" ++ index ++ "]" ]
+ , [ Wrap objectUpdate $ \ps val -> val ++ "{ " ++ intercalate ", " ps ++ " }" ]
+ , [ Wrap app $ \args val -> val ++ "(" ++ args ++ ")" ]
+ , [ Split lam $ \args val -> "function (" ++ intercalate "," args ++ ") { return " ++ prettyPrintValue val ++ "; }" ]
+ , [ Wrap ifThenElse $ \(th, el) cond -> cond ++ " ? " ++ prettyPrintValue th ++ " : " ++ prettyPrintValue el ]
+ , [ binary LessThan "<" ]
+ , [ binary LessThanOrEqualTo "<=" ]
+ , [ binary GreaterThan ">" ]
+ , [ binary GreaterThanOrEqualTo ">=" ]
+ , [ unary Not "!" ]
+ , [ unary BitwiseNot "~" ]
+ , [ unary Negate "-" ]
+ , [ binary Multiply "*" ]
+ , [ binary Divide "/" ]
+ , [ binary Modulus "%" ]
+ , [ binary Concat "++" ]
+ , [ binary Add "+" ]
+ , [ binary Subtract "-" ]
+ , [ binary ShiftLeft "<<" ]
+ , [ binary ShiftRight ">>" ]
+ , [ binary ZeroFillShiftRight ">>>" ]
+ , [ binary EqualTo "==" ]
+ , [ binary NotEqualTo "!=" ]
+ , [ binary BitwiseAnd "&" ]
+ , [ binary BitwiseXor "^" ]
+ , [ binary BitwiseOr "|" ]
+ , [ binary And "&&" ]
+ , [ binary Or "||" ]
+ ]
+
+prettyPrintBinder :: Binder -> String
+prettyPrintBinder NullBinder = "_"
+prettyPrintBinder (StringBinder str) = show str
+prettyPrintBinder (NumberBinder num) = either show show num
+prettyPrintBinder (BooleanBinder True) = "true"
+prettyPrintBinder (BooleanBinder False) = "false"
+prettyPrintBinder (VarBinder ident) = show ident
+prettyPrintBinder (NullaryBinder ctor) = ctor
+prettyPrintBinder (UnaryBinder ctor b) = 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
+
+prettyPrintObjectProperty :: String -> Value -> String
+prettyPrintObjectProperty key value = key ++ ": " ++ prettyPrintValue value
+
+prettyPrintStatement :: Statement -> String
+prettyPrintStatement (VariableIntroduction ident value) = "var " ++ show ident ++ " = " ++ prettyPrintValue value
+prettyPrintStatement (Assignment target value) = show target ++ " = " ++ prettyPrintValue value
+prettyPrintStatement (While cond sts) = "while " ++ prettyPrintValue cond ++ ": {" ++ intercalate ";" (map prettyPrintStatement sts) ++ " }"
+prettyPrintStatement (For ident start end sts) = "for " ++ show ident
+ ++ " <- " ++ prettyPrintValue start
+ ++ " until " ++ prettyPrintValue end ++ ": {"
+ ++ intercalate "; " (map prettyPrintStatement sts) ++ " }"
+prettyPrintStatement (ForEach ident arr sts) = "foreach " ++ show ident
+ ++ " in " ++ prettyPrintValue arr ++ ": {"
+ ++ intercalate "; " (map prettyPrintStatement sts) ++ " }"
+prettyPrintStatement (If ifst) = prettyPrintIfStatement ifst
+prettyPrintStatement (Return value) = "return " ++ prettyPrintValue value
+
+prettyPrintIfStatement :: IfStatement -> String
+prettyPrintIfStatement (IfStatement cond thens elst) =
+ "if "
+ ++ prettyPrintValue cond ++ ": {"
+ ++ intercalate "; " (map prettyPrintStatement thens) ++ " }"
+ ++ maybe "" prettyPrintElseStatement elst
+
+prettyPrintElseStatement :: ElseStatement -> String
+prettyPrintElseStatement (Else sts) = "else: {" ++ intercalate "; " (map prettyPrintStatement sts) ++ " }"
+prettyPrintElseStatement (ElseIf ifst) = "else " ++ prettyPrintIfStatement ifst
diff --git a/src/PureScript/Declarations.hs b/src/PureScript/Declarations.hs
new file mode 100644
index 0000000..46c5084
--- /dev/null
+++ b/src/PureScript/Declarations.hs
@@ -0,0 +1,39 @@
+-----------------------------------------------------------------------------
+--
+-- Module : PureScript.Declarations
+-- Copyright : (c) Phil Freeman 2013
+-- License : MIT
+--
+-- Maintainer : Phil Freeman <paf31@cantab.net>
+-- Stability : experimental
+-- Portability :
+--
+-- |
+--
+-----------------------------------------------------------------------------
+
+{-# LANGUAGE DeriveDataTypeable #-}
+
+module PureScript.Declarations where
+
+import PureScript.Values
+import PureScript.Types
+import PureScript.Names
+import PureScript.Kinds
+
+import qualified Data.Data as D
+
+type Precedence = Integer
+
+data Associativity = Infixl | Infixr deriving (Show, D.Data, D.Typeable)
+
+data Fixity = Fixity Associativity Precedence deriving (Show, D.Data, D.Typeable)
+
+data Declaration
+ = DataDeclaration String [String] [(String, Maybe Type)]
+ | TypeSynonymDeclaration String [String] Type
+ | TypeDeclaration Ident PolyType
+ | ValueDeclaration Ident Value
+ | ExternDeclaration Ident PolyType
+ | ExternDataDeclaration String Kind
+ | FixityDeclaration Fixity String deriving (Show, D.Data, D.Typeable)
diff --git a/src/PureScript/Kinds.hs b/src/PureScript/Kinds.hs
new file mode 100644
index 0000000..5518f8a
--- /dev/null
+++ b/src/PureScript/Kinds.hs
@@ -0,0 +1,25 @@
+-----------------------------------------------------------------------------
+--
+-- Module : PureScript.Kinds
+-- Copyright : (c) Phil Freeman 2013
+-- License : MIT
+--
+-- Maintainer : Phil Freeman <paf31@cantab.net>
+-- Stability : experimental
+-- Portability :
+--
+-- |
+--
+-----------------------------------------------------------------------------
+
+{-# LANGUAGE DeriveDataTypeable #-}
+
+module PureScript.Kinds where
+
+import Data.Data
+
+data Kind
+ = KUnknown Int
+ | Star
+ | Row
+ | FunKind Kind Kind deriving (Show, Eq, Data, Typeable)
diff --git a/src/PureScript/Names.hs b/src/PureScript/Names.hs
new file mode 100644
index 0000000..d823c2e
--- /dev/null
+++ b/src/PureScript/Names.hs
@@ -0,0 +1,26 @@
+-----------------------------------------------------------------------------
+--
+-- Module : PureScript.Names
+-- Copyright : (c) Phil Freeman 2013
+-- License : MIT
+--
+-- Maintainer : Phil Freeman <paf31@cantab.net>
+-- Stability : experimental
+-- Portability :
+--
+-- |
+--
+-----------------------------------------------------------------------------
+
+{-# LANGUAGE DeriveDataTypeable #-}
+
+module PureScript.Names where
+
+import Data.Data
+
+data Ident = Ident String | Op String deriving (Eq, Ord, Data, Typeable)
+
+instance Show Ident where
+ show (Ident s) = s
+ show (Op op) = '(':op ++ ")"
+
diff --git a/src/PureScript/Parser.hs b/src/PureScript/Parser.hs
new file mode 100644
index 0000000..5640bb8
--- /dev/null
+++ b/src/PureScript/Parser.hs
@@ -0,0 +1,22 @@
+-----------------------------------------------------------------------------
+--
+-- Module : PureScript.Parser
+-- Copyright : (c) Phil Freeman 2013
+-- License : MIT
+--
+-- Maintainer : Phil Freeman <paf31@cantab.net>
+-- Stability : experimental
+-- Portability :
+--
+-- |
+--
+-----------------------------------------------------------------------------
+
+module PureScript.Parser (module P) where
+
+import PureScript.Parser.Common as P
+import PureScript.Parser.Types as P
+import PureScript.Parser.Values as P
+import PureScript.Parser.State as P
+import PureScript.Parser.Kinds as P
+import PureScript.Parser.Declarations as P
diff --git a/src/PureScript/Parser/Common.hs b/src/PureScript/Parser/Common.hs
new file mode 100644
index 0000000..8a19f91
--- /dev/null
+++ b/src/PureScript/Parser/Common.hs
@@ -0,0 +1,181 @@
+-----------------------------------------------------------------------------
+--
+-- Module : PureScript.Parser.Common
+-- Copyright : (c) Phil Freeman 2013
+-- License : MIT
+--
+-- Maintainer : Phil Freeman <paf31@cantab.net>
+-- Stability : experimental
+-- Portability :
+--
+-- |
+--
+-----------------------------------------------------------------------------
+
+{-# LANGUAGE FlexibleContexts #-}
+
+module PureScript.Parser.Common where
+
+import Data.Char (isSpace)
+import Control.Applicative
+import Control.Monad
+import Control.Monad.State
+import 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 PureScript.Names
+
+reservedNames :: [String]
+reservedNames = [ "case"
+ , "of"
+ , "data"
+ , "type"
+ , "var"
+ , "val"
+ , "while"
+ , "for"
+ , "foreach"
+ , "if"
+ , "then"
+ , "else"
+ , "return"
+ , "true"
+ , "false"
+ , "extern"
+ , "forall"
+ , "do"
+ , "until"
+ , "in"
+ , "break"
+ , "catch"
+ , "continue"
+ , "debugger"
+ , "default"
+ , "delete"
+ , "finally"
+ , "function"
+ , "instanceof"
+ , "new"
+ , "switch"
+ , "this"
+ , "throw"
+ , "try"
+ , "typeof"
+ , "void"
+ , "with"
+ , "Number"
+ , "String"
+ , "Boolean"
+ , "infixl"
+ , "infixr" ]
+
+reservedOpNames :: [String]
+reservedOpNames = [ "!", "~", "-", "<=", ">=", "<", ">", "*", "/", "%", "++", "+", "<<", ">>>", ">>"
+ , "==", "!=", "&", "^", "|", "&&", "||", "->" ]
+
+identStart :: P.Parsec String u Char
+identStart = P.lower <|> P.oneOf "_$"
+
+properNameStart :: P.Parsec String u Char
+properNameStart = P.upper
+
+identLetter :: P.Parsec String u Char
+identLetter = P.alphaNum <|> P.oneOf "_'"
+
+opStart :: P.Parsec String u Char
+opStart = P.oneOf "!#$%&*+/<=>?@^|-~"
+
+opLetter :: P.Parsec String u Char
+opLetter = P.oneOf ":#$%&*+./<=>?@^|"
+
+langDef = PT.LanguageDef
+ { PT.reservedNames = reservedNames
+ , PT.reservedOpNames = reservedOpNames
+ , PT.commentStart = "{-"
+ , PT.commentEnd = "-}"
+ , PT.commentLine = "--"
+ , PT.nestedComments = True
+ , PT.identStart = identStart
+ , PT.identLetter = identLetter
+ , PT.opStart = opStart
+ , PT.opLetter = opLetter
+ , PT.caseSensitive = True
+ }
+
+tokenParser = PT.makeTokenParser langDef
+
+lexeme = PT.lexeme tokenParser
+identifier = PT.identifier tokenParser
+reserved = PT.reserved tokenParser
+reservedOp = PT.reservedOp tokenParser
+operator = PT.operator tokenParser
+stringLiteral = PT.stringLiteral tokenParser
+whiteSpace = PT.whiteSpace tokenParser
+parens = PT.parens tokenParser
+braces = PT.braces tokenParser
+angles = PT.angles tokenParser
+squares = PT.squares tokenParser
+semi = PT.semi tokenParser
+comma = PT.comma tokenParser
+colon = PT.colon tokenParser
+dot = PT.dot tokenParser
+semiSep = PT.semiSep tokenParser
+semiSep1 = PT.semiSep1 tokenParser
+commaSep = PT.commaSep tokenParser
+commaSep1 = PT.commaSep1 tokenParser
+natural = PT.natural tokenParser
+
+tick :: P.Parsec String u Char
+tick = lexeme $ P.char '`'
+
+properName :: P.Parsec String u String
+properName = lexeme $ P.try ((:) <$> P.upper <*> many (PT.identLetter langDef) P.<?> "name")
+
+integerOrFloat :: P.Parsec String u (Either Integer Double)
+integerOrFloat = (Left <$> P.try (PT.natural tokenParser) <|>
+ Right <$> P.try (PT.float tokenParser)) P.<?> "number"
+
+augment :: P.Stream s m t => P.ParsecT s u m a -> P.ParsecT s u m b -> (a -> b -> a) -> P.ParsecT s u m a
+augment p q f = flip (maybe id $ flip f) <$> p <*> P.optionMaybe q
+
+fold :: P.Stream s m t => P.ParsecT s u m a -> P.ParsecT s u m b -> (a -> b -> a) -> P.ParsecT s u m a
+fold first more combine = do
+ a <- first
+ bs <- P.many more
+ return $ foldl combine a bs
+
+buildPostfixParser :: P.Stream s m t => [P.ParsecT s u m (a -> a)] -> P.ParsecT s u m a -> P.ParsecT s u m a
+buildPostfixParser f x = fold x (P.choice (map P.try f)) (flip ($))
+
+parseIdent :: P.Parsec String u Ident
+parseIdent = (Ident <$> identifier) <|> (Op <$> parens operator)
+
+parseIdentInfix :: P.Parsec String u Ident
+parseIdentInfix = (Ident <$> P.between tick tick identifier) <|> (Op <$> operator)
+
+mark :: P.Parsec String ParseState a -> P.Parsec String ParseState a
+mark p = do
+ current <- indentationLevel <$> P.getState
+ pos <- P.sourceColumn <$> P.getPosition
+ P.modifyState $ \st -> st { indentationLevel = pos }
+ a <- p
+ P.modifyState $ \st -> st { indentationLevel = current }
+ return a
+
+checkIndentation :: (P.Column -> P.Column -> Bool) -> P.Parsec String ParseState ()
+checkIndentation rel = do
+ col <- P.sourceColumn <$> P.getPosition
+ current <- indentationLevel <$> P.getState
+ guard (col `rel` current)
+
+indented :: P.Parsec String ParseState ()
+indented = checkIndentation (>) P.<?> "indentation"
+
+same :: P.Parsec String ParseState ()
+same = checkIndentation (==) P.<?> "no indentation"
+
+runIndentParser :: P.Parsec String ParseState a -> String -> Either P.ParseError a
+runIndentParser p = P.runParser p (ParseState 0 M.empty) ""
diff --git a/src/PureScript/Parser/Declarations.hs b/src/PureScript/Parser/Declarations.hs
new file mode 100644
index 0000000..f326aa3
--- /dev/null
+++ b/src/PureScript/Parser/Declarations.hs
@@ -0,0 +1,100 @@
+-----------------------------------------------------------------------------
+--
+-- Module : PureScript.Parser.Declarations
+-- Copyright : (c) Phil Freeman 2013
+-- License : MIT
+--
+-- Maintainer : Phil Freeman <paf31@cantab.net>
+-- Stability : experimental
+-- Portability :
+--
+-- |
+--
+-----------------------------------------------------------------------------
+
+module PureScript.Parser.Declarations (
+ parseDeclaration,
+ 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 PureScript.Values
+import PureScript.Types
+import PureScript.Parser.State
+import PureScript.Parser.Common
+import PureScript.Declarations
+import PureScript.Parser.Values
+import PureScript.Parser.Types
+import PureScript.Parser.Kinds
+
+parseDataDeclaration :: P.Parsec String ParseState Declaration
+parseDataDeclaration = do
+ reserved "data"
+ name <- indented *> properName
+ tyArgs <- many (indented *> identifier)
+ lexeme $ indented *> P.char '='
+ ctors <- P.sepBy1 ((,) <$> (indented *> properName) <*> P.optionMaybe parseType) (lexeme $ indented *> P.char '|')
+ return $ DataDeclaration name tyArgs ctors
+
+parseTypeDeclaration :: P.Parsec String ParseState Declaration
+parseTypeDeclaration =
+ TypeDeclaration <$> parseIdent
+ <*> (lexeme (indented *> P.string "::") *> parsePolyType)
+
+parseTypeSynonymDeclaration :: P.Parsec String ParseState Declaration
+parseTypeSynonymDeclaration =
+ TypeSynonymDeclaration <$> (reserved "type" *> indented *> properName)
+ <*> many (indented *> identifier)
+ <*> (lexeme (indented *> P.char '=') *> parseType)
+
+parseValueDeclaration :: P.Parsec String ParseState Declaration
+parseValueDeclaration =
+ ValueDeclaration <$> parseIdent
+ <*> (lexeme (indented *> P.char '=') *> parseValue)
+
+parseExternDeclaration :: P.Parsec String ParseState Declaration
+parseExternDeclaration = reserved "extern" *> indented *>
+ (ExternDataDeclaration <$> (reserved "data" *> indented *> properName)
+ <*> (lexeme (indented *> P.string "::") *> parseKind)
+ <|> ExternDeclaration <$> parseIdent
+ <*> (lexeme (indented *> P.string "::") *> parsePolyType))
+
+parseAssociativity :: P.Parsec String ParseState Associativity
+parseAssociativity =
+ (reserved "infixl" >> return Infixl) <|>
+ (reserved "infixr" >> return Infixr)
+
+parseFixity :: P.Parsec String ParseState Fixity
+parseFixity = Fixity <$> parseAssociativity <*> (indented *> natural)
+
+parseFixityDeclaration :: P.Parsec String ParseState Declaration
+parseFixityDeclaration = do
+ fixity <- parseFixity
+ indented
+ name <- operator
+ current <- fixities <$> P.getState
+ when (name `M.member` current) (P.unexpected $ "redefined fixity for " ++ show name)
+ P.modifyState $ \st -> st { fixities = M.insert name fixity current }
+ return $ FixityDeclaration fixity name
+
+parseDeclaration :: P.Parsec String ParseState Declaration
+parseDeclaration = P.choice (map P.try
+ [ parseDataDeclaration
+ , parseTypeDeclaration
+ , parseTypeSynonymDeclaration
+ , parseValueDeclaration
+ , parseExternDeclaration
+ , parseFixityDeclaration ]) P.<?> "declaration"
+
+parseDeclarations :: P.Parsec String ParseState [Declaration]
+parseDeclarations = whiteSpace *> mark (same *> P.many parseDeclaration) <* P.eof
diff --git a/src/PureScript/Parser/Kinds.hs b/src/PureScript/Parser/Kinds.hs
new file mode 100644
index 0000000..bf1ac37
--- /dev/null
+++ b/src/PureScript/Parser/Kinds.hs
@@ -0,0 +1,41 @@
+-----------------------------------------------------------------------------
+--
+-- Module : PureScript.Parser.Kinds
+-- Copyright : (c) Phil Freeman 2013
+-- License : MIT
+--
+-- Maintainer : Phil Freeman <paf31@cantab.net>
+-- Stability : experimental
+-- Portability :
+--
+-- |
+--
+-----------------------------------------------------------------------------
+
+module PureScript.Parser.Kinds (
+ parseKind
+) where
+
+import PureScript.Kinds
+import PureScript.Parser.State
+import PureScript.Parser.Common
+import Control.Applicative
+import qualified Text.Parsec as P
+import qualified Text.Parsec.Expr as P
+
+parseStar :: P.Parsec String ParseState Kind
+parseStar = const Star <$> lexeme (P.char '*')
+
+parseRow :: P.Parsec String ParseState Kind
+parseRow = const Row <$> lexeme (P.char '#')
+
+parseTypeAtom :: P.Parsec String ParseState Kind
+parseTypeAtom = indented *> P.choice (map P.try
+ [ parseStar
+ , parseRow
+ , parens parseKind ])
+
+parseKind :: P.Parsec String ParseState Kind
+parseKind = P.buildExpressionParser operators parseTypeAtom P.<?> "kind"
+ where
+ operators = [ [ P.Infix (lexeme (P.try (P.string "->")) >> return FunKind) P.AssocRight ] ]
diff --git a/src/PureScript/Parser/State.hs b/src/PureScript/Parser/State.hs
new file mode 100644
index 0000000..68f5a7e
--- /dev/null
+++ b/src/PureScript/Parser/State.hs
@@ -0,0 +1,27 @@
+-----------------------------------------------------------------------------
+--
+-- Module : PureScript.Parser.State
+-- Copyright : (c) Phil Freeman 2013
+-- License : MIT
+--
+-- Maintainer : Phil Freeman <paf31@cantab.net>
+-- Stability : experimental
+-- Portability :
+--
+-- |
+--
+-----------------------------------------------------------------------------
+
+module PureScript.Parser.State where
+
+import PureScript.Names
+import PureScript.Declarations
+
+import qualified Text.Parsec as P
+import qualified Data.Map as M
+
+data ParseState = ParseState
+ { indentationLevel :: P.Column
+ , fixities :: M.Map String Fixity } deriving Show
+
+
diff --git a/src/PureScript/Parser/Types.hs b/src/PureScript/Parser/Types.hs
new file mode 100644
index 0000000..097f6d1
--- /dev/null
+++ b/src/PureScript/Parser/Types.hs
@@ -0,0 +1,91 @@
+-----------------------------------------------------------------------------
+--
+-- Module : PureScript.Parser.Types
+-- Copyright : (c) Phil Freeman 2013
+-- License : MIT
+--
+-- Maintainer : Phil Freeman <paf31@cantab.net>
+-- Stability : experimental
+-- Portability :
+--
+-- |
+--
+-----------------------------------------------------------------------------
+
+module PureScript.Parser.Types (
+ parseType,
+ parsePolyType,
+ parseRow
+) where
+
+import PureScript.Types
+import PureScript.Parser.State
+import PureScript.Parser.Common
+import Control.Applicative
+import qualified Text.Parsec as P
+import qualified Text.Parsec.Expr as P
+import Control.Arrow (Arrow(..))
+
+parseNumber :: P.Parsec String ParseState Type
+parseNumber = const Number <$> reserved "Number"
+
+parseString :: P.Parsec String ParseState Type
+parseString = const String <$> reserved "String"
+
+parseBoolean :: P.Parsec String ParseState Type
+parseBoolean = const Boolean <$> reserved "Boolean"
+
+parseArray :: P.Parsec String ParseState Type
+parseArray = squares $ Array <$> parseType
+
+parseObject :: P.Parsec String ParseState Type
+parseObject = braces $ Object <$> parseRow
+
+parseFunction :: P.Parsec String ParseState Type
+parseFunction = do
+ args <- lexeme $ parens $ commaSep parseType
+ lexeme $ P.string "->"
+ resultType <- parseType
+ return $ Function args resultType
+
+parseTypeVariable :: P.Parsec String ParseState Type
+parseTypeVariable = TypeVar <$> identifier
+
+parseTypeConstructor :: P.Parsec String ParseState Type
+parseTypeConstructor = TypeConstructor <$> properName
+
+parseTypeAtom :: P.Parsec String ParseState Type
+parseTypeAtom = indented *> P.choice (map P.try
+ [ parseNumber
+ , parseString
+ , parseBoolean
+ , parseArray
+ , parseObject
+ , parseFunction
+ , parseTypeVariable
+ , parseTypeConstructor
+ , parens parseType ])
+
+parsePolyType :: P.Parsec String ParseState PolyType
+parsePolyType = (PolyType <$> P.option [] (indented *> reserved "forall" *> many (indented *> identifier) <* indented <* dot)
+ <*> parseType) P.<?> "polymorphic type"
+
+parseType :: P.Parsec String ParseState Type
+parseType = (P.buildExpressionParser operators . buildPostfixParser postfixTable $ parseTypeAtom) P.<?> "type"
+ where
+ postfixTable :: [P.Parsec String ParseState (Type -> Type)]
+ postfixTable = [ flip TypeApp <$> (indented *> parseTypeAtom) ]
+ operators = [ [ P.Infix (lexeme (P.try (P.string "->")) >> return (\t1 t2 -> Function [t1] t2)) P.AssocRight ] ]
+
+parseNameAndType :: P.Parsec String ParseState (String, Type)
+parseNameAndType = (,) <$> (indented *> identifier <* indented <* lexeme (P.string "::")) <*> parseType
+
+parseRowEnding :: P.Parsec String ParseState Row
+parseRowEnding = P.option REmpty (RowVar <$> (lexeme (indented *> P.char '|') *> indented *> identifier))
+
+parseRow :: P.Parsec String ParseState Row
+parseRow = (fromList <$> (parseNameAndType `P.sepBy` (indented *> semi)) <*> parseRowEnding) P.<?> "row"
+ where
+ fromList :: [(String, Type)] -> Row -> Row
+ fromList [] r = r
+ fromList ((name, t):ts) r = RCons name t (fromList ts r)
diff --git a/src/PureScript/Parser/Values.hs b/src/PureScript/Parser/Values.hs
new file mode 100644
index 0000000..d38b046
--- /dev/null
+++ b/src/PureScript/Parser/Values.hs
@@ -0,0 +1,292 @@
+-----------------------------------------------------------------------------
+--
+-- Module : PureScript.Parser.Values
+-- Copyright : (c) Phil Freeman 2013
+-- License : MIT
+--
+-- Maintainer : Phil Freeman <paf31@cantab.net>
+-- Stability : experimental
+-- Portability :
+--
+-- |
+--
+-----------------------------------------------------------------------------
+
+module PureScript.Parser.Values (
+ parseValue,
+ parseBinder
+) where
+
+import PureScript.Values
+import PureScript.Names
+import PureScript.Declarations
+import PureScript.Parser.State
+import Data.Function (on)
+import Data.List
+import Data.Functor.Identity
+import qualified Data.Map as M
+import qualified 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 PureScript.Parser.Types
+import PureScript.Types
+
+booleanLiteral :: P.Parsec String ParseState Bool
+booleanLiteral = (C.reserved "true" >> return True) P.<|> (C.reserved "false" >> return False)
+
+parseNumericLiteral :: P.Parsec String ParseState Value
+parseNumericLiteral = NumericLiteral <$> C.integerOrFloat
+
+parseStringLiteral :: P.Parsec String ParseState Value
+parseStringLiteral = StringLiteral <$> C.stringLiteral
+
+parseBooleanLiteral :: P.Parsec String ParseState Value
+parseBooleanLiteral = BooleanLiteral <$> booleanLiteral
+
+parseArrayLiteral :: P.Parsec String ParseState Value
+parseArrayLiteral = ArrayLiteral <$> C.squares (parseValue `P.sepBy` (C.indented *> C.comma))
+
+parseObjectLiteral :: P.Parsec String ParseState Value
+parseObjectLiteral = ObjectLiteral <$> C.braces (parseIdentifierAndValue `P.sepBy` (C.indented *> C.comma))
+
+parseIdentifierAndValue :: P.Parsec String ParseState (String, Value)
+parseIdentifierAndValue = (,) <$> (C.indented *> C.identifier <* C.indented <* C.colon)
+ <*> (C.indented *> parseValue)
+
+parseAbs :: P.Parsec String ParseState Value
+parseAbs = do
+ C.lexeme $ P.char '\\'
+ args <- (C.indented *> C.parseIdent) `P.sepBy` (C.indented *> C.comma)
+ C.lexeme $ C.indented *> P.string "->"
+ value <- parseValue
+ return $ Abs args value
+
+parseApp :: P.Parsec String ParseState Value
+parseApp = App <$> parseValue
+ <*> (C.indented *> C.parens (parseValue `P.sepBy` (C.indented *> C.comma)))
+
+parseVar :: P.Parsec String ParseState Value
+parseVar = Var <$> C.parseIdent
+
+parseConstructor :: P.Parsec String ParseState Value
+parseConstructor = Constructor <$> C.properName
+
+parseCase :: P.Parsec String ParseState Value
+parseCase = Case <$> P.between (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, Value)
+parseCaseAlternative = (,) <$> (parseGuardedBinder <* C.lexeme (P.string "->"))
+ <*> parseValue
+ P.<?> "case alternative"
+
+parseIfThenElse :: P.Parsec String ParseState Value
+parseIfThenElse = IfThenElse <$> (C.reserved "if" *> C.indented *> parseValue)
+ <*> (C.indented *> C.reserved "then" *> C.indented *> parseValue)
+ <*> (C.indented *> C.reserved "else" *> C.indented *> parseValue)
+
+parseBlock :: P.Parsec String ParseState Value
+parseBlock = Block <$> (C.reserved "do" *> parseManyStatements)
+
+parseManyStatements :: P.Parsec String ParseState [Statement]
+parseManyStatements = C.indented *> C.mark (P.many (C.same *> C.mark parseStatement)) P.<?> "block"
+
+parseValueAtom :: P.Parsec String ParseState Value
+parseValueAtom = C.indented *> P.choice (map P.try
+ [ parseNumericLiteral
+ , parseStringLiteral
+ , parseBooleanLiteral
+ , parseArrayLiteral
+ , parseObjectLiteral
+ , parseAbs
+ , parseVar
+ , parseConstructor
+ , parseBlock
+ , parseCase
+ , parseIfThenElse
+ , C.parens parseValue ])
+
+parsePropertyUpdate :: P.Parsec String ParseState (String, Value)
+parsePropertyUpdate = do
+ name <- C.lexeme C.identifier
+ C.lexeme $ C.indented *> P.char '='
+ value <- C.indented *> parseValue
+ return (name, value)
+
+parseValue :: P.Parsec String ParseState Value
+parseValue = do
+ customOps <- fixities <$> P.getState
+ (buildExpressionParser (operators customOps)
+ . C.buildPostfixParser postfixTable2
+ $ indexersAndAccessors) P.<?> "expression"
+ where
+ indexersAndAccessors = C.buildPostfixParser postfixTable1 parseValueAtom
+ postfixTable1 = [ Accessor <$> (C.indented *> C.dot *> C.indented *> C.identifier)
+ , Indexer <$> (C.indented *> C.squares parseValue)
+ , flip ObjectUpdate <$> (C.indented *> C.braces ((C.indented *> parsePropertyUpdate) `P.sepBy1` (C.indented *> C.comma))) ]
+ postfixTable2 = [ C.indented *> indexersAndAccessors >>= \t2 -> return (\t1 -> App t1 [t2])
+ , flip App <$> (C.indented *> C.parens (parseValue `P.sepBy` (C.indented *> C.comma)))
+ , flip TypedValue <$> (P.try (C.lexeme (C.indented *> P.string "::")) *> parsePolyType) ]
+ operators user =
+ [ [ 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)
+ , Prefix $ C.lexeme (P.try $ C.indented *> C.reservedOp "+") >> return id ]
+ ] ++ customOperatorTable user ++
+ [ [ Infix (C.lexeme (P.try (C.indented *> C.parseIdentInfix P.<?> "operator") >>= \ident -> return $ \t1 t2 -> App (App (Var ident) [t1]) [t2])) AssocLeft ]
+ , [ Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "<=") >> return (Binary LessThanOrEqualTo)) AssocRight
+ , Infix (C.lexeme (P.try $ C.indented *> C.reservedOp ">=") >> return (Binary GreaterThanOrEqualTo)) AssocRight ]
+ , [ Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "<") >> return (Binary LessThan)) AssocRight
+ , Infix (C.lexeme (P.try $ C.indented *> C.reservedOp ">") >> return (Binary GreaterThan)) AssocRight ]
+ , [ Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "*") >> return (Binary Multiply)) AssocRight
+ , Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "/") >> return (Binary Divide)) AssocRight
+ , Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "%") >> return (Binary Modulus)) AssocRight ]
+ , [ Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "++") >> return (Binary Concat)) AssocRight
+ , Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "+") >> return (Binary Add)) AssocRight
+ , Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "-") >> return (Binary Subtract)) AssocRight ]
+ , [ Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "<<") >> return (Binary ShiftLeft)) AssocRight
+ , Infix (C.lexeme (P.try $ C.indented *> C.reservedOp ">>>") >> return (Binary ZeroFillShiftRight)) AssocRight
+ , Infix (C.lexeme (P.try $ C.indented *> C.reservedOp ">>") >> return (Binary ShiftRight)) AssocRight ]
+ , [ Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "==") >> return (Binary EqualTo)) AssocRight
+ , Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "!=") >> return (Binary NotEqualTo)) AssocRight ]
+ , [ Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "&") >> return (Binary BitwiseAnd)) AssocRight ]
+ , [ Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "^") >> return (Binary BitwiseXor)) AssocRight ]
+ , [ Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "|") >> return (Binary BitwiseOr)) AssocRight ]
+ , [ Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "&&") >> return (Binary And)) AssocRight ]
+ , [ Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "||") >> return (Binary Or)) AssocRight ]
+ ]
+
+customOperatorTable :: M.Map String Fixity -> OperatorTable String ParseState Identity Value
+customOperatorTable fixities =
+ let
+ ops = map (\(name, Fixity a p) -> (name, (a, p))) . M.toList $ fixities
+ sorted = sortBy (compare `on` (snd . snd)) ops
+ levels = groupBy ((==) `on` (snd . snd)) sorted
+ in
+ map (map $ \(name, (a, _)) ->
+ flip Infix (toAssoc a) $
+ C.lexeme $ P.try $ do
+ C.indented
+ C.reservedOp name P.<?> "operator"
+ return $ \t1 t2 -> App (App (Var (Op name)) [t1]) [t2])
+ levels
+
+
+toAssoc :: Associativity -> Assoc
+toAssoc Infixl = AssocLeft
+toAssoc Infixr = AssocRight
+
+parseVariableIntroduction :: P.Parsec String ParseState Statement
+parseVariableIntroduction = do
+ C.reserved "var"
+ name <- C.indented *> C.parseIdent
+ C.lexeme $ C.indented *> P.char '='
+ value <- parseValue
+ return $ VariableIntroduction name value
+
+parseAssignment :: P.Parsec String ParseState Statement
+parseAssignment = do
+ tgt <- C.parseIdent
+ C.lexeme $ C.indented *> P.char '='
+ value <- parseValue
+ return $ Assignment tgt value
+
+parseWhile :: P.Parsec String ParseState Statement
+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.parseIdent)
+ <*> (C.indented *> C.lexeme (P.string "<-") *> parseValue)
+ <*> (C.indented *> C.reserved "until" *> parseValue <* C.colon)
+ <*> parseManyStatements
+
+parseForEach :: P.Parsec String ParseState Statement
+parseForEach = ForEach <$> (C.reserved "foreach" *> C.indented *> C.parseIdent)
+ <*> (C.indented *> C.reserved "in" *> parseValue <* C.colon)
+ <*> parseManyStatements
+
+parseIf :: P.Parsec String ParseState Statement
+parseIf = If <$> parseIfStatement
+
+parseIfStatement :: P.Parsec String ParseState IfStatement
+parseIfStatement =
+ IfStatement <$> (C.reserved "if" *> C.indented *> parseValue <* C.indented <* C.colon)
+ <*> parseManyStatements
+ <*> P.optionMaybe (C.same *> parseElseStatement)
+
+parseElseStatement :: P.Parsec String ParseState ElseStatement
+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)
+
+parseStatement :: P.Parsec String ParseState Statement
+parseStatement = P.choice (map P.try
+ [ parseVariableIntroduction
+ , parseAssignment
+ , parseWhile
+ , parseFor
+ , parseForEach
+ , parseIf
+ , parseReturn ]) P.<?> "statement"
+
+parseStringBinder :: P.Parsec String ParseState Binder
+parseStringBinder = StringBinder <$> C.stringLiteral
+
+parseBooleanBinder :: P.Parsec String ParseState Binder
+parseBooleanBinder = BooleanBinder <$> booleanLiteral
+
+parseNumberBinder :: P.Parsec String ParseState Binder
+parseNumberBinder = NumberBinder <$> C.integerOrFloat
+
+parseVarBinder :: P.Parsec String ParseState Binder
+parseVarBinder = VarBinder <$> C.parseIdent
+
+parseNullaryBinder :: P.Parsec String ParseState Binder
+parseNullaryBinder = NullaryBinder <$> C.lexeme C.properName
+
+parseUnaryBinder :: P.Parsec String ParseState Binder
+parseUnaryBinder = UnaryBinder <$> C.lexeme C.properName <*> (C.indented *> parseBinder)
+
+parseObjectBinder :: P.Parsec String ParseState Binder
+parseObjectBinder = ObjectBinder <$> C.braces ((C.indented *> parseIdentifierAndBinder) `P.sepBy` (C.indented *> C.comma))
+
+parseArrayBinder :: P.Parsec String ParseState Binder
+parseArrayBinder = C.squares $ ArrayBinder <$> ((C.indented *> parseBinder) `P.sepBy` (C.indented *> C.comma))
+ <*> 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 '@'))
+ <*> (C.indented *> parseBinder)
+
+parseNullBinder :: P.Parsec String ParseState Binder
+parseNullBinder = C.lexeme (P.char '_') *> P.notFollowedBy C.identLetter *> return NullBinder
+
+parseIdentifierAndBinder :: P.Parsec String ParseState (String, Binder)
+parseIdentifierAndBinder = do
+ name <- C.lexeme C.identifier
+ C.lexeme $ C.indented *> P.char '='
+ binder <- C.indented *> parseBinder
+ return (name, binder)
+
+parseBinder :: P.Parsec String ParseState Binder
+parseBinder = P.choice (map P.try
+ [ parseNullBinder
+ , parseStringBinder
+ , parseBooleanBinder
+ , parseNumberBinder
+ , parseNamedBinder
+ , parseVarBinder
+ , parseUnaryBinder
+ , parseNullaryBinder
+ , parseObjectBinder
+ , parseArrayBinder
+ , C.parens parseBinder ]) P.<?> "binder"
+
+parseGuardedBinder :: P.Parsec String ParseState Binder
+parseGuardedBinder = flip ($) <$> parseBinder <*> P.option id (GuardedBinder <$> (C.indented *> C.lexeme (P.char '|') *> C.indented *> parseValue))
diff --git a/src/PureScript/Pretty.hs b/src/PureScript/Pretty.hs
new file mode 100644
index 0000000..124737f
--- /dev/null
+++ b/src/PureScript/Pretty.hs
@@ -0,0 +1,22 @@
+-----------------------------------------------------------------------------
+--
+-- Module : PureScript.Pretty
+-- Copyright : (c) Phil Freeman 2013
+-- License : MIT
+--
+-- Maintainer : Phil Freeman <paf31@cantab.net>
+-- Stability : experimental
+-- Portability :
+--
+-- |
+--
+-----------------------------------------------------------------------------
+
+module PureScript.Pretty (module P) where
+
+import PureScript.CodeGen.Pretty.Kinds as P
+import PureScript.CodeGen.Pretty.Values as P
+import PureScript.CodeGen.Pretty.Types as P
+
+
+
diff --git a/src/PureScript/TypeChecker.hs b/src/PureScript/TypeChecker.hs
new file mode 100644
index 0000000..4c92b59
--- /dev/null
+++ b/src/PureScript/TypeChecker.hs
@@ -0,0 +1,96 @@
+-----------------------------------------------------------------------------
+--
+-- Module : PureScript.TypeChecker
+-- Copyright : (c) Phil Freeman 2013
+-- License : MIT
+--
+-- Maintainer : Phil Freeman <paf31@cantab.net>
+-- Stability : experimental
+-- Portability :
+--
+-- |
+--
+-----------------------------------------------------------------------------
+
+{-# LANGUAGE FlexibleInstances #-}
+
+module PureScript.TypeChecker (
+module T,
+ typeCheckAll
+) where
+
+import PureScript.TypeChecker.Monad as T
+import PureScript.TypeChecker.Kinds as T
+import PureScript.TypeChecker.Types as T
+import PureScript.TypeChecker.Synonyms as T
+
+import Data.List
+import Data.Maybe
+import Data.Function
+import qualified Data.Map as M
+
+import PureScript.Values
+import PureScript.Types
+import PureScript.Names
+import PureScript.Kinds
+import PureScript.Declarations
+
+import Control.Monad (forM_)
+import Control.Monad.State
+import Control.Monad.Error
+
+typeCheckAll :: [Declaration] -> Check ()
+typeCheckAll [] = return ()
+typeCheckAll (DataDeclaration name args dctors : rest) = do
+ rethrow (("Error in type constructor " ++ name ++ ": ") ++) $ do
+ env <- getEnv
+ guardWith (name ++ " is already defined") $ not $ M.member name (types env)
+ ctorKind <- kindsOf (Just name) args (mapMaybe snd dctors)
+ putEnv $ env { types = M.insert name (ctorKind, Data) (types env) }
+ forM_ dctors $ \(dctor, maybeTy) ->
+ rethrow (("Error in data constructor " ++ name ++ ": ") ++) $ do
+ env' <- getEnv
+ guardWith (dctor ++ " is already defined") $ not $ M.member dctor (dataConstructors env')
+ let retTy = foldl TypeApp (TypeConstructor name) (map TypeVar args)
+ let dctorTy = maybe retTy (\ty -> Function [ty] retTy) maybeTy
+ let polyType = PolyType args dctorTy
+ putEnv $ env' { dataConstructors = M.insert dctor polyType (dataConstructors env') }
+ typeCheckAll rest
+typeCheckAll (TypeSynonymDeclaration name args ty : rest) = do
+ rethrow (("Error in type synonym " ++ name ++ ": ") ++) $ do
+ env <- getEnv
+ guardWith (name ++ " is already defined") $ not $ M.member name (types env)
+ kind <- kindsOf (Just name) args [ty]
+ putEnv $ env { types = M.insert name (kind, TypeSynonym) (types env)
+ , typeSynonyms = M.insert name (args, ty) (typeSynonyms env) }
+ typeCheckAll rest
+typeCheckAll (TypeDeclaration name ty : ValueDeclaration name' val : rest) | name == name' =
+ typeCheckAll (ValueDeclaration name (TypedValue val ty) : rest)
+typeCheckAll (TypeDeclaration name _ : _) = throwError $ "Orphan type declaration for " ++ show name
+typeCheckAll (ValueDeclaration name val : rest) = do
+ rethrow (("Error in declaration " ++ show name ++ ": ") ++) $ do
+ env <- getEnv
+ case M.lookup name (names env) of
+ Just ty -> throwError $ show name ++ " is already defined"
+ Nothing -> do
+ ty <- typeOf name val
+ putEnv (env { names = M.insert name (ty, Value) (names env) })
+ typeCheckAll rest
+typeCheckAll (ExternDataDeclaration name kind : rest) = do
+ env <- getEnv
+ guardWith (name ++ " is already defined") $ not $ M.member name (types env)
+ putEnv $ env { types = M.insert name (kind, TypeSynonym) (types env) }
+ typeCheckAll rest
+typeCheckAll (ExternDeclaration name ty : rest) = do
+ rethrow (("Error in extern declaration " ++ show name ++ ": ") ++) $ do
+ env <- getEnv
+ kind <- kindOf ty
+ guardWith "Expected kind *" $ kind == Star
+ case M.lookup name (names env) of
+ Just _ -> throwError $ show name ++ " is already defined"
+ Nothing -> putEnv (env { names = M.insert name (ty, Extern) (names env) })
+ typeCheckAll rest
+typeCheckAll (FixityDeclaration _ name : rest) = do
+ typeCheckAll rest
+ env <- getEnv
+ guardWith ("Fixity declaration with no binding: " ++ name) $ M.member (Op name) $ names env
diff --git a/src/PureScript/TypeChecker/Kinds.hs b/src/PureScript/TypeChecker/Kinds.hs
new file mode 100644
index 0000000..5c617b3
--- /dev/null
+++ b/src/PureScript/TypeChecker/Kinds.hs
@@ -0,0 +1,183 @@
+-----------------------------------------------------------------------------
+--
+-- Module : PureScript.TypeChecker.Kinds
+-- Copyright : (c) Phil Freeman 2013
+-- License : MIT
+--
+-- Maintainer : Phil Freeman <paf31@cantab.net>
+-- Stability : experimental
+-- Portability :
+--
+-- |
+--
+-----------------------------------------------------------------------------
+
+{-# LANGUAGE DeriveDataTypeable #-}
+
+module PureScript.TypeChecker.Kinds (
+ KindConstraint(..),
+ KindSolution(..),
+ kindsOf,
+ kindOf
+) where
+
+import Data.List
+import Data.Maybe (fromMaybe)
+import Data.Function
+import Data.Data
+
+import PureScript.Types
+import PureScript.Kinds
+import PureScript.Declarations
+import PureScript.TypeChecker.Monad
+import PureScript.CodeGen.Pretty.Kinds
+import PureScript.CodeGen.Pretty.Types
+
+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
+
+data KindConstraintOrigin
+ = DataDeclOrigin
+ | TypeOrigin Type
+ | RowOrigin Row deriving (Show, Data, Typeable)
+
+prettyPrintKindConstraintOrigin :: KindConstraintOrigin -> String
+prettyPrintKindConstraintOrigin (DataDeclOrigin) = "data declaration"
+prettyPrintKindConstraintOrigin (TypeOrigin ty) = prettyPrintType ty
+prettyPrintKindConstraintOrigin (RowOrigin row) = prettyPrintRow row
+
+data KindConstraint = KindConstraint Int Kind KindConstraintOrigin deriving (Show, Data, Typeable)
+
+newtype KindSolution = KindSolution { runKindSolution :: Int -> Kind }
+
+emptyKindSolution :: KindSolution
+emptyKindSolution = KindSolution KUnknown
+
+kindOf :: PolyType -> Check Kind
+kindOf (PolyType idents ty) = do
+ ns <- replicateM (length idents) fresh
+ (cs, n, m) <- kindConstraints (M.fromList (zip idents ns)) ty
+ solution <- solveKindConstraints cs emptyKindSolution
+ return $ starIfUnknown $ runKindSolution solution n
+
+kindsOf :: Maybe String -> [String] -> [Type] -> Check Kind
+kindsOf name args ts = do
+ tyCon <- fresh
+ nargs <- replicateM (length args) fresh
+ (cs, ns, m) <- kindConstraintsAll (maybe id (`M.insert` tyCon) name $ M.fromList (zip args nargs)) ts
+ let extraConstraints =
+ KindConstraint tyCon (foldr (FunKind . KUnknown) Star nargs) DataDeclOrigin
+ : zipWith (\n arg -> KindConstraint n Star (TypeOrigin arg)) ns ts
+ solution <- solveKindConstraints (extraConstraints ++ cs) emptyKindSolution
+ return $ starIfUnknown $ runKindSolution solution tyCon
+
+starIfUnknown :: Kind -> Kind
+starIfUnknown (KUnknown _) = Star
+starIfUnknown (FunKind k1 k2) = FunKind (starIfUnknown k1) (starIfUnknown k2)
+starIfUnknown k = k
+
+kindConstraintsAll :: M.Map String Int -> [Type] -> Check ([KindConstraint], [Int], M.Map String Int)
+kindConstraintsAll m [] = return ([], [], m)
+kindConstraintsAll m (t:ts) = do
+ (cs, n1, m') <- kindConstraints m t
+ (cs', ns, m'') <- kindConstraintsAll m' ts
+ return (KindConstraint n1 Star (TypeOrigin t) : cs ++ cs', n1:ns, m'')
+
+kindConstraints :: M.Map String Int -> Type -> Check ([KindConstraint], Int, M.Map String Int)
+kindConstraints m a@(Array t) = do
+ me <- fresh
+ (cs, n1, m') <- kindConstraints m t
+ return (KindConstraint n1 Star (TypeOrigin t) : KindConstraint me Star (TypeOrigin a) : cs, me, m')
+kindConstraints m o@(Object row) = do
+ me <- fresh
+ (cs, r, m') <- kindConstraintsForRow m row
+ return (KindConstraint me Star (TypeOrigin o) : KindConstraint r Row (RowOrigin row) : cs, me, m')
+kindConstraints m f@(Function args ret) = do
+ me <- fresh
+ (cs, ns, m') <- kindConstraintsAll m args
+ (cs', retN, m'') <- kindConstraints m' ret
+ return (KindConstraint retN Star (TypeOrigin ret) : KindConstraint me Star (TypeOrigin f) : zipWith (\n arg -> KindConstraint n Star (TypeOrigin arg)) ns args ++ cs ++ cs', me, m'')
+kindConstraints m (TypeVar v) =
+ case M.lookup v m of
+ Just u -> return ([], u, m)
+ Nothing -> throwError $ "Unbound type variable " ++ v
+kindConstraints m c@(TypeConstructor v) = do
+ env <- getEnv
+ me <- fresh
+ case M.lookup v m of
+ Nothing -> case M.lookup v (types env) of
+ Nothing -> throwError $ "Unknown type constructor '" ++ v ++ "'"
+ Just (kind, _) -> return ([KindConstraint me kind (TypeOrigin c)], me, m)
+ Just u -> return ([KindConstraint me (KUnknown u) (TypeOrigin c)], me, m)
+kindConstraints m a@(TypeApp t1 t2) = do
+ me <- fresh
+ (cs1, n1, m1) <- kindConstraints m t1
+ (cs2, n2, m2) <- kindConstraints m1 t2
+ return (KindConstraint n1 (FunKind (KUnknown n2) (KUnknown me)) (TypeOrigin a) : cs1 ++ cs2, me, m2)
+kindConstraints m t = do
+ me <- fresh
+ return ([KindConstraint me Star (TypeOrigin t)], me, m)
+
+kindConstraintsForRow :: M.Map String Int -> Row -> Check ([KindConstraint], Int, M.Map String Int)
+kindConstraintsForRow m r@(RowVar v) = do
+ me <- case M.lookup v m of
+ Just u -> return u
+ Nothing -> fresh
+ return ([KindConstraint me Row (RowOrigin r)], me, M.insert v me m)
+kindConstraintsForRow m r@REmpty = do
+ me <- fresh
+ return ([KindConstraint me Row (RowOrigin r)], me, m)
+kindConstraintsForRow m r@(RCons _ ty row) = do
+ me <- fresh
+ (cs1, n1, m1) <- kindConstraints m ty
+ (cs2, n2, m2) <- kindConstraintsForRow m1 row
+ return (KindConstraint me Row (RowOrigin r) : KindConstraint n1 Star (TypeOrigin ty) : KindConstraint n2 Row (RowOrigin r) : cs1 ++ cs2, me, m2)
+
+solveKindConstraints :: [KindConstraint] -> KindSolution -> Check KindSolution
+solveKindConstraints [] s = return s
+solveKindConstraints all@(KindConstraint n k t : cs) s = do
+ (cs', s') <- rethrow (\err -> "Error in " ++ prettyPrintKindConstraintOrigin t ++ ": " ++ err) $ do
+ guardWith "Occurs check failed" $ not $ kindOccursCheck False n k
+ let s' = KindSolution $ replaceUnknownKind n k . runKindSolution s
+ cs' <- fmap concat $ mapM (substituteKindConstraint n k) cs
+ return (cs', s')
+ solveKindConstraints cs' s'
+
+substituteKindConstraint :: Int -> Kind -> KindConstraint -> Check [KindConstraint]
+substituteKindConstraint n k (KindConstraint m l t)
+ | n == m = unifyKinds t k l
+ | otherwise = return [KindConstraint m (replaceUnknownKind n k l) t]
+
+replaceUnknownKind :: Int -> Kind -> Kind -> Kind
+replaceUnknownKind n k = f
+ where
+ f (KUnknown m) | m == n = k
+ f (FunKind k1 k2) = FunKind (f k2) (f k2)
+ f other = other
+
+unifyKinds :: KindConstraintOrigin -> Kind -> Kind -> Check [KindConstraint]
+unifyKinds _ (KUnknown u1) (KUnknown u2) | u1 == u2 = return []
+unifyKinds t (KUnknown u) k = do
+ guardWith "Occurs check failed" $ not $ kindOccursCheck False u k
+ return [KindConstraint u k t]
+unifyKinds t k (KUnknown u) = do
+ guardWith "Occurs check failed" $ not $ kindOccursCheck False u k
+ return [KindConstraint u k t]
+unifyKinds _ Star Star = return []
+unifyKinds _ Row Row = return []
+unifyKinds t (FunKind k1 k2) (FunKind k3 k4) = do
+ cs1 <- unifyKinds t k1 k3
+ cs2 <- unifyKinds t k2 k4
+ return $ cs1 ++ cs2
+unifyKinds _ k1 k2 = throwError $ "Cannot unify " ++ prettyPrintKind k1 ++ " with " ++ prettyPrintKind k2 ++ "."
+
+kindOccursCheck :: Bool -> Int -> Kind -> Bool
+kindOccursCheck b u (KUnknown u') | u == u' = b
+kindOccursCheck _ u (FunKind k1 k2) = kindOccursCheck True u k1 || kindOccursCheck True u k2
+kindOccursCheck _ _ _ = False
diff --git a/src/PureScript/TypeChecker/Monad.hs b/src/PureScript/TypeChecker/Monad.hs
new file mode 100644
index 0000000..d283232
--- /dev/null
+++ b/src/PureScript/TypeChecker/Monad.hs
@@ -0,0 +1,67 @@
+-----------------------------------------------------------------------------
+--
+-- Module : PureScript.TypeChecker.Monad
+-- Copyright : (c) Phil Freeman 2013
+-- License : MIT
+--
+-- Maintainer : Phil Freeman <paf31@cantab.net>
+-- Stability : experimental
+-- Portability :
+--
+-- |
+--
+-----------------------------------------------------------------------------
+
+{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleInstances #-}
+
+module PureScript.TypeChecker.Monad where
+
+import PureScript.Types
+import PureScript.Kinds
+import PureScript.Names
+
+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 deriving Show
+
+data TypeDeclarationKind = Data | ExternData | TypeSynonym deriving Show
+
+data Environment = Environment
+ { names :: M.Map Ident (PolyType, NameKind)
+ , types :: M.Map String (Kind, TypeDeclarationKind)
+ , dataConstructors :: M.Map String PolyType
+ , typeSynonyms :: M.Map String ([String], Type)
+ }
+
+emptyEnvironment :: Environment
+emptyEnvironment = Environment M.empty M.empty M.empty M.empty
+
+newtype Check a = Check { unCheck :: StateT (Environment, Int) (Either String) a } deriving (Functor, Monad, Applicative, MonadPlus, MonadState (Environment, Int), MonadError String)
+
+getEnv :: Check Environment
+getEnv = fmap fst get
+
+putEnv :: Environment -> Check ()
+putEnv env = fmap (first (const env)) get >>= put
+
+fresh :: Check Int
+fresh = do
+ (env, n) <- get
+ put (env, n + 1)
+ return n
+
+check :: Check a -> Either String (a, Environment)
+check = fmap (second fst) . flip runStateT (emptyEnvironment, 0) . unCheck
+
+guardWith :: (MonadError e m) => e -> Bool -> m ()
+guardWith _ True = return ()
+guardWith e False = throwError e
+
+rethrow :: (MonadError e m) => (e -> e) -> m a -> m a
+rethrow f = flip catchError $ \e -> throwError (f e)
diff --git a/src/PureScript/TypeChecker/Synonyms.hs b/src/PureScript/TypeChecker/Synonyms.hs
new file mode 100644
index 0000000..5254629
--- /dev/null
+++ b/src/PureScript/TypeChecker/Synonyms.hs
@@ -0,0 +1,56 @@
+-----------------------------------------------------------------------------
+--
+-- Module : PureScript.TypeChecker.Synonyms
+-- Copyright : (c) Phil Freeman 2013
+-- License : MIT
+--
+-- Maintainer : Phil Freeman <paf31@cantab.net>
+-- Stability : experimental
+-- Portability :
+--
+-- |
+--
+-----------------------------------------------------------------------------
+
+{-# LANGUAGE Rank2Types #-}
+
+module PureScript.TypeChecker.Synonyms (
+ saturateTypeSynonym,
+ saturateAllTypeSynonyms
+) where
+
+import PureScript.Types
+import PureScript.Declarations
+
+import Data.Maybe (fromMaybe)
+import Data.Data
+import Data.Generics
+import Control.Arrow
+import Control.Monad.Writer
+import Control.Monad.Error
+import qualified Data.Map as M
+
+buildTypeSubstitution :: String -> Int -> Type -> Either String (Maybe Type)
+buildTypeSubstitution name n = go n []
+ where
+ go :: Int -> [Type] -> Type -> Either String (Maybe Type)
+ go 0 args (TypeConstructor ctor) | name == ctor = return (Just $ SaturatedTypeSynonym ctor args)
+ go n _ (TypeConstructor ctor) | n > 0 && name == ctor = throwError $ "Partially applied type synonym " ++ name
+ go n args (TypeApp f arg) = go (n - 1) (arg:args) f
+ go _ _ _ = return Nothing
+
+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
+
+saturateTypeSynonym :: (Data d) => String -> Int -> d -> Either String d
+saturateTypeSynonym name n = everywhereM' (mkM replace)
+ where
+ replace t = fmap (fromMaybe t) $ buildTypeSubstitution name n t
+
+saturateAllTypeSynonyms :: (Data d) => [(String, Int)] -> d -> Either String d
+saturateAllTypeSynonyms syns d = foldM (\d (name, n) -> saturateTypeSynonym name n d) d syns
+
+
+
diff --git a/src/PureScript/TypeChecker/Types.hs b/src/PureScript/TypeChecker/Types.hs
new file mode 100644
index 0000000..e6dffbe
--- /dev/null
+++ b/src/PureScript/TypeChecker/Types.hs
@@ -0,0 +1,626 @@
+-----------------------------------------------------------------------------
+--
+-- Module : PureScript.TypeChecker.Types
+-- Copyright : (c) Phil Freeman 2013
+-- License : MIT
+--
+-- Maintainer : Phil Freeman <paf31@cantab.net>
+-- Stability : experimental
+-- Portability :
+--
+-- |
+--
+-----------------------------------------------------------------------------
+
+{-# LANGUAGE DeriveDataTypeable #-}
+
+module PureScript.TypeChecker.Types (
+ TypeConstraint(..),
+ TypeSolution(..),
+ typeOf
+) where
+
+import Debug.Trace
+
+import Data.List
+import Data.Function
+import qualified Data.Data as D
+import Data.Generics (everywhere, everywhereM, everything, mkT, mkM, mkQ, extM, extQ)
+
+import PureScript.Values
+import PureScript.Types
+import PureScript.Kinds
+import PureScript.Names
+import PureScript.TypeChecker.Monad
+import PureScript.TypeChecker.Kinds
+import PureScript.TypeChecker.Synonyms
+import PureScript.CodeGen.Pretty.Types
+import PureScript.CodeGen.Pretty.Kinds
+import PureScript.CodeGen.Pretty.Values
+
+import Control.Monad.State
+import Control.Monad.Error
+
+import Control.Applicative
+import Control.Arrow (Kleisli(..), (***), (&&&), first)
+import qualified Control.Category as C
+
+import qualified Data.Map as M
+
+data TypeConstraintOrigin
+ = ValueOrigin Value
+ | BinderOrigin Binder
+ | AssignmentTargetOrigin Ident deriving (Show, D.Data, D.Typeable)
+
+prettyPrintOrigin :: TypeConstraintOrigin -> String
+prettyPrintOrigin (ValueOrigin val) = prettyPrintValue val
+prettyPrintOrigin (BinderOrigin binder) = prettyPrintBinder binder
+prettyPrintOrigin (AssignmentTargetOrigin ident) = show ident
+
+data TypeConstraint
+ = TypeConstraint Int Type TypeConstraintOrigin
+ | RowConstraint Int Row TypeConstraintOrigin deriving (Show, D.Data, D.Typeable)
+
+newtype TypeSolution = TypeSolution { runTypeSolution :: (Int -> Type, Int -> Row) }
+
+emptyTypeSolution :: TypeSolution
+emptyTypeSolution = TypeSolution (TUnknown, RUnknown)
+
+isFunction :: Value -> Bool
+isFunction (Abs _ _) = True
+isFunction (TypedValue untyped _) = isFunction untyped
+isFunction _ = False
+
+allConstraints :: Ident -> Value -> Check ([TypeConstraint], Int)
+allConstraints name val | isFunction val = do
+ me <- fresh
+ (cs, n) <- typeConstraints (M.singleton name me) val
+ return (TypeConstraint me (TUnknown n) (ValueOrigin val): cs, n)
+allConstraints _ val = typeConstraints M.empty val
+
+typeOf :: Ident -> Value -> Check PolyType
+typeOf name val = do
+ (cs, n) <- allConstraints name val
+ desugared <- replaceAllTypeSynonyms cs
+ solution <- solveTypeConstraints desugared emptyTypeSolution
+ let ty = fst (runTypeSolution solution) n
+ allUnknownsBecameQuantified desugared solution ty
+ return $ varIfUnknown $ desaturateAllTypeSynonyms $ setifyAll ty
+
+allUnknownsBecameQuantified :: [TypeConstraint] -> TypeSolution -> Type -> Check ()
+allUnknownsBecameQuantified cs solution ty = do
+ let
+ typesMentioned = findUnknownTypes ty
+ unknownTypes = nub $ flip concatMap cs $ \c -> case c of
+ TypeConstraint u t _ -> u : findUnknownTypes t
+ RowConstraint _ r _ -> findUnknownTypes r
+ unsolvedTypes = filter (\n -> TUnknown n == fst (runTypeSolution solution) n) unknownTypes
+ guardWith "Unsolved type variable" $ null $ unsolvedTypes \\ typesMentioned
+ let
+ rowsMentioned = findUnknownRows ty
+ unknownRows = nub $ flip concatMap cs $ \c -> case c of
+ TypeConstraint _ t _ -> findUnknownRows t
+ RowConstraint u r _ -> u : findUnknownRows r
+ unsolvedRows = filter (\n -> RUnknown n == snd (runTypeSolution solution) n) unknownRows
+ guardWith "Unsolved row variable" $ null $ unsolvedRows \\ rowsMentioned
+
+setify :: Row -> Row
+setify = rowFromList . first (M.toList . M.fromList) . rowToList
+
+setifyAll :: (D.Data d) => d -> d
+setifyAll = everywhere (mkT setify)
+
+findUnknownTypes :: (D.Data d) => d -> [Int]
+findUnknownTypes = everything (++) (mkQ [] f)
+ where
+ f :: Type -> [Int]
+ f (TUnknown n) = [n]
+ f _ = []
+
+findTypeVars :: (D.Data d) => d -> [String]
+findTypeVars = everything (++) (mkQ [] f)
+ where
+ f :: Type -> [String]
+ f (TypeVar v) = [v]
+ f _ = []
+
+findUnknownRows :: (D.Data d) => d -> [Int]
+findUnknownRows = everything (++) (mkQ [] f)
+ where
+ f :: Row -> [Int]
+ f (RUnknown n) = [n]
+ f _ = []
+
+varIfUnknown :: Type -> PolyType
+varIfUnknown ty =
+ let
+ (ty', m) = flip runState M.empty $ everywhereM (flip extM g $ mkM f) ty
+ in
+ PolyType (sort $ nub $ M.elems m ++ findTypeVars ty) ty'
+ where
+ f :: Type -> State (M.Map Int String) Type
+ f (TUnknown n) = do
+ m <- get
+ case M.lookup n m of
+ Nothing -> do
+ let name = 't' : show (M.size m)
+ put $ M.insert n name m
+ return $ TypeVar name
+ Just name -> return $ TypeVar name
+ f t = return t
+ g :: Row -> State (M.Map Int String) Row
+ g (RUnknown n) = do
+ m <- get
+ case M.lookup n m of
+ Nothing -> do
+ let name = 'r' : show (M.size m)
+ put $ M.insert n name m
+ return $ RowVar name
+ Just name -> return $ RowVar name
+ g r = return r
+
+replaceTypeVars :: M.Map String Type -> Type -> Type
+replaceTypeVars m = everywhere (mkT replace)
+ where
+ replace (TypeVar v) = case M.lookup v m of
+ Just ty -> ty
+ _ -> TypeVar v
+ replace t = t
+
+replaceVarsWithUnknowns :: [String] -> Type -> Check Type
+replaceVarsWithUnknowns idents = flip evalStateT M.empty . everywhereM (flip extM f $ mkM g)
+ where
+ f :: Type -> StateT (M.Map String Int) 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 n
+ Just u -> return $ TUnknown u
+ f t = return t
+ g :: Row -> StateT (M.Map String Int) 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 n
+ Just u -> return $ RUnknown u
+ g r = return r
+
+replaceAllTypeSynonyms :: (D.Data d) => d -> Check d
+replaceAllTypeSynonyms d = do
+ env <- getEnv
+ let syns = map (\(name, (args, _)) -> (name, length args)) . M.toList $ typeSynonyms env
+ either throwError return $ saturateAllTypeSynonyms syns d
+
+desaturateAllTypeSynonyms :: (D.Data d) => d -> d
+desaturateAllTypeSynonyms = everywhere (mkT replace)
+ where
+ replace (SaturatedTypeSynonym name args) = foldl TypeApp (TypeConstructor name) args
+ replace t = t
+
+replaceType :: (D.Data d) => Int -> Type -> d -> d
+replaceType n t = everywhere (mkT go)
+ where
+ go (TUnknown m) | m == n = t
+ go t = t
+
+replaceRow :: (D.Data d) => Int -> Row -> d -> d
+replaceRow n r = everywhere (mkT go)
+ where
+ go (RUnknown m) | m == n = r
+ go r = r
+
+typeOccursCheck :: Int -> Type -> Check ()
+typeOccursCheck u (TUnknown _) = return ()
+typeOccursCheck u t = when (occursCheck u t) $ throwError $ "Occurs check failed: " ++ show u ++ " = " ++ prettyPrintType t
+
+rowOccursCheck :: Int -> Row -> Check ()
+rowOccursCheck u (RUnknown _) = return ()
+rowOccursCheck u r = when (occursCheck u r) $ throwError $ "Occurs check failed: " ++ show u ++ " = " ++ prettyPrintRow r
+
+occursCheck :: (D.Data d) => Int -> d -> Bool
+occursCheck u = everything (||) $ flip extQ g $ mkQ False f
+ where
+ f (TUnknown u') | u' == u = True
+ f _ = False
+ g (RUnknown u') | u' == u = True
+ g _ = False
+
+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)
+rowToList r = ([], r)
+
+rowFromList :: ([(String, Type)], Row) -> Row
+rowFromList ([], r) = r
+rowFromList ((name, t):ts, r) = RCons name t (rowFromList (ts, r))
+
+ensureNoDuplicateProperties :: [(String, Value)] -> Check ()
+ensureNoDuplicateProperties ps = guardWith "Duplicate property names" $ length (nub . map fst $ ps) == length ps
+
+typeConstraints :: M.Map Ident Int -> Value -> Check ([TypeConstraint], Int)
+typeConstraints _ v@(NumericLiteral _) = do
+ me <- fresh
+ return ([TypeConstraint me Number (ValueOrigin v)], me)
+typeConstraints _ v@(StringLiteral _) = do
+ me <- fresh
+ return ([TypeConstraint me String (ValueOrigin v)], me)
+typeConstraints _ v@(BooleanLiteral _) = do
+ me <- fresh
+ return ([TypeConstraint me Boolean (ValueOrigin v)], me)
+typeConstraints m v@(ArrayLiteral vals) = do
+ all <- mapM (typeConstraints m) vals
+ let (cs, ns) = (concatMap fst &&& map snd) all
+ me <- fresh
+ return (cs ++ zipWith (\n el -> TypeConstraint me (Array $ TUnknown n) (ValueOrigin el)) ns vals, me)
+typeConstraints m u@(Unary op val) = do
+ (cs, n1) <- typeConstraints m val
+ me <- fresh
+ return (cs ++ unaryOperatorConstraints u op n1 me, me)
+typeConstraints m b@(Binary op left right) = do
+ (cs1, n1) <- typeConstraints m left
+ (cs2, n2) <- typeConstraints m right
+ me <- fresh
+ return (cs1 ++ cs2 ++ binaryOperatorConstraints b op n1 n2 me, me)
+typeConstraints m v@(ObjectLiteral ps) = do
+ ensureNoDuplicateProperties ps
+ all <- mapM (typeConstraints m . snd) ps
+ let (cs, ns) = (concatMap fst &&& map snd) all
+ me <- fresh
+ let tys = zipWith (\(name, _) u -> (name, TUnknown u)) ps ns
+ return (TypeConstraint me (Object (typesToRow tys)) (ValueOrigin v) : cs, me)
+typeConstraints m v@(ObjectUpdate o ps) = do
+ ensureNoDuplicateProperties ps
+ (cs1, n1) <- typeConstraints m o
+ all <- mapM (typeConstraints m . snd) ps
+ let (cs2, ns) = (concatMap fst &&& map snd) all
+ row <- fresh
+ let tys = zipWith (\(name, _) u -> (name, TUnknown u)) ps ns
+ return (TypeConstraint n1 (Object (rowFromList (tys, RUnknown row))) (ValueOrigin v) : cs1 ++ cs2, n1)
+typeConstraints m v@(Indexer index val) = do
+ (cs1, n1) <- typeConstraints m index
+ (cs2, n2) <- typeConstraints m val
+ me <- fresh
+ return (TypeConstraint n1 Number (ValueOrigin index) : TypeConstraint n2 (Array (TUnknown me)) (ValueOrigin v) : cs1 ++ cs2, me)
+typeConstraints m v@(Accessor prop val) = do
+ (cs, n1) <- typeConstraints m val
+ me <- fresh
+ rest <- fresh
+ return (TypeConstraint n1 (Object (RCons prop (TUnknown me) (RUnknown rest))) (ValueOrigin v) : cs, me)
+typeConstraints m v@(Abs args ret) = do
+ ns <- replicateM (length args) fresh
+ let m' = m `M.union` M.fromList (zip args ns)
+ (cs, n') <- typeConstraints m' ret
+ me <- fresh
+ return (TypeConstraint me (Function (map TUnknown ns) (TUnknown n')) (ValueOrigin v) : cs, me)
+typeConstraints m v@(App f xs) = do
+ (cs1, n1) <- typeConstraints m f
+ all <- mapM (typeConstraints m) xs
+ let (cs2, ns) = (concatMap fst &&& map snd) all
+ me <- fresh
+ return (TypeConstraint n1 (Function (map TUnknown ns) (TUnknown me)) (ValueOrigin v) : cs1 ++ cs2, me)
+typeConstraints m v@(Var var) =
+ case M.lookup var m of
+ Nothing -> do
+ env <- getEnv
+ case M.lookup var (names env) of
+ Nothing -> throwError $ show var ++ " is undefined"
+ Just (PolyType idents ty, _) -> do
+ me <- fresh
+ replaced <- replaceVarsWithUnknowns idents ty
+ return ([TypeConstraint me replaced (ValueOrigin v)], me)
+ Just u -> do
+ me <- fresh
+ return ([TypeConstraint u (TUnknown me) (ValueOrigin v)], me)
+typeConstraints m (Block ss) = do
+ ret <- fresh
+ (cs, allCodePathsReturn, _) <- typeConstraintsForBlock m M.empty ret ss
+ guardWith "Block is missing a return statement" allCodePathsReturn
+ return (cs, ret)
+typeConstraints m v@(Constructor c) = do
+ env <- getEnv
+ case M.lookup c (dataConstructors env) of
+ Nothing -> throwError $ "Constructor " ++ c ++ " is undefined"
+ Just (PolyType idents ty) -> do
+ me <- fresh
+ replaced <- replaceVarsWithUnknowns idents ty
+ return ([TypeConstraint me replaced (ValueOrigin v)], me)
+typeConstraints m (Case val binders) = do
+ (cs1, n1) <- typeConstraints m val
+ ret <- fresh
+ cs2 <- typeConstraintsForBinders m n1 ret binders
+ return (cs1 ++ cs2, ret)
+typeConstraints m v@(IfThenElse cond th el) = do
+ (cs1, n1) <- typeConstraints m cond
+ (cs2, n2) <- typeConstraints m th
+ (cs3, n3) <- typeConstraints m el
+ return (TypeConstraint n1 Boolean (ValueOrigin cond) : TypeConstraint n2 (TUnknown n3) (ValueOrigin v) : cs1 ++ cs2 ++ cs3, n2)
+typeConstraints m v@(TypedValue val poly@(PolyType idents ty)) = do
+ kind <- kindOf poly
+ guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star
+ (cs, n1) <- typeConstraints m val
+ return (TypeConstraint n1 ty (ValueOrigin v) : cs, n1)
+
+unaryOperatorConstraints :: Value -> UnaryOperator -> Int -> Int -> [TypeConstraint]
+unaryOperatorConstraints v Negate val result = [TypeConstraint val Number (ValueOrigin v), TypeConstraint result Number (ValueOrigin v)]
+unaryOperatorConstraints v Not val result = [TypeConstraint val Boolean (ValueOrigin v), TypeConstraint result Boolean (ValueOrigin v)]
+unaryOperatorConstraints v BitwiseNot val result = [TypeConstraint val Number (ValueOrigin v), TypeConstraint result Number (ValueOrigin v)]
+
+binaryOperatorConstraints :: Value -> BinaryOperator -> Int -> Int -> Int -> [TypeConstraint]
+binaryOperatorConstraints v Add = symBinOpConstraints v Number
+binaryOperatorConstraints v Subtract = symBinOpConstraints v Number
+binaryOperatorConstraints v Multiply = symBinOpConstraints v Number
+binaryOperatorConstraints v Divide = symBinOpConstraints v Number
+binaryOperatorConstraints v Modulus = symBinOpConstraints v Number
+binaryOperatorConstraints v LessThan = asymBinOpConstraints v Number Boolean
+binaryOperatorConstraints v LessThanOrEqualTo = asymBinOpConstraints v Number Boolean
+binaryOperatorConstraints v GreaterThan = asymBinOpConstraints v Number Boolean
+binaryOperatorConstraints v GreaterThanOrEqualTo = asymBinOpConstraints v Number Boolean
+binaryOperatorConstraints v BitwiseAnd = symBinOpConstraints v Number
+binaryOperatorConstraints v BitwiseOr = symBinOpConstraints v Number
+binaryOperatorConstraints v BitwiseXor = symBinOpConstraints v Number
+binaryOperatorConstraints v ShiftLeft = symBinOpConstraints v Number
+binaryOperatorConstraints v ShiftRight = symBinOpConstraints v Number
+binaryOperatorConstraints v ZeroFillShiftRight = symBinOpConstraints v Number
+binaryOperatorConstraints v EqualTo = equalityBinOpConstraints v
+binaryOperatorConstraints v NotEqualTo = equalityBinOpConstraints v
+binaryOperatorConstraints v And = symBinOpConstraints v Boolean
+binaryOperatorConstraints v Or = symBinOpConstraints v Boolean
+binaryOperatorConstraints v Concat = symBinOpConstraints v String
+
+equalityBinOpConstraints :: Value -> Int -> Int -> Int -> [TypeConstraint]
+equalityBinOpConstraints v left right result = [TypeConstraint left (TUnknown right) (ValueOrigin v), TypeConstraint result Boolean (ValueOrigin v)]
+
+symBinOpConstraints :: Value -> Type -> Int -> Int -> Int -> [TypeConstraint]
+symBinOpConstraints v ty = asymBinOpConstraints v ty ty
+
+asymBinOpConstraints :: Value -> Type -> Type -> Int -> Int -> Int -> [TypeConstraint]
+asymBinOpConstraints v ty res left right result = [TypeConstraint left ty (ValueOrigin v), TypeConstraint right ty (ValueOrigin v), TypeConstraint result res (ValueOrigin v)]
+
+typeConstraintsForBinder :: Int -> Binder -> Check ([TypeConstraint], M.Map Ident Int)
+typeConstraintsForBinder _ NullBinder = return ([], M.empty)
+typeConstraintsForBinder val b@(StringBinder _) = constantBinder b val String
+typeConstraintsForBinder val b@(NumberBinder _) = constantBinder b val Number
+typeConstraintsForBinder val b@(BooleanBinder _) = constantBinder b val Boolean
+typeConstraintsForBinder val b@(VarBinder name) = do
+ me <- fresh
+ return ([TypeConstraint me (TUnknown val) (BinderOrigin b)], M.singleton name me)
+typeConstraintsForBinder val b@(NullaryBinder ctor) = do
+ env <- getEnv
+ case M.lookup ctor (dataConstructors env) of
+ Just (PolyType args ret) -> do
+ ret' <- replaceVarsWithUnknowns args ret
+ return ([TypeConstraint val ret' (BinderOrigin b)], M.empty)
+ _ -> throwError $ "Constructor " ++ ctor ++ " is not defined"
+typeConstraintsForBinder val b@(UnaryBinder ctor binder) = do
+ env <- getEnv
+ case M.lookup ctor (dataConstructors env) of
+ Just (PolyType idents f@(Function [_] _)) -> do
+ obj <- fresh
+ (Function [ty] ret) <- replaceVarsWithUnknowns idents f
+ (cs, m1) <- typeConstraintsForBinder obj binder
+ return (TypeConstraint val ret (BinderOrigin b) : TypeConstraint obj ty (BinderOrigin b) : cs, m1)
+ Just _ -> throwError $ ctor ++ " is not a unary constructor"
+ _ -> throwError $ "Constructor " ++ ctor ++ " is not defined"
+typeConstraintsForBinder val b@(ObjectBinder props) = do
+ row <- fresh
+ rest <- fresh
+ (cs, m1) <- typeConstraintsForProperties row (RUnknown rest) props
+ return (TypeConstraint val (Object (RUnknown row)) (BinderOrigin b) : cs, m1)
+ where
+ typeConstraintsForProperties :: Int -> Row -> [(String, Binder)] -> Check ([TypeConstraint], M.Map Ident Int)
+ typeConstraintsForProperties nrow row [] = return ([RowConstraint nrow row (BinderOrigin b)], M.empty)
+ typeConstraintsForProperties nrow row ((name, binder):binders) = do
+ propTy <- fresh
+ (cs1, m1) <- typeConstraintsForBinder propTy binder
+ (cs2, m2) <- typeConstraintsForProperties nrow (RCons name (TUnknown propTy) row) binders
+ return (cs1 ++ cs2, m1 `M.union` m2)
+typeConstraintsForBinder val b@(ArrayBinder binders rest) = do
+ el <- fresh
+ all <- mapM (typeConstraintsForBinder el) binders
+ let (cs1, m1) = (concatMap fst &&& M.unions . map snd) all
+ let arrayConstraint = TypeConstraint val (Array (TUnknown el)) (BinderOrigin b)
+ case rest of
+ Nothing -> return (arrayConstraint : cs1, m1)
+ Just binder -> do
+ (cs2, m2) <- typeConstraintsForBinder val binder
+ return (arrayConstraint : cs1 ++ cs2, m1 `M.union` m2)
+typeConstraintsForBinder val b@(NamedBinder name binder) = do
+ me <- fresh
+ (cs, m) <- typeConstraintsForBinder val binder
+ return (TypeConstraint me (TUnknown val) (BinderOrigin b) : cs, M.insert name me m)
+typeConstraintsForBinder val b@(GuardedBinder cond binder) = do
+ (cs1, m) <- typeConstraintsForBinder val binder
+ (cs2, n) <- typeConstraints m cond
+ return (TypeConstraint n Boolean (ValueOrigin cond) : cs1 ++ cs2, m)
+
+constantBinder :: Binder -> Int -> Type -> Check ([TypeConstraint], M.Map Ident Int)
+constantBinder b val ty = return ([TypeConstraint val ty (BinderOrigin b)], M.empty)
+
+typeConstraintsForBinders :: M.Map Ident Int -> Int -> Int -> [(Binder, Value)] -> Check [TypeConstraint]
+typeConstraintsForBinders _ _ _ [] = return []
+typeConstraintsForBinders m nval ret ((binder, val):bs) = do
+ (cs1, m1) <- typeConstraintsForBinder nval binder
+ (cs2, n2) <- typeConstraints (m `M.union` m1) val
+ cs3 <- typeConstraintsForBinders m nval ret bs
+ return (TypeConstraint n2 (TUnknown ret) (BinderOrigin binder) : cs1 ++ cs2 ++ cs3)
+
+assignVariable :: Ident -> M.Map Ident Int -> Check ()
+assignVariable name m =
+ case M.lookup name m of
+ Nothing -> return ()
+ Just _ -> throwError $ "Variable with name " ++ show name ++ " already exists."
+
+typeConstraintsForStatement :: M.Map Ident Int -> M.Map Ident Int -> Int -> Statement -> Check ([TypeConstraint], Bool, M.Map Ident Int)
+typeConstraintsForStatement m mass ret (VariableIntroduction name val) = do
+ assignVariable name (m `M.union` mass)
+ (cs1, n1) <- typeConstraints m val
+ return (cs1, False, M.insert name n1 mass)
+typeConstraintsForStatement m mass ret (Assignment ident val) = do
+ (cs1, n1) <- typeConstraints m val
+ case M.lookup ident mass of
+ Nothing -> throwError $ "No local variable with name " ++ show ident
+ Just ty ->
+ return (TypeConstraint n1 (TUnknown ty) (AssignmentTargetOrigin ident) : cs1, False, mass)
+typeConstraintsForStatement m mass ret (While val inner) = do
+ (cs1, n1) <- typeConstraints m val
+ (cs2, allCodePathsReturn, _) <- typeConstraintsForBlock m mass ret inner
+ return (TypeConstraint n1 Boolean (ValueOrigin val) : cs1 ++ cs2, allCodePathsReturn, mass)
+typeConstraintsForStatement m mass ret (If ifst) = do
+ (cs, allCodePathsReturn) <- typeConstraintsForIfStatement m mass ret ifst
+ return (cs, allCodePathsReturn, mass)
+typeConstraintsForStatement m mass ret (For ident start end inner) = do
+ assignVariable ident (m `M.union` mass)
+ (cs1, n1) <- typeConstraints (m `M.union` mass) start
+ (cs2, n2) <- typeConstraints (m `M.union` mass) end
+ let mass1 = M.insert ident n1 mass
+ (cs3, allCodePathsReturn, _) <- typeConstraintsForBlock (m `M.union` mass1) mass1 ret inner
+ return (TypeConstraint n1 Number (ValueOrigin start) : TypeConstraint n2 Number (ValueOrigin end) : cs1 ++ cs2 ++ cs3, allCodePathsReturn, mass)
+typeConstraintsForStatement m mass ret (ForEach ident vals inner) = do
+ assignVariable ident (m `M.union` mass)
+ val <- fresh
+ (cs1, n1) <- typeConstraints (m `M.union` mass) vals
+ let mass1 = M.insert ident val mass
+ (cs2, allCodePathsReturn, _) <- typeConstraintsForBlock (m `M.union` mass1) mass1 ret inner
+ guardWith "Cannot return from within a foreach block" $ not allCodePathsReturn
+ return (TypeConstraint n1 (Array (TUnknown val)) (ValueOrigin vals) : cs1 ++ cs2, False, mass)
+typeConstraintsForStatement m mass ret (Return val) = do
+ (cs1, n1) <- typeConstraints (m `M.union` mass) val
+ return (TypeConstraint n1 (TUnknown ret) (ValueOrigin val) : cs1, True, mass)
+
+typeConstraintsForIfStatement :: M.Map Ident Int -> M.Map Ident Int -> Int -> IfStatement -> Check ([TypeConstraint], Bool)
+typeConstraintsForIfStatement m mass ret (IfStatement val thens Nothing) = do
+ (cs1, n1) <- typeConstraints m val
+ (cs2, _, _) <- typeConstraintsForBlock m mass ret thens
+ return (TypeConstraint n1 Boolean (ValueOrigin val) : cs1 ++ cs2, False)
+typeConstraintsForIfStatement m mass ret (IfStatement val thens (Just elses)) = do
+ (cs1, n1) <- typeConstraints m val
+ (cs2, allCodePathsReturn1, _) <- typeConstraintsForBlock m mass ret thens
+ (cs3, allCodePathsReturn2) <- typeConstraintsForElseStatement m mass ret elses
+ return (TypeConstraint n1 Boolean (ValueOrigin val) : cs1 ++ cs2 ++ cs3, allCodePathsReturn1 && allCodePathsReturn2)
+
+typeConstraintsForElseStatement :: M.Map Ident Int -> M.Map Ident Int -> Int -> ElseStatement -> Check ([TypeConstraint], Bool)
+typeConstraintsForElseStatement m mass ret (Else elses) = do
+ (cs, allCodePathsReturn, _) <- typeConstraintsForBlock m mass ret elses
+ return (cs, allCodePathsReturn)
+typeConstraintsForElseStatement m mass ret (ElseIf ifst) = do
+ (cs, allCodePathsReturn) <- typeConstraintsForIfStatement m mass ret ifst
+ return (cs, allCodePathsReturn)
+
+typeConstraintsForBlock :: M.Map Ident Int -> M.Map Ident Int -> Int -> [Statement] -> Check ([TypeConstraint], Bool, M.Map Ident Int)
+typeConstraintsForBlock _ mass _ [] = return ([], False, mass)
+typeConstraintsForBlock m mass ret (s:ss) = do
+ (cs1, b1, mass1) <- typeConstraintsForStatement (m `M.union` mass) mass ret s
+ case (b1, ss) of
+ (True, []) -> return (cs1, True, mass1)
+ (True, _) -> throwError "Unreachable code"
+ (False, ss) -> do
+ (cs2, b2, mass2) <- typeConstraintsForBlock m mass1 ret ss
+ return (cs1 ++ cs2, b2, mass2)
+
+solveTypeConstraints :: [TypeConstraint] -> TypeSolution -> Check TypeSolution
+solveTypeConstraints [] s = return s
+solveTypeConstraints all@(TypeConstraint n t o:cs) s = do
+ (cs', s') <- rethrow (\err -> "Error in " ++ prettyPrintOrigin o ++ ": " ++ err) $ do
+ typeOccursCheck n t
+ let s' = let (f, g) = runTypeSolution s
+ in TypeSolution (replaceType n t . f, replaceType n t . g)
+ cs' <- fmap concat $ mapM (substituteTypeInConstraint n t) cs
+ return (cs', s')
+ solveTypeConstraints cs' s'
+solveTypeConstraints (RowConstraint n r o:cs) s = do
+ (cs', s') <- rethrow (\err -> "Error in " ++ prettyPrintOrigin o ++ ": " ++ err) $ do
+ rowOccursCheck n r
+ let s' = let (f, g) = runTypeSolution s
+ in TypeSolution (replaceRow n r . f, replaceRow n r . g)
+ cs' <- fmap concat $ mapM (substituteRowInConstraint n r) cs
+ return (cs', s')
+ solveTypeConstraints cs' s'
+
+substituteTypeInConstraint :: Int -> Type -> TypeConstraint -> Check [TypeConstraint]
+substituteTypeInConstraint n s (TypeConstraint m t v)
+ | n == m = unifyTypes v s t
+ | otherwise = return [TypeConstraint m (replaceType n s t) v]
+substituteTypeInConstraint n s (RowConstraint m r v)
+ = return [RowConstraint m (replaceType n s r) v]
+
+substituteRowInConstraint :: Int -> Row -> TypeConstraint -> Check [TypeConstraint]
+substituteRowInConstraint n r (TypeConstraint m t v)
+ = return [TypeConstraint m (replaceRow n r t) v]
+substituteRowInConstraint n r (RowConstraint m r1 v)
+ | m == n = unifyRows v r r1
+ | otherwise = return [RowConstraint m (replaceRow n r r1) v]
+
+unifyTypes :: TypeConstraintOrigin -> Type -> Type -> Check [TypeConstraint]
+unifyTypes _ (TUnknown u1) (TUnknown u2) | u1 == u2 = return []
+unifyTypes o (TUnknown u) t = do
+ typeOccursCheck u t
+ return [TypeConstraint u t o]
+unifyTypes o t (TUnknown u) = do
+ typeOccursCheck u t
+ return [TypeConstraint u t o]
+unifyTypes o (SaturatedTypeSynonym name1 args1) (SaturatedTypeSynonym name2 args2) | name1 == name2 =
+ fmap concat $ zipWithM (unifyTypes o) args1 args2
+unifyTypes o (SaturatedTypeSynonym name args) ty = do
+ env <- getEnv
+ case M.lookup name (typeSynonyms env) of
+ Just (synArgs, body) -> do
+ let m = M.fromList $ zip synArgs args
+ let replaced = replaceTypeVars m body
+ unifyTypes o replaced ty
+ Nothing -> error "Type synonym was not defined"
+unifyTypes o ty s@(SaturatedTypeSynonym _ _) = unifyTypes o s ty
+unifyTypes _ Number Number = return []
+unifyTypes _ String String = return []
+unifyTypes _ Boolean Boolean = return []
+unifyTypes o (Array s) (Array t) = unifyTypes o s t
+unifyTypes o (Object row1) (Object row2) = unifyRows o row1 row2
+unifyTypes o (Function args1 ret1) (Function args2 ret2) = do
+ guardWith "Function applied to incorrect number of args" $ length args1 == length args2
+ cs1 <- fmap concat $ zipWithM (unifyTypes o) args1 args2
+ cs2 <- unifyTypes o ret1 ret2
+ return $ cs1 ++ cs2
+unifyTypes _ (TypeVar v1) (TypeVar v2) | v1 == v2 = return []
+unifyTypes _ (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = return []
+unifyTypes o (TypeApp t1 t2) (TypeApp t3 t4) = do
+ cs1 <- unifyTypes o t1 t3
+ cs2 <- unifyTypes o t2 t4
+ return $ cs1 ++ cs2
+unifyTypes _ t1 t2 = throwError $ "Cannot unify " ++ prettyPrintType t1 ++ " with " ++ prettyPrintType t2 ++ "."
+
+unifyRows :: TypeConstraintOrigin -> Row -> Row -> Check [TypeConstraint]
+unifyRows o r1 r2 =
+ let
+ (s1, r1') = rowToList r1
+ (s2, r2') = rowToList r2
+ int = [ (t1, t2) | (name, t1) <- s1, (name', t2) <- s2, name == name' ]
+ sd1 = [ (name, t1) | (name, t1) <- s1, name `notElem` map fst s2 ]
+ sd2 = [ (name, t2) | (name, t2) <- s2, name `notElem` map fst s1 ]
+ in do
+ cs1 <- fmap concat $ mapM (uncurry $ unifyTypes o) int
+ cs2 <- unifyRows' o sd1 r1' sd2 r2'
+ return $ cs1 ++ cs2
+ where
+ unifyRows' :: TypeConstraintOrigin -> [(String, Type)] -> Row -> [(String, Type)] -> Row -> Check [TypeConstraint]
+ unifyRows' o [] (RUnknown u) sd r = do
+ rowOccursCheck u r
+ return [RowConstraint u (rowFromList (sd, r)) o]
+ unifyRows' o sd r [] (RUnknown u) = do
+ rowOccursCheck u r
+ return [RowConstraint u (rowFromList (sd, r)) o]
+ unifyRows' o ns@((name, ty):row) r others (RUnknown u) | not (occursCheck u (ty, row)) = do
+ u' <- fresh
+ cs <- unifyRows' o row r others (RUnknown u')
+ return (RowConstraint u (RCons name ty (RUnknown u')) o : cs)
+ unifyRows' _ [] REmpty [] REmpty = return []
+ unifyRows' _ [] (RowVar v1) [] (RowVar v2) | v1 == v2 = return []
+ unifyRows' _ sd1 r1 sd2 r2 = throwError $ "Cannot unify " ++ prettyPrintRow (rowFromList (sd1, r1)) ++ " with " ++ prettyPrintRow (rowFromList (sd2, r2)) ++ "."
diff --git a/src/PureScript/Types.hs b/src/PureScript/Types.hs
new file mode 100644
index 0000000..fd35fd4
--- /dev/null
+++ b/src/PureScript/Types.hs
@@ -0,0 +1,43 @@
+-----------------------------------------------------------------------------
+--
+-- Module : Purescript.Types
+-- Copyright : (c) Phil Freeman 2013
+-- License : MIT
+--
+-- Maintainer : Phil Freeman <paf31@cantab.net>
+-- Stability : experimental
+-- Portability :
+--
+-- |
+--
+-----------------------------------------------------------------------------
+
+{-# LANGUAGE DeriveDataTypeable #-}
+
+module PureScript.Types where
+
+import Data.Data
+
+data Type
+ = TUnknown Int
+ | Number
+ | String
+ | Boolean
+ | Array Type
+ | Object Row
+ | Function [Type] Type
+ | TypeVar String
+ | TypeConstructor String
+ | TypeApp Type Type
+ | SaturatedTypeSynonym String [Type] deriving (Show, Eq, Data, Typeable)
+
+data PolyType = PolyType [String] Type deriving (Show, Eq, Data, Typeable)
+
+data Row
+ = RUnknown Int
+ | RowVar String
+ | REmpty
+ | RCons String Type Row deriving (Show, Eq, Data, Typeable)
+
+monoType :: Type -> PolyType
+monoType = PolyType []
diff --git a/src/PureScript/Values.hs b/src/PureScript/Values.hs
new file mode 100644
index 0000000..0ed3765
--- /dev/null
+++ b/src/PureScript/Values.hs
@@ -0,0 +1,97 @@
+-----------------------------------------------------------------------------
+--
+-- Module : PureScript.Values
+-- Copyright : (c) Phil Freeman 2013
+-- License : MIT
+--
+-- Maintainer : Phil Freeman <paf31@cantab.net>
+-- Stability : experimental
+-- Portability :
+--
+-- |
+--
+-----------------------------------------------------------------------------
+
+{-# LANGUAGE DeriveDataTypeable #-}
+
+module PureScript.Values where
+
+import PureScript.Types
+import PureScript.Names
+
+import Data.Data
+
+data UnaryOperator
+ = Negate
+ | Not
+ | BitwiseNot deriving (Show, Eq, Data, Typeable)
+
+data BinaryOperator
+ = Add
+ | Subtract
+ | Multiply
+ | Divide
+ | Modulus
+ | EqualTo
+ | NotEqualTo
+ | LessThan
+ | LessThanOrEqualTo
+ | GreaterThan
+ | GreaterThanOrEqualTo
+ | And
+ | Or
+ | BitwiseAnd
+ | BitwiseOr
+ | BitwiseXor
+ | ShiftLeft
+ | ShiftRight
+ | ZeroFillShiftRight
+ | Concat deriving (Show, Eq, Data, Typeable)
+
+data Value
+ = NumericLiteral (Either Integer Double)
+ | StringLiteral String
+ | BooleanLiteral Bool
+ | Unary UnaryOperator Value
+ | Binary BinaryOperator Value Value
+ | ArrayLiteral [Value]
+ | Indexer Value Value
+ | ObjectLiteral [(String, Value)]
+ | Accessor String Value
+ | ObjectUpdate Value [(String, Value)]
+ | Abs [Ident] Value
+ | App Value [Value]
+ | Var Ident
+ | IfThenElse Value Value Value
+ | Block [Statement]
+ | Constructor String
+ | Case Value [(Binder, Value)]
+ | TypedValue Value PolyType deriving (Show, Data, Typeable)
+
+data Statement
+ = VariableIntroduction Ident Value
+ | Assignment Ident Value
+ | While Value [Statement]
+ | For Ident Value Value [Statement]
+ | ForEach Ident Value [Statement]
+ | If IfStatement
+ | Return Value deriving (Show, Data, Typeable)
+
+data IfStatement = IfStatement Value [Statement] (Maybe ElseStatement) deriving (Show, Data, Typeable)
+
+data ElseStatement
+ = Else [Statement]
+ | ElseIf IfStatement deriving (Show, Data, Typeable)
+
+data Binder
+ = NullBinder
+ | BooleanBinder Bool
+ | StringBinder String
+ | NumberBinder (Either Integer Double)
+ | VarBinder Ident
+ | NullaryBinder String
+ | UnaryBinder String Binder
+ | ObjectBinder [(String, Binder)]
+ | ArrayBinder [Binder] (Maybe Binder)
+ | NamedBinder Ident Binder
+ | GuardedBinder Value Binder deriving (Show, Data, Typeable)
diff --git a/tests/Main.hs b/tests/Main.hs
new file mode 100644
index 0000000..10a56c8
--- /dev/null
+++ b/tests/Main.hs
@@ -0,0 +1,71 @@
+-----------------------------------------------------------------------------
+--
+-- Module : Main
+-- Copyright : (c) Phil Freeman 2013
+-- License : MIT
+--
+-- Maintainer : Phil Freeman <paf31@cantab.net>
+-- Stability : experimental
+-- Portability :
+--
+-- |
+--
+-----------------------------------------------------------------------------
+
+module Main (main) where
+
+import PureScript
+import PureScript.CodeGen.Pretty.Types
+
+import Data.List (isSuffixOf)
+import Control.Applicative
+import Control.Monad
+import System.Exit (exitSuccess, exitFailure)
+import System.FilePath (pathSeparator)
+import System.Directory (getCurrentDirectory, getDirectoryContents)
+import qualified System.IO.UTF8 as U
+import qualified Data.Map as M
+
+compile :: FilePath -> IO (Either String Environment)
+compile inputFile = do
+ ast <- runIndentParser parseDeclarations <$> U.readFile inputFile
+ case ast of
+ Left parseError -> do
+ return (Left $ show parseError)
+ Right decls -> do
+ case check (typeCheckAll decls) of
+ Left typeError -> do
+ return (Left typeError)
+ Right (_, env) -> do
+ return (Right env)
+
+assert :: FilePath -> (Either String Environment -> Maybe String) -> IO ()
+assert inputFile f = do
+ e <- compile inputFile
+ case f e of
+ Just err -> exitFailure
+ Nothing -> return ()
+
+assertCompiles :: FilePath -> IO ()
+assertCompiles inputFile = do
+ putStrLn $ "assert " ++ inputFile ++ " compiles successfully"
+ assert inputFile $ either Just (const Nothing)
+
+assertDoesNotCompile :: FilePath -> IO ()
+assertDoesNotCompile inputFile = do
+ putStrLn $ "assert " ++ inputFile ++ " does not compile"
+ assert inputFile $ either (const Nothing) (const $ Just "Should not have compiled")
+
+main :: IO ()
+main = do
+ cd <- getCurrentDirectory
+ let examples = cd ++ pathSeparator : "examples"
+ let passing = examples ++ pathSeparator : "passing"
+ passingTestCases <- getDirectoryContents passing
+ forM_ passingTestCases $ \inputFile -> when (".ps" `isSuffixOf` inputFile) $
+ assertCompiles (passing ++ pathSeparator : inputFile)
+ let failing = examples ++ pathSeparator : "failing"
+ failingTestCases <- getDirectoryContents failing
+ forM_ failingTestCases $ \inputFile -> when (".ps" `isSuffixOf` inputFile) $
+ assertDoesNotCompile (failing ++ pathSeparator : inputFile)
+ exitSuccess