packages feed

purescript 0.1.0 → 0.1.1

raw patch · 57 files changed

+2819/−2811 lines, 57 files

Files

purescript.cabal view
@@ -1,5 +1,5 @@ name: purescript-version: 0.1.0+version: 0.1.1 cabal-version: >=1.8 build-type: Simple license: MIT@@ -11,28 +11,45 @@ description: A small compile-to-JS language with extensible records and type-safe blocks author: Phil Freeman <paf31@cantab.net> data-dir: ""- +category: Language+ 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-modules: Main+                     Language.PureScript+                     Language.PureScript.Declarations+                     Language.PureScript.Names+                     Language.PureScript.Types+                     Language.PureScript.Values+                     Language.PureScript.Kinds+                     Language.PureScript.Pretty+                     Language.PureScript.Pretty.Common+                     Language.PureScript.Pretty.Values+                     Language.PureScript.Pretty.Types+                     Language.PureScript.Pretty.Kinds+                     Language.PureScript.CodeGen+                     Language.PureScript.CodeGen.Externs+                     Language.PureScript.CodeGen.JS+                     Language.PureScript.CodeGen.Monad+                     Language.PureScript.Parser+                     Language.PureScript.Parser.Common+                     Language.PureScript.Parser.Declarations+                     Language.PureScript.Parser.Types+                     Language.PureScript.Parser.Values+                     Language.PureScript.Parser.State+                     Language.PureScript.Parser.Kinds+                     Language.PureScript.TypeChecker+                     Language.PureScript.TypeChecker.Kinds+                     Language.PureScript.TypeChecker.Monad+                     Language.PureScript.TypeChecker.Types+                     Language.PureScript.TypeChecker.Synonyms     exposed: True     buildable: True     hs-source-dirs: src-    other-modules: PureScript.Pretty- +    other-modules:+ executable psc     build-depends: base >=4 && <5, cmdtheline -any, containers -any,                    mtl -any, transformers -any, parsec -any, utf8-string -any,@@ -40,8 +57,7 @@     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,
+ src/Language/PureScript.hs view
@@ -0,0 +1,26 @@+-----------------------------------------------------------------------------+--+-- Module      :  Language.PureScript+-- Copyright   :  (c) Phil Freeman 2013+-- License     :  MIT+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>+-- Stability   :  experimental+-- Portability :+--+-- |+--+-----------------------------------------------------------------------------++module Language.PureScript (module P) where++import Language.PureScript.Values as P+import Language.PureScript.Types as P+import Language.PureScript.Kinds as P+import Language.PureScript.Declarations as P+import Language.PureScript.Names as P+import Language.PureScript.Parser as P+import Language.PureScript.CodeGen as P+import Language.PureScript.TypeChecker as P+import Language.PureScript.Pretty as P+
+ src/Language/PureScript/CodeGen.hs view
@@ -0,0 +1,18 @@+-----------------------------------------------------------------------------+--+-- Module      :  Language.PureScript.CodeGen+-- Copyright   :  (c) Phil Freeman 2013+-- License     :  MIT+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>+-- Stability   :  experimental+-- Portability :+--+-- |+--+-----------------------------------------------------------------------------++module Language.PureScript.CodeGen (module C) where++import Language.PureScript.CodeGen.JS as C+import Language.PureScript.CodeGen.Externs as C
+ src/Language/PureScript/CodeGen/Externs.hs view
@@ -0,0 +1,35 @@+-----------------------------------------------------------------------------+--+-- Module      :  Language.PureScript.CodeGen.Externs+-- Copyright   :  (c) Phil Freeman 2013+-- License     :  MIT+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>+-- Stability   :  experimental+-- Portability :+--+-- |+--+-----------------------------------------------------------------------------++module Language.PureScript.CodeGen.Externs (+    externToPs+) where++import Data.List (intercalate)+import qualified Data.Map as M+import Language.PureScript.Declarations+import Language.PureScript.TypeChecker.Monad+import Language.PureScript.Pretty++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
+ src/Language/PureScript/CodeGen/JS.hs view
@@ -0,0 +1,232 @@+-----------------------------------------------------------------------------+--+-- Module      :  Language.PureScript.CodeGen.JS+-- Copyright   :  (c) Phil Freeman 2013+-- License     :  MIT+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>+-- Stability   :  experimental+-- Portability :+--+-- |+--+-----------------------------------------------------------------------------++module Language.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 Language.PureScript.Types+import Language.PureScript.Values+import Language.PureScript.Names+import Language.PureScript.Declarations+import Language.PureScript.Pretty.Common+import Language.PureScript.CodeGen.Monad++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
+ src/Language/PureScript/CodeGen/Monad.hs view
@@ -0,0 +1,31 @@+-----------------------------------------------------------------------------+--+-- Module      :  Language.PureScript.CodeGen.Monad+-- Copyright   :  (c) Phil Freeman 2013+-- License     :  MIT+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>+-- Stability   :  experimental+-- Portability :+--+-- |+--+-----------------------------------------------------------------------------++{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Language.PureScript.CodeGen.Monad where++import Control.Monad.State+import Control.Applicative++newtype Gen a = Gen { unGen :: State Int a } deriving (Functor, Applicative, Monad, MonadState Int)++runGen :: Gen a -> a+runGen = flip evalState 0 . unGen++fresh :: Gen String+fresh = do+  n <- get+  modify (+ 1)+  return $ '_' : show n
+ src/Language/PureScript/Declarations.hs view
@@ -0,0 +1,39 @@+-----------------------------------------------------------------------------+--+-- Module      :  Language.PureScript.Declarations+-- Copyright   :  (c) Phil Freeman 2013+-- License     :  MIT+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>+-- Stability   :  experimental+-- Portability :+--+-- |+--+-----------------------------------------------------------------------------++{-# LANGUAGE DeriveDataTypeable #-}++module Language.PureScript.Declarations where++import Language.PureScript.Values+import Language.PureScript.Types+import Language.PureScript.Names+import Language.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)
+ src/Language/PureScript/Kinds.hs view
@@ -0,0 +1,25 @@+-----------------------------------------------------------------------------+--+-- Module      :  Language.PureScript.Kinds+-- Copyright   :  (c) Phil Freeman 2013+-- License     :  MIT+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>+-- Stability   :  experimental+-- Portability :+--+-- |+--+-----------------------------------------------------------------------------++{-# LANGUAGE DeriveDataTypeable #-}++module Language.PureScript.Kinds where++import Data.Data++data Kind+  = KUnknown Int+  | Star+  | Row+  | FunKind Kind Kind deriving (Show, Eq, Data, Typeable)
+ src/Language/PureScript/Names.hs view
@@ -0,0 +1,26 @@+-----------------------------------------------------------------------------+--+-- Module      :  Language.PureScript.Names+-- Copyright   :  (c) Phil Freeman 2013+-- License     :  MIT+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>+-- Stability   :  experimental+-- Portability :+--+-- |+--+-----------------------------------------------------------------------------++{-# LANGUAGE DeriveDataTypeable #-}++module Language.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 ++ ")"+
+ src/Language/PureScript/Parser.hs view
@@ -0,0 +1,22 @@+-----------------------------------------------------------------------------+--+-- Module      :  Language.PureScript.Parser+-- Copyright   :  (c) Phil Freeman 2013+-- License     :  MIT+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>+-- Stability   :  experimental+-- Portability :+--+-- |+--+-----------------------------------------------------------------------------++module Language.PureScript.Parser (module P) where++import Language.PureScript.Parser.Common as P+import Language.PureScript.Parser.Types as P+import Language.PureScript.Parser.Values as P+import Language.PureScript.Parser.State as P+import Language.PureScript.Parser.Kinds as P+import Language.PureScript.Parser.Declarations as P
+ src/Language/PureScript/Parser/Common.hs view
@@ -0,0 +1,181 @@+-----------------------------------------------------------------------------+--+-- Module      :  Language.PureScript.Parser.Common+-- Copyright   :  (c) Phil Freeman 2013+-- License     :  MIT+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>+-- Stability   :  experimental+-- Portability :+--+-- |+--+-----------------------------------------------------------------------------++{-# LANGUAGE FlexibleContexts #-}++module Language.PureScript.Parser.Common where++import Data.Char (isSpace)+import Control.Applicative+import Control.Monad+import Control.Monad.State+import Language.PureScript.Parser.State+import qualified Data.Map as M+import qualified Text.Parsec as P+import qualified Text.Parsec.Pos as P+import qualified Text.Parsec.Token as PT++import Language.PureScript.Names++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) ""
+ src/Language/PureScript/Parser/Declarations.hs view
@@ -0,0 +1,100 @@+-----------------------------------------------------------------------------+--+-- Module      :  Language.PureScript.Parser.Declarations+-- Copyright   :  (c) Phil Freeman 2013+-- License     :  MIT+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>+-- Stability   :  experimental+-- Portability :+--+-- |+--+-----------------------------------------------------------------------------++module Language.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 Language.PureScript.Values+import Language.PureScript.Types+import Language.PureScript.Parser.State+import Language.PureScript.Parser.Common+import Language.PureScript.Declarations+import Language.PureScript.Parser.Values+import Language.PureScript.Parser.Types+import Language.PureScript.Parser.Kinds++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
+ src/Language/PureScript/Parser/Kinds.hs view
@@ -0,0 +1,41 @@+-----------------------------------------------------------------------------+--+-- Module      :  Language.PureScript.Parser.Kinds+-- Copyright   :  (c) Phil Freeman 2013+-- License     :  MIT+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>+-- Stability   :  experimental+-- Portability :+--+-- |+--+-----------------------------------------------------------------------------++module Language.PureScript.Parser.Kinds (+    parseKind+) where++import Language.PureScript.Kinds+import Language.PureScript.Parser.State+import Language.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 ] ]
+ src/Language/PureScript/Parser/State.hs view
@@ -0,0 +1,27 @@+-----------------------------------------------------------------------------+--+-- Module      :  Language.PureScript.Parser.State+-- Copyright   :  (c) Phil Freeman 2013+-- License     :  MIT+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>+-- Stability   :  experimental+-- Portability :+--+-- |+--+-----------------------------------------------------------------------------++module Language.PureScript.Parser.State where++import Language.PureScript.Names+import Language.PureScript.Declarations++import qualified Text.Parsec as P+import qualified Data.Map as M++data ParseState = ParseState+  { indentationLevel :: P.Column+  , fixities :: M.Map String Fixity } deriving Show++
+ src/Language/PureScript/Parser/Types.hs view
@@ -0,0 +1,91 @@+-----------------------------------------------------------------------------+--+-- Module      :  Language.PureScript.Parser.Types+-- Copyright   :  (c) Phil Freeman 2013+-- License     :  MIT+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>+-- Stability   :  experimental+-- Portability :+--+-- |+--+-----------------------------------------------------------------------------++module Language.PureScript.Parser.Types (+    parseType,+    parsePolyType,+    parseRow+) where++import Language.PureScript.Types+import Language.PureScript.Parser.State+import Language.PureScript.Parser.Common+import Control.Applicative+import qualified Text.Parsec as P+import qualified Text.Parsec.Expr as P+import Control.Arrow (Arrow(..))++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)
+ src/Language/PureScript/Parser/Values.hs view
@@ -0,0 +1,292 @@+-----------------------------------------------------------------------------+--+-- Module      :  Language.PureScript.Parser.Values+-- Copyright   :  (c) Phil Freeman 2013+-- License     :  MIT+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>+-- Stability   :  experimental+-- Portability :+--+-- |+--+-----------------------------------------------------------------------------++module Language.PureScript.Parser.Values (+    parseValue,+    parseBinder+) where++import Language.PureScript.Values+import Language.PureScript.Names+import Language.PureScript.Declarations+import Language.PureScript.Parser.State+import Data.Function (on)+import Data.List+import Data.Functor.Identity+import qualified Data.Map as M+import qualified Language.PureScript.Parser.Common as C+import Control.Applicative+import qualified Text.Parsec as P+import Text.Parsec.Expr+import Control.Monad+import Control.Arrow (Arrow(..))+import Language.PureScript.Parser.Types+import Language.PureScript.Types++booleanLiteral :: P.Parsec String ParseState Bool+booleanLiteral = (C.reserved "true" >> return True) P.<|> (C.reserved "false" >> return False)++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))
+ src/Language/PureScript/Pretty.hs view
@@ -0,0 +1,22 @@+-----------------------------------------------------------------------------+--+-- Module      :  Language.PureScript.Pretty+-- Copyright   :  (c) Phil Freeman 2013+-- License     :  MIT+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>+-- Stability   :  experimental+-- Portability :+--+-- |+--+-----------------------------------------------------------------------------++module Language.PureScript.Pretty (module P) where++import Language.PureScript.Pretty.Kinds as P+import Language.PureScript.Pretty.Values as P+import Language.PureScript.Pretty.Types as P+++
+ src/Language/PureScript/Pretty/Common.hs view
@@ -0,0 +1,80 @@+-----------------------------------------------------------------------------+--+-- Module      :  Language.PureScript.Pretty.Common+-- Copyright   :  (c) Phil Freeman 2013+-- License     :  MIT+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>+-- Stability   :  experimental+-- Portability :+--+-- |+--+-----------------------------------------------------------------------------++{-# LANGUAGE GeneralizedNewtypeDeriving, GADTs #-}++module Language.PureScript.Pretty.Common where++import Data.Char+import Data.Maybe (fromMaybe)+import Data.List (nub, intersperse, intercalate)+import Data.Function (fix)+import Control.Monad.State+import Control.Applicative (Applicative(..), Alternative(..))+import qualified Control.Category as C+import Control.Category ((>>>))+import qualified Control.Arrow as A+import Control.Arrow ((***), (<+>))++import Language.PureScript.Names+import Language.PureScript.Values+import Language.PureScript.Types+import Language.PureScript.Declarations++identToJs :: Ident -> String+identToJs (Ident name) = name+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
+ src/Language/PureScript/Pretty/Kinds.hs view
@@ -0,0 +1,50 @@+-----------------------------------------------------------------------------+--+-- Module      :  Language.PureScript.Pretty.Kinds+-- Copyright   :  (c) Phil Freeman 2013+-- License     :  MIT+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>+-- Stability   :  experimental+-- Portability :+--+-- |+--+-----------------------------------------------------------------------------++module Language.PureScript.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 Language.PureScript.Kinds+import Language.PureScript.Pretty.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 ] ]
+ src/Language/PureScript/Pretty/Types.hs view
@@ -0,0 +1,95 @@+-----------------------------------------------------------------------------+--+-- Module      :  Language.PureScript.Pretty.Types+-- Copyright   :  (c) Phil Freeman 2013+-- License     :  MIT+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>+-- Stability   :  experimental+-- Portability :+--+-- |+--+-----------------------------------------------------------------------------++module Language.PureScript.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 Language.PureScript.Values+import Language.PureScript.Types+import Language.PureScript.Names+import Language.PureScript.Declarations+import Language.PureScript.TypeChecker.Monad+import Language.PureScript.Pretty.Common++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
+ src/Language/PureScript/Pretty/Values.hs view
@@ -0,0 +1,185 @@+-----------------------------------------------------------------------------+--+-- Module      :  Language.PureScript.Pretty.Values+-- Copyright   :  Kinds.hs(c) Phil Freeman 2013+-- License     :  MIT+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>+-- Stability   :  experimental+-- Portability :+--+-- |+--+-----------------------------------------------------------------------------++module Language.PureScript.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 Language.PureScript.Types+import Language.PureScript.Values+import Language.PureScript.Names+import Language.PureScript.Pretty.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
+ src/Language/PureScript/TypeChecker.hs view
@@ -0,0 +1,96 @@+-----------------------------------------------------------------------------+--+-- Module      :  Language.PureScript.TypeChecker+-- Copyright   :  (c) Phil Freeman 2013+-- License     :  MIT+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>+-- Stability   :  experimental+-- Portability :+--+-- |+--+-----------------------------------------------------------------------------++{-# LANGUAGE FlexibleInstances #-}++module Language.PureScript.TypeChecker (+    module T,+    typeCheckAll+) where++import Language.PureScript.TypeChecker.Monad as T+import Language.PureScript.TypeChecker.Kinds as T+import Language.PureScript.TypeChecker.Types as T+import Language.PureScript.TypeChecker.Synonyms as T++import Data.List+import Data.Maybe+import Data.Function+import qualified Data.Map as M++import Language.PureScript.Values+import Language.PureScript.Types+import Language.PureScript.Names+import Language.PureScript.Kinds+import Language.PureScript.Declarations++import Control.Monad (forM_)+import Control.Monad.State+import Control.Monad.Error++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
+ src/Language/PureScript/TypeChecker/Kinds.hs view
@@ -0,0 +1,182 @@+-----------------------------------------------------------------------------+--+-- Module      :  Language.PureScript.TypeChecker.Kinds+-- Copyright   :  (c) Phil Freeman 2013+-- License     :  MIT+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>+-- Stability   :  experimental+-- Portability :+--+-- |+--+-----------------------------------------------------------------------------++{-# LANGUAGE DeriveDataTypeable #-}++module Language.PureScript.TypeChecker.Kinds (+    KindConstraint(..),+    KindSolution(..),+    kindsOf,+    kindOf+) where++import Data.List+import Data.Maybe (fromMaybe)+import Data.Function+import Data.Data++import Language.PureScript.Types+import Language.PureScript.Kinds+import Language.PureScript.Declarations+import Language.PureScript.TypeChecker.Monad+import Language.PureScript.Pretty++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
+ src/Language/PureScript/TypeChecker/Monad.hs view
@@ -0,0 +1,67 @@+-----------------------------------------------------------------------------+--+-- Module      :  Language.PureScript.TypeChecker.Monad+-- Copyright   :  (c) Phil Freeman 2013+-- License     :  MIT+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>+-- Stability   :  experimental+-- Portability :+--+-- |+--+-----------------------------------------------------------------------------++{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleInstances #-}++module Language.PureScript.TypeChecker.Monad where++import Language.PureScript.Types+import Language.PureScript.Kinds+import Language.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)
+ src/Language/PureScript/TypeChecker/Synonyms.hs view
@@ -0,0 +1,56 @@+-----------------------------------------------------------------------------+--+-- Module      :  Language.PureScript.TypeChecker.Synonyms+-- Copyright   :  (c) Phil Freeman 2013+-- License     :  MIT+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>+-- Stability   :  experimental+-- Portability :+--+-- |+--+-----------------------------------------------------------------------------++{-# LANGUAGE Rank2Types #-}++module Language.PureScript.TypeChecker.Synonyms (+    saturateTypeSynonym,+    saturateAllTypeSynonyms+) where++import Language.PureScript.Types+import Language.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+++
+ src/Language/PureScript/TypeChecker/Types.hs view
@@ -0,0 +1,624 @@+-----------------------------------------------------------------------------+--+-- Module      :  Language.PureScript.TypeChecker.Types+-- Copyright   :  (c) Phil Freeman 2013+-- License     :  MIT+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>+-- Stability   :  experimental+-- Portability :+--+-- |+--+-----------------------------------------------------------------------------++{-# LANGUAGE DeriveDataTypeable #-}++module Language.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 Language.PureScript.Values+import Language.PureScript.Types+import Language.PureScript.Kinds+import Language.PureScript.Names+import Language.PureScript.TypeChecker.Monad+import Language.PureScript.TypeChecker.Kinds+import Language.PureScript.TypeChecker.Synonyms+import Language.PureScript.Pretty++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)) ++ "."
+ src/Language/PureScript/Types.hs view
@@ -0,0 +1,43 @@+-----------------------------------------------------------------------------+--+-- Module      :  Language.PureScript.Types+-- Copyright   :  (c) Phil Freeman 2013+-- License     :  MIT+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>+-- Stability   :  experimental+-- Portability :+--+-- |+--+-----------------------------------------------------------------------------++{-# LANGUAGE DeriveDataTypeable #-}++module Language.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 []
+ src/Language/PureScript/Values.hs view
@@ -0,0 +1,97 @@+-----------------------------------------------------------------------------+--+-- Module      :  Language.PureScript.Values+-- Copyright   :  (c) Phil Freeman 2013+-- License     :  MIT+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>+-- Stability   :  experimental+-- Portability :+--+-- |+--+-----------------------------------------------------------------------------++{-# LANGUAGE DeriveDataTypeable #-}++module Language.PureScript.Values where++import Language.PureScript.Types+import Language.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)
src/Main.hs view
@@ -14,7 +14,7 @@  module Main where -import PureScript+import Language.PureScript import Data.Maybe (mapMaybe) import Data.List (intercalate) import System.Console.CmdTheLine
− src/PureScript.hs 
@@ -1,26 +0,0 @@------------------------------------------------------------------------------------ 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-
− src/PureScript/CodeGen.hs 
@@ -1,21 +0,0 @@------------------------------------------------------------------------------------ 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
− src/PureScript/CodeGen/Common.hs 
@@ -1,80 +0,0 @@------------------------------------------------------------------------------------ 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
− src/PureScript/CodeGen/Common/Gen.hs 
@@ -1,31 +0,0 @@------------------------------------------------------------------------------------ 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
− src/PureScript/CodeGen/Externs.hs 
@@ -1,36 +0,0 @@------------------------------------------------------------------------------------ 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
− src/PureScript/CodeGen/JS.hs 
@@ -1,232 +0,0 @@------------------------------------------------------------------------------------ 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
− src/PureScript/CodeGen/Pretty/Kinds.hs 
@@ -1,50 +0,0 @@------------------------------------------------------------------------------------ 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 ] ]
− src/PureScript/CodeGen/Pretty/Types.hs 
@@ -1,95 +0,0 @@------------------------------------------------------------------------------------ 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
− src/PureScript/CodeGen/Pretty/Values.hs 
@@ -1,185 +0,0 @@------------------------------------------------------------------------------------ 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
− src/PureScript/Declarations.hs 
@@ -1,39 +0,0 @@------------------------------------------------------------------------------------ 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)
− src/PureScript/Kinds.hs 
@@ -1,25 +0,0 @@------------------------------------------------------------------------------------ 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)
− src/PureScript/Names.hs 
@@ -1,26 +0,0 @@------------------------------------------------------------------------------------ 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 ++ ")"-
− src/PureScript/Parser.hs 
@@ -1,22 +0,0 @@------------------------------------------------------------------------------------ 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
− src/PureScript/Parser/Common.hs 
@@ -1,181 +0,0 @@------------------------------------------------------------------------------------ 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) ""
− src/PureScript/Parser/Declarations.hs 
@@ -1,100 +0,0 @@------------------------------------------------------------------------------------ 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
− src/PureScript/Parser/Kinds.hs 
@@ -1,41 +0,0 @@------------------------------------------------------------------------------------ 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 ] ]
− src/PureScript/Parser/State.hs 
@@ -1,27 +0,0 @@------------------------------------------------------------------------------------ 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--
− src/PureScript/Parser/Types.hs 
@@ -1,91 +0,0 @@------------------------------------------------------------------------------------ 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)
− src/PureScript/Parser/Values.hs 
@@ -1,292 +0,0 @@------------------------------------------------------------------------------------ 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))
− src/PureScript/Pretty.hs 
@@ -1,22 +0,0 @@------------------------------------------------------------------------------------ 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---
− src/PureScript/TypeChecker.hs 
@@ -1,96 +0,0 @@------------------------------------------------------------------------------------ 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
− src/PureScript/TypeChecker/Kinds.hs 
@@ -1,183 +0,0 @@------------------------------------------------------------------------------------ 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
− src/PureScript/TypeChecker/Monad.hs 
@@ -1,67 +0,0 @@------------------------------------------------------------------------------------ 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)
− src/PureScript/TypeChecker/Synonyms.hs 
@@ -1,56 +0,0 @@------------------------------------------------------------------------------------ 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---
− src/PureScript/TypeChecker/Types.hs 
@@ -1,626 +0,0 @@------------------------------------------------------------------------------------ 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)) ++ "."
− src/PureScript/Types.hs 
@@ -1,43 +0,0 @@------------------------------------------------------------------------------------ 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 []
− src/PureScript/Values.hs 
@@ -1,97 +0,0 @@------------------------------------------------------------------------------------ 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)
tests/Main.hs view
@@ -14,8 +14,7 @@  module Main (main) where -import PureScript-import PureScript.CodeGen.Pretty.Types+import Language.PureScript  import Data.List (isSuffixOf) import Control.Applicative