purescript (empty) → 0.1.0

raw patch · 32 files changed

+3013/−0 lines, 32 filesdep +basedep +cmdthelinedep +containerssetup-changed

Dependencies added: base, cmdtheline, containers, directory, filepath, mtl, parsec, purescript, syb, transformers, utf8-string

Files

• LICENSE +20/−0
• Setup.lhs +6/−0
• purescript.cabal +52/−0
• src/Main.hs +74/−0
• src/PureScript.hs +26/−0
• src/PureScript/CodeGen.hs +21/−0
• src/PureScript/CodeGen/Common.hs +80/−0
• src/PureScript/CodeGen/Common/Gen.hs +31/−0
• src/PureScript/CodeGen/Externs.hs +36/−0
• src/PureScript/CodeGen/JS.hs +232/−0
• src/PureScript/CodeGen/Pretty/Kinds.hs +50/−0
• src/PureScript/CodeGen/Pretty/Types.hs +95/−0
• src/PureScript/CodeGen/Pretty/Values.hs +185/−0
• src/PureScript/Declarations.hs +39/−0
• src/PureScript/Kinds.hs +25/−0
• src/PureScript/Names.hs +26/−0
• src/PureScript/Parser.hs +22/−0
• src/PureScript/Parser/Common.hs +181/−0
• src/PureScript/Parser/Declarations.hs +100/−0
• src/PureScript/Parser/Kinds.hs +41/−0
• src/PureScript/Parser/State.hs +27/−0
• src/PureScript/Parser/Types.hs +91/−0
• src/PureScript/Parser/Values.hs +292/−0
• src/PureScript/Pretty.hs +22/−0
• src/PureScript/TypeChecker.hs +96/−0
• src/PureScript/TypeChecker/Kinds.hs +183/−0
• src/PureScript/TypeChecker/Monad.hs +67/−0
• src/PureScript/TypeChecker/Synonyms.hs +56/−0
• src/PureScript/TypeChecker/Types.hs +626/−0
• src/PureScript/Types.hs +43/−0
• src/PureScript/Values.hs +97/−0
• tests/Main.hs +71/−0

@@ -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.

@@ -0,0 +1,6 @@+#!/usr/bin/runhaskell +> module Main where+> import Distribution.Simple+> main :: IO ()+> main = defaultMain+

@@ -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

@@ -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)

@@ -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+

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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 ] ]

@@ -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

@@ -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

@@ -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)

@@ -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)

@@ -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 ++ ")"+

@@ -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

@@ -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) ""

@@ -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

@@ -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 ] ]

@@ -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++

@@ -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)

@@ -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))

@@ -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+++

@@ -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

@@ -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

@@ -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)

@@ -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+++

@@ -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)) ++ "."

@@ -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 []

@@ -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)

@@ -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