diff --git a/purescript.cabal b/purescript.cabal --- a/purescript.cabal +++ b/purescript.cabal @@ -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 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, diff --git a/src/Language/PureScript.hs b/src/Language/PureScript.hs new file mode 100644 --- /dev/null +++ b/src/Language/PureScript.hs @@ -0,0 +1,26 @@ +----------------------------------------------------------------------------- +-- +-- Module : Language.PureScript +-- Copyright : (c) Phil Freeman 2013 +-- License : MIT +-- +-- Maintainer : Phil Freeman +-- 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 + diff --git a/src/Language/PureScript/CodeGen.hs b/src/Language/PureScript/CodeGen.hs new file mode 100644 --- /dev/null +++ b/src/Language/PureScript/CodeGen.hs @@ -0,0 +1,18 @@ +----------------------------------------------------------------------------- +-- +-- Module : Language.PureScript.CodeGen +-- Copyright : (c) Phil Freeman 2013 +-- License : MIT +-- +-- Maintainer : Phil Freeman +-- Stability : experimental +-- Portability : +-- +-- | +-- +----------------------------------------------------------------------------- + +module Language.PureScript.CodeGen (module C) where + +import Language.PureScript.CodeGen.JS as C +import Language.PureScript.CodeGen.Externs as C diff --git a/src/Language/PureScript/CodeGen/Externs.hs b/src/Language/PureScript/CodeGen/Externs.hs new file mode 100644 --- /dev/null +++ b/src/Language/PureScript/CodeGen/Externs.hs @@ -0,0 +1,35 @@ +----------------------------------------------------------------------------- +-- +-- Module : Language.PureScript.CodeGen.Externs +-- Copyright : (c) Phil Freeman 2013 +-- License : MIT +-- +-- Maintainer : Phil Freeman +-- 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 diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs new file mode 100644 --- /dev/null +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -0,0 +1,232 @@ +----------------------------------------------------------------------------- +-- +-- Module : Language.PureScript.CodeGen.JS +-- Copyright : (c) Phil Freeman 2013 +-- License : MIT +-- +-- Maintainer : Phil Freeman +-- 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 diff --git a/src/Language/PureScript/CodeGen/Monad.hs b/src/Language/PureScript/CodeGen/Monad.hs new file mode 100644 --- /dev/null +++ b/src/Language/PureScript/CodeGen/Monad.hs @@ -0,0 +1,31 @@ +----------------------------------------------------------------------------- +-- +-- Module : Language.PureScript.CodeGen.Monad +-- Copyright : (c) Phil Freeman 2013 +-- License : MIT +-- +-- Maintainer : Phil Freeman +-- 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 diff --git a/src/Language/PureScript/Declarations.hs b/src/Language/PureScript/Declarations.hs new file mode 100644 --- /dev/null +++ b/src/Language/PureScript/Declarations.hs @@ -0,0 +1,39 @@ +----------------------------------------------------------------------------- +-- +-- Module : Language.PureScript.Declarations +-- Copyright : (c) Phil Freeman 2013 +-- License : MIT +-- +-- Maintainer : Phil Freeman +-- 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) diff --git a/src/Language/PureScript/Kinds.hs b/src/Language/PureScript/Kinds.hs new file mode 100644 --- /dev/null +++ b/src/Language/PureScript/Kinds.hs @@ -0,0 +1,25 @@ +----------------------------------------------------------------------------- +-- +-- Module : Language.PureScript.Kinds +-- Copyright : (c) Phil Freeman 2013 +-- License : MIT +-- +-- Maintainer : Phil Freeman +-- 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) diff --git a/src/Language/PureScript/Names.hs b/src/Language/PureScript/Names.hs new file mode 100644 --- /dev/null +++ b/src/Language/PureScript/Names.hs @@ -0,0 +1,26 @@ +----------------------------------------------------------------------------- +-- +-- Module : Language.PureScript.Names +-- Copyright : (c) Phil Freeman 2013 +-- License : MIT +-- +-- Maintainer : Phil Freeman +-- 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 ++ ")" + diff --git a/src/Language/PureScript/Parser.hs b/src/Language/PureScript/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Language/PureScript/Parser.hs @@ -0,0 +1,22 @@ +----------------------------------------------------------------------------- +-- +-- Module : Language.PureScript.Parser +-- Copyright : (c) Phil Freeman 2013 +-- License : MIT +-- +-- Maintainer : Phil Freeman +-- 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 diff --git a/src/Language/PureScript/Parser/Common.hs b/src/Language/PureScript/Parser/Common.hs new file mode 100644 --- /dev/null +++ b/src/Language/PureScript/Parser/Common.hs @@ -0,0 +1,181 @@ +----------------------------------------------------------------------------- +-- +-- Module : Language.PureScript.Parser.Common +-- Copyright : (c) Phil Freeman 2013 +-- License : MIT +-- +-- Maintainer : Phil Freeman +-- 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) "" diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs new file mode 100644 --- /dev/null +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -0,0 +1,100 @@ +----------------------------------------------------------------------------- +-- +-- Module : Language.PureScript.Parser.Declarations +-- Copyright : (c) Phil Freeman 2013 +-- License : MIT +-- +-- Maintainer : Phil Freeman +-- 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 diff --git a/src/Language/PureScript/Parser/Kinds.hs b/src/Language/PureScript/Parser/Kinds.hs new file mode 100644 --- /dev/null +++ b/src/Language/PureScript/Parser/Kinds.hs @@ -0,0 +1,41 @@ +----------------------------------------------------------------------------- +-- +-- Module : Language.PureScript.Parser.Kinds +-- Copyright : (c) Phil Freeman 2013 +-- License : MIT +-- +-- Maintainer : Phil Freeman +-- 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 ] ] diff --git a/src/Language/PureScript/Parser/State.hs b/src/Language/PureScript/Parser/State.hs new file mode 100644 --- /dev/null +++ b/src/Language/PureScript/Parser/State.hs @@ -0,0 +1,27 @@ +----------------------------------------------------------------------------- +-- +-- Module : Language.PureScript.Parser.State +-- Copyright : (c) Phil Freeman 2013 +-- License : MIT +-- +-- Maintainer : Phil Freeman +-- 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 + + diff --git a/src/Language/PureScript/Parser/Types.hs b/src/Language/PureScript/Parser/Types.hs new file mode 100644 --- /dev/null +++ b/src/Language/PureScript/Parser/Types.hs @@ -0,0 +1,91 @@ +----------------------------------------------------------------------------- +-- +-- Module : Language.PureScript.Parser.Types +-- Copyright : (c) Phil Freeman 2013 +-- License : MIT +-- +-- Maintainer : Phil Freeman +-- 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) diff --git a/src/Language/PureScript/Parser/Values.hs b/src/Language/PureScript/Parser/Values.hs new file mode 100644 --- /dev/null +++ b/src/Language/PureScript/Parser/Values.hs @@ -0,0 +1,292 @@ +----------------------------------------------------------------------------- +-- +-- Module : Language.PureScript.Parser.Values +-- Copyright : (c) Phil Freeman 2013 +-- License : MIT +-- +-- Maintainer : Phil Freeman +-- 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)) diff --git a/src/Language/PureScript/Pretty.hs b/src/Language/PureScript/Pretty.hs new file mode 100644 --- /dev/null +++ b/src/Language/PureScript/Pretty.hs @@ -0,0 +1,22 @@ +----------------------------------------------------------------------------- +-- +-- Module : Language.PureScript.Pretty +-- Copyright : (c) Phil Freeman 2013 +-- License : MIT +-- +-- Maintainer : Phil Freeman +-- 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 + + + diff --git a/src/Language/PureScript/Pretty/Common.hs b/src/Language/PureScript/Pretty/Common.hs new file mode 100644 --- /dev/null +++ b/src/Language/PureScript/Pretty/Common.hs @@ -0,0 +1,80 @@ +----------------------------------------------------------------------------- +-- +-- Module : Language.PureScript.Pretty.Common +-- Copyright : (c) Phil Freeman 2013 +-- License : MIT +-- +-- Maintainer : Phil Freeman +-- 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 diff --git a/src/Language/PureScript/Pretty/Kinds.hs b/src/Language/PureScript/Pretty/Kinds.hs new file mode 100644 --- /dev/null +++ b/src/Language/PureScript/Pretty/Kinds.hs @@ -0,0 +1,50 @@ +----------------------------------------------------------------------------- +-- +-- Module : Language.PureScript.Pretty.Kinds +-- Copyright : (c) Phil Freeman 2013 +-- License : MIT +-- +-- Maintainer : Phil Freeman +-- 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 ] ] diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs new file mode 100644 --- /dev/null +++ b/src/Language/PureScript/Pretty/Types.hs @@ -0,0 +1,95 @@ +----------------------------------------------------------------------------- +-- +-- Module : Language.PureScript.Pretty.Types +-- Copyright : (c) Phil Freeman 2013 +-- License : MIT +-- +-- Maintainer : Phil Freeman +-- 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 diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs new file mode 100644 --- /dev/null +++ b/src/Language/PureScript/Pretty/Values.hs @@ -0,0 +1,185 @@ +----------------------------------------------------------------------------- +-- +-- Module : Language.PureScript.Pretty.Values +-- Copyright : Kinds.hs(c) Phil Freeman 2013 +-- License : MIT +-- +-- Maintainer : Phil Freeman +-- 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 diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs new file mode 100644 --- /dev/null +++ b/src/Language/PureScript/TypeChecker.hs @@ -0,0 +1,96 @@ +----------------------------------------------------------------------------- +-- +-- Module : Language.PureScript.TypeChecker +-- Copyright : (c) Phil Freeman 2013 +-- License : MIT +-- +-- Maintainer : Phil Freeman +-- 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 diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs new file mode 100644 --- /dev/null +++ b/src/Language/PureScript/TypeChecker/Kinds.hs @@ -0,0 +1,182 @@ +----------------------------------------------------------------------------- +-- +-- Module : Language.PureScript.TypeChecker.Kinds +-- Copyright : (c) Phil Freeman 2013 +-- License : MIT +-- +-- Maintainer : Phil Freeman +-- 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 diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs new file mode 100644 --- /dev/null +++ b/src/Language/PureScript/TypeChecker/Monad.hs @@ -0,0 +1,67 @@ +----------------------------------------------------------------------------- +-- +-- Module : Language.PureScript.TypeChecker.Monad +-- Copyright : (c) Phil Freeman 2013 +-- License : MIT +-- +-- Maintainer : Phil Freeman +-- 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) diff --git a/src/Language/PureScript/TypeChecker/Synonyms.hs b/src/Language/PureScript/TypeChecker/Synonyms.hs new file mode 100644 --- /dev/null +++ b/src/Language/PureScript/TypeChecker/Synonyms.hs @@ -0,0 +1,56 @@ +----------------------------------------------------------------------------- +-- +-- Module : Language.PureScript.TypeChecker.Synonyms +-- Copyright : (c) Phil Freeman 2013 +-- License : MIT +-- +-- Maintainer : Phil Freeman +-- 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 + + + diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs new file mode 100644 --- /dev/null +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -0,0 +1,624 @@ +----------------------------------------------------------------------------- +-- +-- Module : Language.PureScript.TypeChecker.Types +-- Copyright : (c) Phil Freeman 2013 +-- License : MIT +-- +-- Maintainer : Phil Freeman +-- 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)) ++ "." diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs new file mode 100644 --- /dev/null +++ b/src/Language/PureScript/Types.hs @@ -0,0 +1,43 @@ +----------------------------------------------------------------------------- +-- +-- Module : Language.PureScript.Types +-- Copyright : (c) Phil Freeman 2013 +-- License : MIT +-- +-- Maintainer : Phil Freeman +-- 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 [] diff --git a/src/Language/PureScript/Values.hs b/src/Language/PureScript/Values.hs new file mode 100644 --- /dev/null +++ b/src/Language/PureScript/Values.hs @@ -0,0 +1,97 @@ +----------------------------------------------------------------------------- +-- +-- Module : Language.PureScript.Values +-- Copyright : (c) Phil Freeman 2013 +-- License : MIT +-- +-- Maintainer : Phil Freeman +-- 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) diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -14,7 +14,7 @@ module Main where -import PureScript +import Language.PureScript import Data.Maybe (mapMaybe) import Data.List (intercalate) import System.Console.CmdTheLine diff --git a/src/PureScript.hs b/src/PureScript.hs deleted file mode 100644 --- a/src/PureScript.hs +++ /dev/null @@ -1,26 +0,0 @@ ------------------------------------------------------------------------------ --- --- Module : PureScript --- Copyright : (c) Phil Freeman 2013 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- --- | --- ------------------------------------------------------------------------------ - -module PureScript (module P) where - -import PureScript.Values as P -import PureScript.Types as P -import PureScript.Kinds as P -import PureScript.Declarations as P -import PureScript.Names as P -import PureScript.Parser as P -import PureScript.CodeGen as P -import PureScript.TypeChecker as P -import PureScript.Pretty as P - diff --git a/src/PureScript/CodeGen.hs b/src/PureScript/CodeGen.hs deleted file mode 100644 --- a/src/PureScript/CodeGen.hs +++ /dev/null @@ -1,21 +0,0 @@ ------------------------------------------------------------------------------ --- --- Module : PureScript.CodeGen --- Copyright : (c) Phil Freeman 2013 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- --- | --- ------------------------------------------------------------------------------ - -module PureScript.CodeGen ( - module PureScript.CodeGen.JS, - module PureScript.CodeGen.Externs -) where - -import PureScript.CodeGen.JS -import PureScript.CodeGen.Externs diff --git a/src/PureScript/CodeGen/Common.hs b/src/PureScript/CodeGen/Common.hs deleted file mode 100644 --- a/src/PureScript/CodeGen/Common.hs +++ /dev/null @@ -1,80 +0,0 @@ ------------------------------------------------------------------------------ --- --- Module : PureScript.CodeGen.Common --- Copyright : (c) Phil Freeman 2013 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- --- | --- ------------------------------------------------------------------------------ - -{-# LANGUAGE GeneralizedNewtypeDeriving, GADTs #-} - -module PureScript.CodeGen.Common where - -import Data.Char -import Data.Maybe (fromMaybe) -import Data.List (nub, intersperse, intercalate) -import Data.Function (fix) -import Control.Monad.State -import Control.Applicative (Applicative(..), Alternative(..)) -import qualified Control.Category as C -import Control.Category ((>>>)) -import qualified Control.Arrow as A -import Control.Arrow ((***), (<+>)) - -import PureScript.Names -import PureScript.Values -import PureScript.Types -import PureScript.Declarations - -identToJs :: Ident -> String -identToJs (Ident name) = name -identToJs (Op op) = concatMap opCharToString op - where - opCharToString :: Char -> String - opCharToString = (:) '$'. show . ord - -newtype Pattern a b = Pattern { runPattern :: A.Kleisli Maybe a b } deriving (C.Category, A.Arrow, A.ArrowZero, A.ArrowPlus) - -instance Functor (Pattern a) where - fmap f (Pattern p) = Pattern $ A.Kleisli $ fmap f . A.runKleisli p - -pattern :: Pattern a b -> a -> Maybe b -pattern = A.runKleisli . runPattern - -parens :: String -> String -parens s = ('(':s) ++ ")" - -chainl :: Pattern a (a, a) -> (r -> r -> r) -> Pattern a r -> Pattern a r -chainl split f p = fix $ \c -> split >>> ((c <+> p) *** p) >>> A.arr (uncurry f) - -chainr :: Pattern a (a, a) -> (r -> r -> r) -> Pattern a r -> Pattern a r -chainr split f p = fix $ \c -> split >>> (p *** (c <+> p)) >>> A.arr (uncurry f) - -wrap :: Pattern a (s, a) -> (s -> r -> r) -> Pattern a r -> Pattern a r -wrap split f p = fix $ \c -> split >>> (C.id *** (c <+> p)) >>> A.arr (uncurry f) - -split :: Pattern a (s, t) -> (s -> t -> r) -> Pattern a r -> Pattern a r -split s f p = s >>> A.arr (uncurry f) - -data OperatorTable a r = OperatorTable { runOperatorTable :: [ [Operator a r] ] } - -data Operator a r where - AssocL :: Pattern a (a, a) -> (r -> r -> r) -> Operator a r - AssocR :: Pattern a (a, a) -> (r -> r -> r) -> Operator a r - Wrap :: Pattern a (s, a) -> (s -> r -> r) -> Operator a r - Split :: Pattern a (s, t) -> (s -> t -> r) -> Operator a r - -buildPrettyPrinter :: OperatorTable a r -> Pattern a r -> Pattern a r -buildPrettyPrinter table p = foldl (\p' ops -> foldl1 (<+>) (flip map ops $ \op -> - case op of - AssocL pat g -> chainl pat g p' - AssocR pat g -> chainr pat g p' - Wrap pat g -> wrap pat g p' - Split pat g -> split pat g p' - ) <+> p') p $ runOperatorTable table diff --git a/src/PureScript/CodeGen/Common/Gen.hs b/src/PureScript/CodeGen/Common/Gen.hs deleted file mode 100644 --- a/src/PureScript/CodeGen/Common/Gen.hs +++ /dev/null @@ -1,31 +0,0 @@ ------------------------------------------------------------------------------ --- --- Module : PureScript.CodeGen.Common.Gen --- Copyright : (c) Phil Freeman 2013 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- --- | --- ------------------------------------------------------------------------------ - -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -module PureScript.CodeGen.Common.Gen where - -import Control.Monad.State -import Control.Applicative - -newtype Gen a = Gen { unGen :: State Int a } deriving (Functor, Applicative, Monad, MonadState Int) - -runGen :: Gen a -> a -runGen = flip evalState 0 . unGen - -fresh :: Gen String -fresh = do - n <- get - modify (+ 1) - return $ '_' : show n diff --git a/src/PureScript/CodeGen/Externs.hs b/src/PureScript/CodeGen/Externs.hs deleted file mode 100644 --- a/src/PureScript/CodeGen/Externs.hs +++ /dev/null @@ -1,36 +0,0 @@ ------------------------------------------------------------------------------ --- --- Module : PureScript.CodeGen.Externs --- Copyright : (c) Phil Freeman 2013 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- --- | --- ------------------------------------------------------------------------------ - -module PureScript.CodeGen.Externs ( - externToPs -) where - -import Data.List (intercalate) -import qualified Data.Map as M -import PureScript.Declarations -import PureScript.TypeChecker.Monad -import PureScript.CodeGen.Pretty.Types -import PureScript.CodeGen.Pretty.Kinds - -externToPs :: Environment -> Declaration -> Maybe String -externToPs env (ValueDeclaration name _) = do - (ty, _) <- M.lookup name $ names env - return $ "extern " ++ show name ++ " :: " ++ prettyPrintPolyType ty -externToPs env (ExternDeclaration name ty) = - return $ "extern " ++ show name ++ " :: " ++ prettyPrintPolyType ty -externToPs env (ExternDataDeclaration name kind) = - return $ "extern data " ++ name ++ " :: " ++ prettyPrintKind kind -externToPs env (TypeSynonymDeclaration name args ty) = - return $ "type " ++ name ++ " " ++ unwords args ++ " = " ++ prettyPrintType ty -externToPs _ _ = Nothing diff --git a/src/PureScript/CodeGen/JS.hs b/src/PureScript/CodeGen/JS.hs deleted file mode 100644 --- a/src/PureScript/CodeGen/JS.hs +++ /dev/null @@ -1,232 +0,0 @@ ------------------------------------------------------------------------------ --- --- Module : PureScript.CodeGen.JS --- Copyright : (c) Phil Freeman 2013 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- --- | --- ------------------------------------------------------------------------------ - -module PureScript.CodeGen.JS ( - declToJs -) where - -import Data.Char -import Data.Maybe (fromMaybe) -import Data.List (intercalate) -import qualified Control.Arrow as A -import Control.Arrow ((<+>)) -import Control.Monad (forM) -import Control.Applicative - -import PureScript.Types -import PureScript.Values -import PureScript.Names -import PureScript.Declarations -import PureScript.CodeGen.Common -import PureScript.CodeGen.Common.Gen - -declToJs :: Declaration -> Maybe String -declToJs (ValueDeclaration ident (Abs args ret)) = Just $ "function " ++ identToJs ident ++ "(" ++ intercalate "," (map identToJs args) ++ ") { return " ++ valueToJs ret ++ "; }" -declToJs (ValueDeclaration ident val) = Just $ "var " ++ identToJs ident ++ " = " ++ valueToJs val ++ ";" -declToJs (DataDeclaration _ _ ctors) = - Just $ flip concatMap ctors $ \(ctor, maybeTy) -> - case maybeTy of - Nothing -> "var " ++ ctor ++ " = { ctor: '" ++ ctor ++ "' };" - Just _ -> "var " ++ ctor ++ " = function (value) { return { ctor: '" ++ ctor ++ "', value: value }; };" -declToJs _ = Nothing - -literals :: Pattern Value String -literals = Pattern $ A.Kleisli match - where - match (NumericLiteral n) = Just $ either show show n - match (StringLiteral s) = Just $ show s - match (BooleanLiteral True) = Just "true" - match (BooleanLiteral False) = Just "false" - match (ArrayLiteral xs) = Just $ "[" ++ intercalate "," (map valueToJs xs) ++ "]" - match (ObjectLiteral ps) = Just $ "{" ++ intercalate "," (map objectPropertyToJs ps) ++ "}" - match (ObjectUpdate o ps) = Just $ "Object.extend(" - ++ valueToJs o ++ ", { " - ++ intercalate ", " (map objectPropertyToJs ps) ++ " }" - match (Constructor name) = Just name - match (Block sts) = Just $ "(function () {" ++ intercalate ";" (map statementToJs sts) ++ "})()" - match (Case value binders) = Just $ "(" ++ runGen (bindersToJs binders) ++ ")(" ++ valueToJs value ++ ")" - where - bindersToJs :: [(Binder, Value)] -> Gen String - bindersToJs binders = do - valName <- fresh - jss <- forM binders $ \(binder, result) -> do - let js = valueToJs result - binderToJs valName ("return " ++ js ++ ";") binder - return $ "function (" ++ valName ++ ") {" ++ concat jss ++ "throw \"Failed pattern match\"; }" - match (Var ident) = Just (identToJs ident) - match _ = Nothing - -ifThenElse :: Pattern Value ((Value, Value), Value) -ifThenElse = Pattern $ A.Kleisli match - where - match (IfThenElse cond th el) = Just ((th, el), cond) - match _ = Nothing - -accessor :: Pattern Value (String, Value) -accessor = Pattern $ A.Kleisli match - where - match (Accessor prop val) = Just (prop, val) - match _ = Nothing - -indexer :: Pattern Value (String, Value) -indexer = Pattern $ A.Kleisli match - where - match (Indexer index val) = Just (valueToJs index, val) - match _ = Nothing - -app :: Pattern Value (String, Value) -app = Pattern $ A.Kleisli match - where - match (App val args) = Just (intercalate "," (map valueToJs args), val) - match _ = Nothing - -lam :: Pattern Value ([String], Value) -lam = Pattern $ A.Kleisli match - where - match (Abs args val) = Just (map identToJs args, val) - match _ = Nothing - -unary :: UnaryOperator -> String -> Operator Value String -unary op str = Wrap pattern (++) - where - pattern :: Pattern Value (String, Value) - pattern = Pattern $ A.Kleisli match - where - match (Unary op' val) | op' == op = Just (str, val) - match _ = Nothing - -binary :: BinaryOperator -> String -> Operator Value String -binary op str = AssocR pattern (\v1 v2 -> v1 ++ " " ++ str ++ " " ++ v2) - where - pattern :: Pattern Value (Value, Value) - pattern = Pattern $ A.Kleisli match - where - match (Binary op' v1 v2) | op' == op = Just (v1, v2) - match _ = Nothing - -valueToJs :: Value -> String -valueToJs = fromMaybe (error "Incomplete pattern") . pattern matchValue - where - matchValue :: Pattern Value String - matchValue = buildPrettyPrinter operators (literals <+> fmap parens matchValue) - operators :: OperatorTable Value String - operators = - OperatorTable [ [ Wrap accessor $ \prop val -> val ++ "." ++ prop ] - , [ Wrap indexer $ \index val -> val ++ "[" ++ index ++ "]" ] - , [ Wrap app $ \args val -> val ++ "(" ++ args ++ ")" ] - , [ Split lam $ \args val -> "function (" ++ intercalate "," args ++ ") { return " ++ valueToJs val ++ "; }" ] - , [ Wrap ifThenElse $ \(th, el) cond -> cond ++ " ? " ++ valueToJs th ++ " : " ++ valueToJs el ] - , [ binary LessThan "<" ] - , [ binary LessThanOrEqualTo "<=" ] - , [ binary GreaterThan ">" ] - , [ binary GreaterThanOrEqualTo ">=" ] - , [ unary Not "!" ] - , [ unary BitwiseNot "~" ] - , [ unary Negate "-" ] - , [ binary Multiply "*" ] - , [ binary Divide "/" ] - , [ binary Modulus "%" ] - , [ binary Concat "+" ] - , [ binary Add "+" ] - , [ binary Subtract "-" ] - , [ binary ShiftLeft "<<" ] - , [ binary ShiftRight ">>" ] - , [ binary ZeroFillShiftRight ">>>" ] - , [ binary EqualTo "===" ] - , [ binary NotEqualTo "!==" ] - , [ binary BitwiseAnd "&" ] - , [ binary BitwiseXor "^" ] - , [ binary BitwiseOr "|" ] - , [ binary And "&&" ] - , [ binary Or "||" ] - ] - -binderToJs :: String -> String -> Binder -> Gen String -binderToJs varName done NullBinder = return done -binderToJs varName done (StringBinder str) = - return $ "if (" ++ varName ++ " === \"" ++ str ++ "\") {" ++ done ++ " }" -binderToJs varName done (NumberBinder num) = - return $ "if (" ++ varName ++ " === " ++ either show show num ++ ") {" ++ done ++ " }" -binderToJs varName done (BooleanBinder True) = - return $ "if (" ++ varName ++ ") {" ++ done ++ " }" -binderToJs varName done (BooleanBinder False) = - return $ "if (!" ++ varName ++ ") {" ++ done ++ " }" -binderToJs varName done (VarBinder ident) = - return $ "var " ++ identToJs ident ++ " = " ++ varName ++ "; " ++ done -binderToJs varName done (NullaryBinder ctor) = - return $ "if (" ++ varName ++ ".ctor === \"" ++ ctor ++ "\") { " ++ done ++ " }" -binderToJs varName done (UnaryBinder ctor b) = do - value <- fresh - js <- binderToJs value done b - return $ "if (" ++ varName ++ ".ctor === \"" ++ ctor ++ "\") { " ++ "var " ++ value ++ " = " ++ varName ++ ".value; " ++ js ++ " }" -binderToJs varName done (ObjectBinder bs) = go done bs - where - go done [] = return done - go done ((prop, binder):bs) = do - propVar <- fresh - done' <- go done bs - js <- binderToJs propVar done' binder - return $ "var " ++ propVar ++ " = " ++ varName ++ "." ++ prop ++ ";" ++ js -binderToJs varName done (ArrayBinder bs rest) = do - js <- go done rest 0 bs - return $ "if (" ++ varName ++ ".length " ++ cmp ++ " " ++ show (length bs) ++ ") { " ++ js ++ " }" - where - cmp = maybe "===" (const ">=") rest - go done Nothing _ [] = return done - go done (Just binder) index [] = do - restVar <- fresh - js <- binderToJs restVar done binder - return $ "var " ++ restVar ++ " = " ++ varName ++ ".slice(" ++ show index ++ "); " ++ js - go done rest index (binder:bs) = do - elVar <- fresh - done' <- go done rest (index + 1) bs - js <- binderToJs elVar done' binder - return $ "var " ++ elVar ++ " = " ++ varName ++ "[" ++ show index ++ "]; " ++ js -binderToJs varName done (NamedBinder ident binder) = do - js <- binderToJs varName done binder - return $ "var " ++ identToJs ident ++ " = " ++ varName ++ "; " ++ js -binderToJs varName done (GuardedBinder cond binder) = binderToJs varName done' binder - where - done' = "if (" ++ valueToJs cond ++ ") { " ++ done ++ "}" - -objectPropertyToJs :: (String, Value) -> String -objectPropertyToJs (key, value) = key ++ ": " ++ valueToJs value - -statementToJs :: Statement -> String -statementToJs (VariableIntroduction ident value) = "var " ++ identToJs ident ++ " = " ++ valueToJs value -statementToJs (Assignment target value) = identToJs target ++ " = " ++ valueToJs value -statementToJs (While cond sts) = "while (" - ++ valueToJs cond ++ ") {" - ++ intercalate ";" (map statementToJs sts) ++ "}" -statementToJs (For ident start end sts) = "for (" ++ - identToJs ident ++ " = " ++ valueToJs start ++ ";" - ++ identToJs ident ++ " < " ++ valueToJs end ++ ";" - ++ identToJs ident ++ "++) {" - ++ intercalate ";" (map statementToJs sts) ++ "}" -statementToJs (ForEach ident arr sts) = valueToJs arr - ++ ".forEach(function(" ++ identToJs ident ++ ") {" - ++ intercalate ";" (map statementToJs sts) ++ "})" -statementToJs (If ifst) = ifStatementToJs ifst -statementToJs (Return value) = "return " ++ valueToJs value - -ifStatementToJs :: IfStatement -> String -ifStatementToJs (IfStatement cond thens elst) = - "if (" - ++ valueToJs cond ++ ") {" - ++ intercalate ";" (map statementToJs thens) ++ "}" - ++ maybe "" elseStatementToJs elst - -elseStatementToJs :: ElseStatement -> String -elseStatementToJs (Else sts) = " else {" ++ intercalate ";" (map statementToJs sts) ++ "}" -elseStatementToJs (ElseIf ifst) = " else " ++ ifStatementToJs ifst diff --git a/src/PureScript/CodeGen/Pretty/Kinds.hs b/src/PureScript/CodeGen/Pretty/Kinds.hs deleted file mode 100644 --- a/src/PureScript/CodeGen/Pretty/Kinds.hs +++ /dev/null @@ -1,50 +0,0 @@ ------------------------------------------------------------------------------ --- --- Module : PureScript.CodeGen.Pretty.Kinds --- Copyright : (c) Phil Freeman 2013 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- --- | --- ------------------------------------------------------------------------------ - -module PureScript.CodeGen.Pretty.Kinds ( - prettyPrintKind -) where - -import Data.Maybe (fromMaybe) -import Data.List (intersperse, intercalate) -import qualified Control.Arrow as A -import Control.Arrow ((<+>)) -import qualified Data.Map as M -import Control.Applicative - -import PureScript.Kinds -import PureScript.CodeGen.Common - -typeLiterals :: Pattern Kind String -typeLiterals = Pattern $ A.Kleisli match - where - match Star = Just "*" - match Row = Just "#" - match (KUnknown u) = Just $ 'u' : show u - match _ = Nothing - -funKind :: Pattern Kind (Kind, Kind) -funKind = Pattern $ A.Kleisli match - where - match (FunKind arg ret) = Just (arg, ret) - match _ = Nothing - -prettyPrintKind :: Kind -> String -prettyPrintKind = fromMaybe (error "Incomplete pattern") . pattern matchKind - where - matchKind :: Pattern Kind String - matchKind = buildPrettyPrinter operators (typeLiterals <+> fmap parens matchKind) - operators :: OperatorTable Kind String - operators = - OperatorTable [ [ AssocR funKind $ \arg ret -> arg ++ " -> " ++ ret ] ] diff --git a/src/PureScript/CodeGen/Pretty/Types.hs b/src/PureScript/CodeGen/Pretty/Types.hs deleted file mode 100644 --- a/src/PureScript/CodeGen/Pretty/Types.hs +++ /dev/null @@ -1,95 +0,0 @@ ------------------------------------------------------------------------------ --- --- Module : PureScript.CodeGen.Pretty.Types --- Copyright : (c) Phil Freeman 2013 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- --- | --- ------------------------------------------------------------------------------ - -module PureScript.CodeGen.Pretty.Types ( - prettyPrintType, - prettyPrintRow, - prettyPrintPolyType -) where - -import Data.Maybe (fromMaybe) -import Data.List (intersperse, intercalate) -import qualified Control.Arrow as A -import Control.Arrow ((<+>)) -import qualified Data.Map as M -import Control.Applicative - -import PureScript.Values -import PureScript.Types -import PureScript.Names -import PureScript.Declarations -import PureScript.TypeChecker.Monad -import PureScript.CodeGen.Common - -typeLiterals :: Pattern Type String -typeLiterals = Pattern $ A.Kleisli match - where - match Number = Just "Number" - match String = Just "String" - match Boolean = Just "Boolean" - match (Array ty) = Just $ "[" ++ prettyPrintType ty ++ "]" - match (Object row) = Just $ "{ " ++ prettyPrintRow row ++ " }" - match (TypeVar var) = Just var - match (TypeConstructor ctor) = Just ctor - match (TUnknown u) = Just $ 'u' : show u - match (SaturatedTypeSynonym name args) = Just $ name ++ "<" ++ intercalate "," (map prettyPrintType args) ++ ">" - match _ = Nothing - -prettyPrintRow :: Row -> String -prettyPrintRow = (\(tys, tail) -> intercalate "; " (map (uncurry nameAndTypeToPs) tys) ++ tailToPs tail) . toList [] - where - nameAndTypeToPs :: String -> Type -> String - nameAndTypeToPs name ty = name ++ " :: " ++ prettyPrintType ty - tailToPs :: Row -> String - tailToPs REmpty = "" - tailToPs (RUnknown u) = " | " ++ show u - tailToPs (RowVar var) = " | " ++ var - toList :: [(String, Type)] -> Row -> ([(String, Type)], Row) - toList tys (RCons name ty row) = toList ((name, ty):tys) row - toList tys r = (tys, r) - -typeApp :: Pattern Type (Type, Type) -typeApp = Pattern $ A.Kleisli match - where - match (TypeApp f x) = Just (f, x) - match _ = Nothing - -singleArgumentFunction :: Pattern Type (Type, Type) -singleArgumentFunction = Pattern $ A.Kleisli match - where - match (Function [arg] ret) = Just (arg, ret) - match _ = Nothing - -function :: Pattern Type ([Type], Type) -function = Pattern $ A.Kleisli match - where - match (Function args ret) = Just (args, ret) - match _ = Nothing - -prettyPrintType :: Type -> String -prettyPrintType = fromMaybe (error "Incomplete pattern") . pattern matchType - where - matchType :: Pattern Type String - matchType = buildPrettyPrinter operators (typeLiterals <+> fmap parens matchType) - operators :: OperatorTable Type String - operators = - OperatorTable [ [ AssocL typeApp $ \f x -> f ++ " " ++ x ] - , [ AssocR singleArgumentFunction $ \arg ret -> arg ++ " -> " ++ ret - , Wrap function $ \args ret -> "(" ++ intercalate ", " (map prettyPrintType args) ++ ") -> " ++ ret - ] - ] - -prettyPrintPolyType :: PolyType -> String -prettyPrintPolyType (PolyType [] ty) = prettyPrintType ty -prettyPrintPolyType (PolyType idents ty) = "forall " ++ unwords idents ++ ". " ++ prettyPrintType ty diff --git a/src/PureScript/CodeGen/Pretty/Values.hs b/src/PureScript/CodeGen/Pretty/Values.hs deleted file mode 100644 --- a/src/PureScript/CodeGen/Pretty/Values.hs +++ /dev/null @@ -1,185 +0,0 @@ ------------------------------------------------------------------------------ --- --- Module : PureScript.CodeGen.Pretty.Values --- Copyright : Kinds.hs(c) Phil Freeman 2013 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- --- | --- ------------------------------------------------------------------------------ - -module PureScript.CodeGen.Pretty.Values ( - prettyPrintValue, - prettyPrintBinder -) where - -import Data.Char -import Data.Maybe (fromMaybe) -import Data.List (intercalate) -import qualified Control.Arrow as A -import Control.Arrow ((<+>)) -import Control.Applicative - -import PureScript.Types -import PureScript.Values -import PureScript.Names -import PureScript.CodeGen.Common - -literals :: Pattern Value String -literals = Pattern $ A.Kleisli match - where - match (NumericLiteral n) = Just $ either show show n - match (StringLiteral s) = Just $ show s - match (BooleanLiteral True) = Just "true" - match (BooleanLiteral False) = Just "false" - match (ArrayLiteral xs) = Just $ "[" ++ intercalate ", " (map prettyPrintValue xs) ++ "]" - match (ObjectLiteral ps) = Just $ "{" ++ intercalate ", " (map (uncurry prettyPrintObjectProperty) ps) ++ "}" - match (Constructor name) = Just name - match (Block sts) = Just $ "do { " ++ intercalate " ; " (map prettyPrintStatement sts) ++ " }" - match (Case value binders) = Just $ "case " ++ prettyPrintValue value ++ " of { " ++ intercalate " ; " (map (uncurry prettyPrintCaseAlternative) binders) ++ " }" - match (Var ident) = Just $ show ident - match _ = Nothing - -prettyPrintCaseAlternative :: Binder -> Value -> String -prettyPrintCaseAlternative binder val = prettyPrintBinder binder ++ " -> " ++ prettyPrintValue val - -ifThenElse :: Pattern Value ((Value, Value), Value) -ifThenElse = Pattern $ A.Kleisli match - where - match (IfThenElse cond th el) = Just ((th, el), cond) - match _ = Nothing - -accessor :: Pattern Value (String, Value) -accessor = Pattern $ A.Kleisli match - where - match (Accessor prop val) = Just (prop, val) - match _ = Nothing - -indexer :: Pattern Value (String, Value) -indexer = Pattern $ A.Kleisli match - where - match (Indexer index val) = Just (prettyPrintValue index, val) - match _ = Nothing - -objectUpdate :: Pattern Value ([String], Value) -objectUpdate = Pattern $ A.Kleisli match - where - match (ObjectUpdate o ps) = Just (flip map ps $ \(key, val) -> key ++ " = " ++ prettyPrintValue val, o) - match _ = Nothing - -app :: Pattern Value (String, Value) -app = Pattern $ A.Kleisli match - where - match (App val args) = Just (intercalate "," (map prettyPrintValue args), val) - match _ = Nothing - -lam :: Pattern Value ([String], Value) -lam = Pattern $ A.Kleisli match - where - match (Abs args val) = Just (map show args, val) - match _ = Nothing - -unary :: UnaryOperator -> String -> Operator Value String -unary op str = Wrap pattern (++) - where - pattern :: Pattern Value (String, Value) - pattern = Pattern $ A.Kleisli match - where - match (Unary op' val) | op' == op = Just (str, val) - match _ = Nothing - -binary :: BinaryOperator -> String -> Operator Value String -binary op str = AssocR pattern (\v1 v2 -> v1 ++ " " ++ str ++ " " ++ v2) - where - pattern :: Pattern Value (Value, Value) - pattern = Pattern $ A.Kleisli match - where - match (Binary op' v1 v2) | op' == op = Just (v1, v2) - match _ = Nothing - -prettyPrintValue :: Value -> String -prettyPrintValue = fromMaybe (error "Incomplete pattern") . pattern matchValue - where - matchValue :: Pattern Value String - matchValue = buildPrettyPrinter operators (literals <+> fmap parens matchValue) - operators :: OperatorTable Value String - operators = - OperatorTable [ [ Wrap accessor $ \prop val -> val ++ "." ++ prop ] - , [ Wrap indexer $ \index val -> val ++ "[" ++ index ++ "]" ] - , [ Wrap objectUpdate $ \ps val -> val ++ "{ " ++ intercalate ", " ps ++ " }" ] - , [ Wrap app $ \args val -> val ++ "(" ++ args ++ ")" ] - , [ Split lam $ \args val -> "function (" ++ intercalate "," args ++ ") { return " ++ prettyPrintValue val ++ "; }" ] - , [ Wrap ifThenElse $ \(th, el) cond -> cond ++ " ? " ++ prettyPrintValue th ++ " : " ++ prettyPrintValue el ] - , [ binary LessThan "<" ] - , [ binary LessThanOrEqualTo "<=" ] - , [ binary GreaterThan ">" ] - , [ binary GreaterThanOrEqualTo ">=" ] - , [ unary Not "!" ] - , [ unary BitwiseNot "~" ] - , [ unary Negate "-" ] - , [ binary Multiply "*" ] - , [ binary Divide "/" ] - , [ binary Modulus "%" ] - , [ binary Concat "++" ] - , [ binary Add "+" ] - , [ binary Subtract "-" ] - , [ binary ShiftLeft "<<" ] - , [ binary ShiftRight ">>" ] - , [ binary ZeroFillShiftRight ">>>" ] - , [ binary EqualTo "==" ] - , [ binary NotEqualTo "!=" ] - , [ binary BitwiseAnd "&" ] - , [ binary BitwiseXor "^" ] - , [ binary BitwiseOr "|" ] - , [ binary And "&&" ] - , [ binary Or "||" ] - ] - -prettyPrintBinder :: Binder -> String -prettyPrintBinder NullBinder = "_" -prettyPrintBinder (StringBinder str) = show str -prettyPrintBinder (NumberBinder num) = either show show num -prettyPrintBinder (BooleanBinder True) = "true" -prettyPrintBinder (BooleanBinder False) = "false" -prettyPrintBinder (VarBinder ident) = show ident -prettyPrintBinder (NullaryBinder ctor) = ctor -prettyPrintBinder (UnaryBinder ctor b) = ctor ++ prettyPrintBinder b -prettyPrintBinder (ObjectBinder bs) = "{ " ++ intercalate ", " (map (uncurry prettyPrintObjectPropertyBinder) bs) ++ " }" -prettyPrintBinder (ArrayBinder bs rest) = "[ " ++ intercalate ", " (map prettyPrintBinder bs) ++ maybe "" (("; " ++) . prettyPrintBinder) rest ++ " ]" -prettyPrintBinder (NamedBinder ident binder) = show ident ++ "@" ++ prettyPrintBinder binder -prettyPrintBinder (GuardedBinder cond binder) = prettyPrintBinder binder ++ " | " ++ prettyPrintValue cond - -prettyPrintObjectPropertyBinder :: String -> Binder -> String -prettyPrintObjectPropertyBinder key binder = key ++ ": " ++ prettyPrintBinder binder - -prettyPrintObjectProperty :: String -> Value -> String -prettyPrintObjectProperty key value = key ++ ": " ++ prettyPrintValue value - -prettyPrintStatement :: Statement -> String -prettyPrintStatement (VariableIntroduction ident value) = "var " ++ show ident ++ " = " ++ prettyPrintValue value -prettyPrintStatement (Assignment target value) = show target ++ " = " ++ prettyPrintValue value -prettyPrintStatement (While cond sts) = "while " ++ prettyPrintValue cond ++ ": {" ++ intercalate ";" (map prettyPrintStatement sts) ++ " }" -prettyPrintStatement (For ident start end sts) = "for " ++ show ident - ++ " <- " ++ prettyPrintValue start - ++ " until " ++ prettyPrintValue end ++ ": {" - ++ intercalate "; " (map prettyPrintStatement sts) ++ " }" -prettyPrintStatement (ForEach ident arr sts) = "foreach " ++ show ident - ++ " in " ++ prettyPrintValue arr ++ ": {" - ++ intercalate "; " (map prettyPrintStatement sts) ++ " }" -prettyPrintStatement (If ifst) = prettyPrintIfStatement ifst -prettyPrintStatement (Return value) = "return " ++ prettyPrintValue value - -prettyPrintIfStatement :: IfStatement -> String -prettyPrintIfStatement (IfStatement cond thens elst) = - "if " - ++ prettyPrintValue cond ++ ": {" - ++ intercalate "; " (map prettyPrintStatement thens) ++ " }" - ++ maybe "" prettyPrintElseStatement elst - -prettyPrintElseStatement :: ElseStatement -> String -prettyPrintElseStatement (Else sts) = "else: {" ++ intercalate "; " (map prettyPrintStatement sts) ++ " }" -prettyPrintElseStatement (ElseIf ifst) = "else " ++ prettyPrintIfStatement ifst diff --git a/src/PureScript/Declarations.hs b/src/PureScript/Declarations.hs deleted file mode 100644 --- a/src/PureScript/Declarations.hs +++ /dev/null @@ -1,39 +0,0 @@ ------------------------------------------------------------------------------ --- --- Module : PureScript.Declarations --- Copyright : (c) Phil Freeman 2013 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- --- | --- ------------------------------------------------------------------------------ - -{-# LANGUAGE DeriveDataTypeable #-} - -module PureScript.Declarations where - -import PureScript.Values -import PureScript.Types -import PureScript.Names -import PureScript.Kinds - -import qualified Data.Data as D - -type Precedence = Integer - -data Associativity = Infixl | Infixr deriving (Show, D.Data, D.Typeable) - -data Fixity = Fixity Associativity Precedence deriving (Show, D.Data, D.Typeable) - -data Declaration - = DataDeclaration String [String] [(String, Maybe Type)] - | TypeSynonymDeclaration String [String] Type - | TypeDeclaration Ident PolyType - | ValueDeclaration Ident Value - | ExternDeclaration Ident PolyType - | ExternDataDeclaration String Kind - | FixityDeclaration Fixity String deriving (Show, D.Data, D.Typeable) diff --git a/src/PureScript/Kinds.hs b/src/PureScript/Kinds.hs deleted file mode 100644 --- a/src/PureScript/Kinds.hs +++ /dev/null @@ -1,25 +0,0 @@ ------------------------------------------------------------------------------ --- --- Module : PureScript.Kinds --- Copyright : (c) Phil Freeman 2013 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- --- | --- ------------------------------------------------------------------------------ - -{-# LANGUAGE DeriveDataTypeable #-} - -module PureScript.Kinds where - -import Data.Data - -data Kind - = KUnknown Int - | Star - | Row - | FunKind Kind Kind deriving (Show, Eq, Data, Typeable) diff --git a/src/PureScript/Names.hs b/src/PureScript/Names.hs deleted file mode 100644 --- a/src/PureScript/Names.hs +++ /dev/null @@ -1,26 +0,0 @@ ------------------------------------------------------------------------------ --- --- Module : PureScript.Names --- Copyright : (c) Phil Freeman 2013 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- --- | --- ------------------------------------------------------------------------------ - -{-# LANGUAGE DeriveDataTypeable #-} - -module PureScript.Names where - -import Data.Data - -data Ident = Ident String | Op String deriving (Eq, Ord, Data, Typeable) - -instance Show Ident where - show (Ident s) = s - show (Op op) = '(':op ++ ")" - diff --git a/src/PureScript/Parser.hs b/src/PureScript/Parser.hs deleted file mode 100644 --- a/src/PureScript/Parser.hs +++ /dev/null @@ -1,22 +0,0 @@ ------------------------------------------------------------------------------ --- --- Module : PureScript.Parser --- Copyright : (c) Phil Freeman 2013 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- --- | --- ------------------------------------------------------------------------------ - -module PureScript.Parser (module P) where - -import PureScript.Parser.Common as P -import PureScript.Parser.Types as P -import PureScript.Parser.Values as P -import PureScript.Parser.State as P -import PureScript.Parser.Kinds as P -import PureScript.Parser.Declarations as P diff --git a/src/PureScript/Parser/Common.hs b/src/PureScript/Parser/Common.hs deleted file mode 100644 --- a/src/PureScript/Parser/Common.hs +++ /dev/null @@ -1,181 +0,0 @@ ------------------------------------------------------------------------------ --- --- Module : PureScript.Parser.Common --- Copyright : (c) Phil Freeman 2013 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- --- | --- ------------------------------------------------------------------------------ - -{-# LANGUAGE FlexibleContexts #-} - -module PureScript.Parser.Common where - -import Data.Char (isSpace) -import Control.Applicative -import Control.Monad -import Control.Monad.State -import PureScript.Parser.State -import qualified Data.Map as M -import qualified Text.Parsec as P -import qualified Text.Parsec.Pos as P -import qualified Text.Parsec.Token as PT - -import PureScript.Names - -reservedNames :: [String] -reservedNames = [ "case" - , "of" - , "data" - , "type" - , "var" - , "val" - , "while" - , "for" - , "foreach" - , "if" - , "then" - , "else" - , "return" - , "true" - , "false" - , "extern" - , "forall" - , "do" - , "until" - , "in" - , "break" - , "catch" - , "continue" - , "debugger" - , "default" - , "delete" - , "finally" - , "function" - , "instanceof" - , "new" - , "switch" - , "this" - , "throw" - , "try" - , "typeof" - , "void" - , "with" - , "Number" - , "String" - , "Boolean" - , "infixl" - , "infixr" ] - -reservedOpNames :: [String] -reservedOpNames = [ "!", "~", "-", "<=", ">=", "<", ">", "*", "/", "%", "++", "+", "<<", ">>>", ">>" - , "==", "!=", "&", "^", "|", "&&", "||", "->" ] - -identStart :: P.Parsec String u Char -identStart = P.lower <|> P.oneOf "_$" - -properNameStart :: P.Parsec String u Char -properNameStart = P.upper - -identLetter :: P.Parsec String u Char -identLetter = P.alphaNum <|> P.oneOf "_'" - -opStart :: P.Parsec String u Char -opStart = P.oneOf "!#$%&*+/<=>?@^|-~" - -opLetter :: P.Parsec String u Char -opLetter = P.oneOf ":#$%&*+./<=>?@^|" - -langDef = PT.LanguageDef - { PT.reservedNames = reservedNames - , PT.reservedOpNames = reservedOpNames - , PT.commentStart = "{-" - , PT.commentEnd = "-}" - , PT.commentLine = "--" - , PT.nestedComments = True - , PT.identStart = identStart - , PT.identLetter = identLetter - , PT.opStart = opStart - , PT.opLetter = opLetter - , PT.caseSensitive = True - } - -tokenParser = PT.makeTokenParser langDef - -lexeme = PT.lexeme tokenParser -identifier = PT.identifier tokenParser -reserved = PT.reserved tokenParser -reservedOp = PT.reservedOp tokenParser -operator = PT.operator tokenParser -stringLiteral = PT.stringLiteral tokenParser -whiteSpace = PT.whiteSpace tokenParser -parens = PT.parens tokenParser -braces = PT.braces tokenParser -angles = PT.angles tokenParser -squares = PT.squares tokenParser -semi = PT.semi tokenParser -comma = PT.comma tokenParser -colon = PT.colon tokenParser -dot = PT.dot tokenParser -semiSep = PT.semiSep tokenParser -semiSep1 = PT.semiSep1 tokenParser -commaSep = PT.commaSep tokenParser -commaSep1 = PT.commaSep1 tokenParser -natural = PT.natural tokenParser - -tick :: P.Parsec String u Char -tick = lexeme $ P.char '`' - -properName :: P.Parsec String u String -properName = lexeme $ P.try ((:) <$> P.upper <*> many (PT.identLetter langDef) P. "name") - -integerOrFloat :: P.Parsec String u (Either Integer Double) -integerOrFloat = (Left <$> P.try (PT.natural tokenParser) <|> - Right <$> P.try (PT.float tokenParser)) P. "number" - -augment :: P.Stream s m t => P.ParsecT s u m a -> P.ParsecT s u m b -> (a -> b -> a) -> P.ParsecT s u m a -augment p q f = flip (maybe id $ flip f) <$> p <*> P.optionMaybe q - -fold :: P.Stream s m t => P.ParsecT s u m a -> P.ParsecT s u m b -> (a -> b -> a) -> P.ParsecT s u m a -fold first more combine = do - a <- first - bs <- P.many more - return $ foldl combine a bs - -buildPostfixParser :: P.Stream s m t => [P.ParsecT s u m (a -> a)] -> P.ParsecT s u m a -> P.ParsecT s u m a -buildPostfixParser f x = fold x (P.choice (map P.try f)) (flip ($)) - -parseIdent :: P.Parsec String u Ident -parseIdent = (Ident <$> identifier) <|> (Op <$> parens operator) - -parseIdentInfix :: P.Parsec String u Ident -parseIdentInfix = (Ident <$> P.between tick tick identifier) <|> (Op <$> operator) - -mark :: P.Parsec String ParseState a -> P.Parsec String ParseState a -mark p = do - current <- indentationLevel <$> P.getState - pos <- P.sourceColumn <$> P.getPosition - P.modifyState $ \st -> st { indentationLevel = pos } - a <- p - P.modifyState $ \st -> st { indentationLevel = current } - return a - -checkIndentation :: (P.Column -> P.Column -> Bool) -> P.Parsec String ParseState () -checkIndentation rel = do - col <- P.sourceColumn <$> P.getPosition - current <- indentationLevel <$> P.getState - guard (col `rel` current) - -indented :: P.Parsec String ParseState () -indented = checkIndentation (>) P. "indentation" - -same :: P.Parsec String ParseState () -same = checkIndentation (==) P. "no indentation" - -runIndentParser :: P.Parsec String ParseState a -> String -> Either P.ParseError a -runIndentParser p = P.runParser p (ParseState 0 M.empty) "" diff --git a/src/PureScript/Parser/Declarations.hs b/src/PureScript/Parser/Declarations.hs deleted file mode 100644 --- a/src/PureScript/Parser/Declarations.hs +++ /dev/null @@ -1,100 +0,0 @@ ------------------------------------------------------------------------------ --- --- Module : PureScript.Parser.Declarations --- Copyright : (c) Phil Freeman 2013 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- --- | --- ------------------------------------------------------------------------------ - -module PureScript.Parser.Declarations ( - parseDeclaration, - parseDeclarations -) where - -import Data.Char -import Data.List -import Data.Maybe -import Data.Function -import Control.Applicative -import Control.Arrow (Arrow(..)) -import Control.Monad.State -import qualified Data.Map as M -import qualified Text.Parsec as P -import qualified Text.Parsec.Pos as P - -import PureScript.Values -import PureScript.Types -import PureScript.Parser.State -import PureScript.Parser.Common -import PureScript.Declarations -import PureScript.Parser.Values -import PureScript.Parser.Types -import PureScript.Parser.Kinds - -parseDataDeclaration :: P.Parsec String ParseState Declaration -parseDataDeclaration = do - reserved "data" - name <- indented *> properName - tyArgs <- many (indented *> identifier) - lexeme $ indented *> P.char '=' - ctors <- P.sepBy1 ((,) <$> (indented *> properName) <*> P.optionMaybe parseType) (lexeme $ indented *> P.char '|') - return $ DataDeclaration name tyArgs ctors - -parseTypeDeclaration :: P.Parsec String ParseState Declaration -parseTypeDeclaration = - TypeDeclaration <$> parseIdent - <*> (lexeme (indented *> P.string "::") *> parsePolyType) - -parseTypeSynonymDeclaration :: P.Parsec String ParseState Declaration -parseTypeSynonymDeclaration = - TypeSynonymDeclaration <$> (reserved "type" *> indented *> properName) - <*> many (indented *> identifier) - <*> (lexeme (indented *> P.char '=') *> parseType) - -parseValueDeclaration :: P.Parsec String ParseState Declaration -parseValueDeclaration = - ValueDeclaration <$> parseIdent - <*> (lexeme (indented *> P.char '=') *> parseValue) - -parseExternDeclaration :: P.Parsec String ParseState Declaration -parseExternDeclaration = reserved "extern" *> indented *> - (ExternDataDeclaration <$> (reserved "data" *> indented *> properName) - <*> (lexeme (indented *> P.string "::") *> parseKind) - <|> ExternDeclaration <$> parseIdent - <*> (lexeme (indented *> P.string "::") *> parsePolyType)) - -parseAssociativity :: P.Parsec String ParseState Associativity -parseAssociativity = - (reserved "infixl" >> return Infixl) <|> - (reserved "infixr" >> return Infixr) - -parseFixity :: P.Parsec String ParseState Fixity -parseFixity = Fixity <$> parseAssociativity <*> (indented *> natural) - -parseFixityDeclaration :: P.Parsec String ParseState Declaration -parseFixityDeclaration = do - fixity <- parseFixity - indented - name <- operator - current <- fixities <$> P.getState - when (name `M.member` current) (P.unexpected $ "redefined fixity for " ++ show name) - P.modifyState $ \st -> st { fixities = M.insert name fixity current } - return $ FixityDeclaration fixity name - -parseDeclaration :: P.Parsec String ParseState Declaration -parseDeclaration = P.choice (map P.try - [ parseDataDeclaration - , parseTypeDeclaration - , parseTypeSynonymDeclaration - , parseValueDeclaration - , parseExternDeclaration - , parseFixityDeclaration ]) P. "declaration" - -parseDeclarations :: P.Parsec String ParseState [Declaration] -parseDeclarations = whiteSpace *> mark (same *> P.many parseDeclaration) <* P.eof diff --git a/src/PureScript/Parser/Kinds.hs b/src/PureScript/Parser/Kinds.hs deleted file mode 100644 --- a/src/PureScript/Parser/Kinds.hs +++ /dev/null @@ -1,41 +0,0 @@ ------------------------------------------------------------------------------ --- --- Module : PureScript.Parser.Kinds --- Copyright : (c) Phil Freeman 2013 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- --- | --- ------------------------------------------------------------------------------ - -module PureScript.Parser.Kinds ( - parseKind -) where - -import PureScript.Kinds -import PureScript.Parser.State -import PureScript.Parser.Common -import Control.Applicative -import qualified Text.Parsec as P -import qualified Text.Parsec.Expr as P - -parseStar :: P.Parsec String ParseState Kind -parseStar = const Star <$> lexeme (P.char '*') - -parseRow :: P.Parsec String ParseState Kind -parseRow = const Row <$> lexeme (P.char '#') - -parseTypeAtom :: P.Parsec String ParseState Kind -parseTypeAtom = indented *> P.choice (map P.try - [ parseStar - , parseRow - , parens parseKind ]) - -parseKind :: P.Parsec String ParseState Kind -parseKind = P.buildExpressionParser operators parseTypeAtom P. "kind" - where - operators = [ [ P.Infix (lexeme (P.try (P.string "->")) >> return FunKind) P.AssocRight ] ] diff --git a/src/PureScript/Parser/State.hs b/src/PureScript/Parser/State.hs deleted file mode 100644 --- a/src/PureScript/Parser/State.hs +++ /dev/null @@ -1,27 +0,0 @@ ------------------------------------------------------------------------------ --- --- Module : PureScript.Parser.State --- Copyright : (c) Phil Freeman 2013 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- --- | --- ------------------------------------------------------------------------------ - -module PureScript.Parser.State where - -import PureScript.Names -import PureScript.Declarations - -import qualified Text.Parsec as P -import qualified Data.Map as M - -data ParseState = ParseState - { indentationLevel :: P.Column - , fixities :: M.Map String Fixity } deriving Show - - diff --git a/src/PureScript/Parser/Types.hs b/src/PureScript/Parser/Types.hs deleted file mode 100644 --- a/src/PureScript/Parser/Types.hs +++ /dev/null @@ -1,91 +0,0 @@ ------------------------------------------------------------------------------ --- --- Module : PureScript.Parser.Types --- Copyright : (c) Phil Freeman 2013 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- --- | --- ------------------------------------------------------------------------------ - -module PureScript.Parser.Types ( - parseType, - parsePolyType, - parseRow -) where - -import PureScript.Types -import PureScript.Parser.State -import PureScript.Parser.Common -import Control.Applicative -import qualified Text.Parsec as P -import qualified Text.Parsec.Expr as P -import Control.Arrow (Arrow(..)) - -parseNumber :: P.Parsec String ParseState Type -parseNumber = const Number <$> reserved "Number" - -parseString :: P.Parsec String ParseState Type -parseString = const String <$> reserved "String" - -parseBoolean :: P.Parsec String ParseState Type -parseBoolean = const Boolean <$> reserved "Boolean" - -parseArray :: P.Parsec String ParseState Type -parseArray = squares $ Array <$> parseType - -parseObject :: P.Parsec String ParseState Type -parseObject = braces $ Object <$> parseRow - -parseFunction :: P.Parsec String ParseState Type -parseFunction = do - args <- lexeme $ parens $ commaSep parseType - lexeme $ P.string "->" - resultType <- parseType - return $ Function args resultType - -parseTypeVariable :: P.Parsec String ParseState Type -parseTypeVariable = TypeVar <$> identifier - -parseTypeConstructor :: P.Parsec String ParseState Type -parseTypeConstructor = TypeConstructor <$> properName - -parseTypeAtom :: P.Parsec String ParseState Type -parseTypeAtom = indented *> P.choice (map P.try - [ parseNumber - , parseString - , parseBoolean - , parseArray - , parseObject - , parseFunction - , parseTypeVariable - , parseTypeConstructor - , parens parseType ]) - -parsePolyType :: P.Parsec String ParseState PolyType -parsePolyType = (PolyType <$> P.option [] (indented *> reserved "forall" *> many (indented *> identifier) <* indented <* dot) - <*> parseType) P. "polymorphic type" - -parseType :: P.Parsec String ParseState Type -parseType = (P.buildExpressionParser operators . buildPostfixParser postfixTable $ parseTypeAtom) P. "type" - where - postfixTable :: [P.Parsec String ParseState (Type -> Type)] - postfixTable = [ flip TypeApp <$> (indented *> parseTypeAtom) ] - operators = [ [ P.Infix (lexeme (P.try (P.string "->")) >> return (\t1 t2 -> Function [t1] t2)) P.AssocRight ] ] - -parseNameAndType :: P.Parsec String ParseState (String, Type) -parseNameAndType = (,) <$> (indented *> identifier <* indented <* lexeme (P.string "::")) <*> parseType - -parseRowEnding :: P.Parsec String ParseState Row -parseRowEnding = P.option REmpty (RowVar <$> (lexeme (indented *> P.char '|') *> indented *> identifier)) - -parseRow :: P.Parsec String ParseState Row -parseRow = (fromList <$> (parseNameAndType `P.sepBy` (indented *> semi)) <*> parseRowEnding) P. "row" - where - fromList :: [(String, Type)] -> Row -> Row - fromList [] r = r - fromList ((name, t):ts) r = RCons name t (fromList ts r) diff --git a/src/PureScript/Parser/Values.hs b/src/PureScript/Parser/Values.hs deleted file mode 100644 --- a/src/PureScript/Parser/Values.hs +++ /dev/null @@ -1,292 +0,0 @@ ------------------------------------------------------------------------------ --- --- Module : PureScript.Parser.Values --- Copyright : (c) Phil Freeman 2013 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- --- | --- ------------------------------------------------------------------------------ - -module PureScript.Parser.Values ( - parseValue, - parseBinder -) where - -import PureScript.Values -import PureScript.Names -import PureScript.Declarations -import PureScript.Parser.State -import Data.Function (on) -import Data.List -import Data.Functor.Identity -import qualified Data.Map as M -import qualified PureScript.Parser.Common as C -import Control.Applicative -import qualified Text.Parsec as P -import Text.Parsec.Expr -import Control.Monad -import Control.Arrow (Arrow(..)) -import PureScript.Parser.Types -import PureScript.Types - -booleanLiteral :: P.Parsec String ParseState Bool -booleanLiteral = (C.reserved "true" >> return True) P.<|> (C.reserved "false" >> return False) - -parseNumericLiteral :: P.Parsec String ParseState Value -parseNumericLiteral = NumericLiteral <$> C.integerOrFloat - -parseStringLiteral :: P.Parsec String ParseState Value -parseStringLiteral = StringLiteral <$> C.stringLiteral - -parseBooleanLiteral :: P.Parsec String ParseState Value -parseBooleanLiteral = BooleanLiteral <$> booleanLiteral - -parseArrayLiteral :: P.Parsec String ParseState Value -parseArrayLiteral = ArrayLiteral <$> C.squares (parseValue `P.sepBy` (C.indented *> C.comma)) - -parseObjectLiteral :: P.Parsec String ParseState Value -parseObjectLiteral = ObjectLiteral <$> C.braces (parseIdentifierAndValue `P.sepBy` (C.indented *> C.comma)) - -parseIdentifierAndValue :: P.Parsec String ParseState (String, Value) -parseIdentifierAndValue = (,) <$> (C.indented *> C.identifier <* C.indented <* C.colon) - <*> (C.indented *> parseValue) - -parseAbs :: P.Parsec String ParseState Value -parseAbs = do - C.lexeme $ P.char '\\' - args <- (C.indented *> C.parseIdent) `P.sepBy` (C.indented *> C.comma) - C.lexeme $ C.indented *> P.string "->" - value <- parseValue - return $ Abs args value - -parseApp :: P.Parsec String ParseState Value -parseApp = App <$> parseValue - <*> (C.indented *> C.parens (parseValue `P.sepBy` (C.indented *> C.comma))) - -parseVar :: P.Parsec String ParseState Value -parseVar = Var <$> C.parseIdent - -parseConstructor :: P.Parsec String ParseState Value -parseConstructor = Constructor <$> C.properName - -parseCase :: P.Parsec String ParseState Value -parseCase = Case <$> P.between (C.reserved "case") (C.indented *> C.reserved "of") parseValue - <*> (C.indented *> C.mark (P.many (C.same *> C.mark parseCaseAlternative))) - -parseCaseAlternative :: P.Parsec String ParseState (Binder, Value) -parseCaseAlternative = (,) <$> (parseGuardedBinder <* C.lexeme (P.string "->")) - <*> parseValue - P. "case alternative" - -parseIfThenElse :: P.Parsec String ParseState Value -parseIfThenElse = IfThenElse <$> (C.reserved "if" *> C.indented *> parseValue) - <*> (C.indented *> C.reserved "then" *> C.indented *> parseValue) - <*> (C.indented *> C.reserved "else" *> C.indented *> parseValue) - -parseBlock :: P.Parsec String ParseState Value -parseBlock = Block <$> (C.reserved "do" *> parseManyStatements) - -parseManyStatements :: P.Parsec String ParseState [Statement] -parseManyStatements = C.indented *> C.mark (P.many (C.same *> C.mark parseStatement)) P. "block" - -parseValueAtom :: P.Parsec String ParseState Value -parseValueAtom = C.indented *> P.choice (map P.try - [ parseNumericLiteral - , parseStringLiteral - , parseBooleanLiteral - , parseArrayLiteral - , parseObjectLiteral - , parseAbs - , parseVar - , parseConstructor - , parseBlock - , parseCase - , parseIfThenElse - , C.parens parseValue ]) - -parsePropertyUpdate :: P.Parsec String ParseState (String, Value) -parsePropertyUpdate = do - name <- C.lexeme C.identifier - C.lexeme $ C.indented *> P.char '=' - value <- C.indented *> parseValue - return (name, value) - -parseValue :: P.Parsec String ParseState Value -parseValue = do - customOps <- fixities <$> P.getState - (buildExpressionParser (operators customOps) - . C.buildPostfixParser postfixTable2 - $ indexersAndAccessors) P. "expression" - where - indexersAndAccessors = C.buildPostfixParser postfixTable1 parseValueAtom - postfixTable1 = [ Accessor <$> (C.indented *> C.dot *> C.indented *> C.identifier) - , Indexer <$> (C.indented *> C.squares parseValue) - , flip ObjectUpdate <$> (C.indented *> C.braces ((C.indented *> parsePropertyUpdate) `P.sepBy1` (C.indented *> C.comma))) ] - postfixTable2 = [ C.indented *> indexersAndAccessors >>= \t2 -> return (\t1 -> App t1 [t2]) - , flip App <$> (C.indented *> C.parens (parseValue `P.sepBy` (C.indented *> C.comma))) - , flip TypedValue <$> (P.try (C.lexeme (C.indented *> P.string "::")) *> parsePolyType) ] - operators user = - [ [ Prefix $ C.lexeme (P.try $ C.indented *> C.reservedOp "!") >> return (Unary Not) - , Prefix $ C.lexeme (P.try $ C.indented *> C.reservedOp "~") >> return (Unary BitwiseNot) - , Prefix $ C.lexeme (P.try $ C.indented *> C.reservedOp "-") >> return (Unary Negate) - , Prefix $ C.lexeme (P.try $ C.indented *> C.reservedOp "+") >> return id ] - ] ++ customOperatorTable user ++ - [ [ Infix (C.lexeme (P.try (C.indented *> C.parseIdentInfix P. "operator") >>= \ident -> return $ \t1 t2 -> App (App (Var ident) [t1]) [t2])) AssocLeft ] - , [ Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "<=") >> return (Binary LessThanOrEqualTo)) AssocRight - , Infix (C.lexeme (P.try $ C.indented *> C.reservedOp ">=") >> return (Binary GreaterThanOrEqualTo)) AssocRight ] - , [ Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "<") >> return (Binary LessThan)) AssocRight - , Infix (C.lexeme (P.try $ C.indented *> C.reservedOp ">") >> return (Binary GreaterThan)) AssocRight ] - , [ Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "*") >> return (Binary Multiply)) AssocRight - , Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "/") >> return (Binary Divide)) AssocRight - , Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "%") >> return (Binary Modulus)) AssocRight ] - , [ Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "++") >> return (Binary Concat)) AssocRight - , Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "+") >> return (Binary Add)) AssocRight - , Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "-") >> return (Binary Subtract)) AssocRight ] - , [ Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "<<") >> return (Binary ShiftLeft)) AssocRight - , Infix (C.lexeme (P.try $ C.indented *> C.reservedOp ">>>") >> return (Binary ZeroFillShiftRight)) AssocRight - , Infix (C.lexeme (P.try $ C.indented *> C.reservedOp ">>") >> return (Binary ShiftRight)) AssocRight ] - , [ Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "==") >> return (Binary EqualTo)) AssocRight - , Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "!=") >> return (Binary NotEqualTo)) AssocRight ] - , [ Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "&") >> return (Binary BitwiseAnd)) AssocRight ] - , [ Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "^") >> return (Binary BitwiseXor)) AssocRight ] - , [ Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "|") >> return (Binary BitwiseOr)) AssocRight ] - , [ Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "&&") >> return (Binary And)) AssocRight ] - , [ Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "||") >> return (Binary Or)) AssocRight ] - ] - -customOperatorTable :: M.Map String Fixity -> OperatorTable String ParseState Identity Value -customOperatorTable fixities = - let - ops = map (\(name, Fixity a p) -> (name, (a, p))) . M.toList $ fixities - sorted = sortBy (compare `on` (snd . snd)) ops - levels = groupBy ((==) `on` (snd . snd)) sorted - in - map (map $ \(name, (a, _)) -> - flip Infix (toAssoc a) $ - C.lexeme $ P.try $ do - C.indented - C.reservedOp name P. "operator" - return $ \t1 t2 -> App (App (Var (Op name)) [t1]) [t2]) - levels - - -toAssoc :: Associativity -> Assoc -toAssoc Infixl = AssocLeft -toAssoc Infixr = AssocRight - -parseVariableIntroduction :: P.Parsec String ParseState Statement -parseVariableIntroduction = do - C.reserved "var" - name <- C.indented *> C.parseIdent - C.lexeme $ C.indented *> P.char '=' - value <- parseValue - return $ VariableIntroduction name value - -parseAssignment :: P.Parsec String ParseState Statement -parseAssignment = do - tgt <- C.parseIdent - C.lexeme $ C.indented *> P.char '=' - value <- parseValue - return $ Assignment tgt value - -parseWhile :: P.Parsec String ParseState Statement -parseWhile = While <$> (C.reserved "while" *> C.indented *> parseValue <* C.indented <* C.colon) - <*> parseManyStatements - -parseFor :: P.Parsec String ParseState Statement -parseFor = For <$> (C.reserved "for" *> C.indented *> C.parseIdent) - <*> (C.indented *> C.lexeme (P.string "<-") *> parseValue) - <*> (C.indented *> C.reserved "until" *> parseValue <* C.colon) - <*> parseManyStatements - -parseForEach :: P.Parsec String ParseState Statement -parseForEach = ForEach <$> (C.reserved "foreach" *> C.indented *> C.parseIdent) - <*> (C.indented *> C.reserved "in" *> parseValue <* C.colon) - <*> parseManyStatements - -parseIf :: P.Parsec String ParseState Statement -parseIf = If <$> parseIfStatement - -parseIfStatement :: P.Parsec String ParseState IfStatement -parseIfStatement = - IfStatement <$> (C.reserved "if" *> C.indented *> parseValue <* C.indented <* C.colon) - <*> parseManyStatements - <*> P.optionMaybe (C.same *> parseElseStatement) - -parseElseStatement :: P.Parsec String ParseState ElseStatement -parseElseStatement = C.reserved "else" >> (ElseIf <$> (C.indented *> parseIfStatement) - <|> Else <$> (C.indented *> C.colon *> parseManyStatements)) - -parseReturn :: P.Parsec String ParseState Statement -parseReturn = Return <$> (C.reserved "return" *> parseValue) - -parseStatement :: P.Parsec String ParseState Statement -parseStatement = P.choice (map P.try - [ parseVariableIntroduction - , parseAssignment - , parseWhile - , parseFor - , parseForEach - , parseIf - , parseReturn ]) P. "statement" - -parseStringBinder :: P.Parsec String ParseState Binder -parseStringBinder = StringBinder <$> C.stringLiteral - -parseBooleanBinder :: P.Parsec String ParseState Binder -parseBooleanBinder = BooleanBinder <$> booleanLiteral - -parseNumberBinder :: P.Parsec String ParseState Binder -parseNumberBinder = NumberBinder <$> C.integerOrFloat - -parseVarBinder :: P.Parsec String ParseState Binder -parseVarBinder = VarBinder <$> C.parseIdent - -parseNullaryBinder :: P.Parsec String ParseState Binder -parseNullaryBinder = NullaryBinder <$> C.lexeme C.properName - -parseUnaryBinder :: P.Parsec String ParseState Binder -parseUnaryBinder = UnaryBinder <$> C.lexeme C.properName <*> (C.indented *> parseBinder) - -parseObjectBinder :: P.Parsec String ParseState Binder -parseObjectBinder = ObjectBinder <$> C.braces ((C.indented *> parseIdentifierAndBinder) `P.sepBy` (C.indented *> C.comma)) - -parseArrayBinder :: P.Parsec String ParseState Binder -parseArrayBinder = C.squares $ ArrayBinder <$> ((C.indented *> parseBinder) `P.sepBy` (C.indented *> C.comma)) - <*> P.optionMaybe (C.indented *> C.colon *> C.indented *> parseBinder) - -parseNamedBinder :: P.Parsec String ParseState Binder -parseNamedBinder = NamedBinder <$> (C.parseIdent <* C.indented <* C.lexeme (P.char '@')) - <*> (C.indented *> parseBinder) - -parseNullBinder :: P.Parsec String ParseState Binder -parseNullBinder = C.lexeme (P.char '_') *> P.notFollowedBy C.identLetter *> return NullBinder - -parseIdentifierAndBinder :: P.Parsec String ParseState (String, Binder) -parseIdentifierAndBinder = do - name <- C.lexeme C.identifier - C.lexeme $ C.indented *> P.char '=' - binder <- C.indented *> parseBinder - return (name, binder) - -parseBinder :: P.Parsec String ParseState Binder -parseBinder = P.choice (map P.try - [ parseNullBinder - , parseStringBinder - , parseBooleanBinder - , parseNumberBinder - , parseNamedBinder - , parseVarBinder - , parseUnaryBinder - , parseNullaryBinder - , parseObjectBinder - , parseArrayBinder - , C.parens parseBinder ]) P. "binder" - -parseGuardedBinder :: P.Parsec String ParseState Binder -parseGuardedBinder = flip ($) <$> parseBinder <*> P.option id (GuardedBinder <$> (C.indented *> C.lexeme (P.char '|') *> C.indented *> parseValue)) diff --git a/src/PureScript/Pretty.hs b/src/PureScript/Pretty.hs deleted file mode 100644 --- a/src/PureScript/Pretty.hs +++ /dev/null @@ -1,22 +0,0 @@ ------------------------------------------------------------------------------ --- --- Module : PureScript.Pretty --- Copyright : (c) Phil Freeman 2013 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- --- | --- ------------------------------------------------------------------------------ - -module PureScript.Pretty (module P) where - -import PureScript.CodeGen.Pretty.Kinds as P -import PureScript.CodeGen.Pretty.Values as P -import PureScript.CodeGen.Pretty.Types as P - - - diff --git a/src/PureScript/TypeChecker.hs b/src/PureScript/TypeChecker.hs deleted file mode 100644 --- a/src/PureScript/TypeChecker.hs +++ /dev/null @@ -1,96 +0,0 @@ ------------------------------------------------------------------------------ --- --- Module : PureScript.TypeChecker --- Copyright : (c) Phil Freeman 2013 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- --- | --- ------------------------------------------------------------------------------ - -{-# LANGUAGE FlexibleInstances #-} - -module PureScript.TypeChecker ( -module T, - typeCheckAll -) where - -import PureScript.TypeChecker.Monad as T -import PureScript.TypeChecker.Kinds as T -import PureScript.TypeChecker.Types as T -import PureScript.TypeChecker.Synonyms as T - -import Data.List -import Data.Maybe -import Data.Function -import qualified Data.Map as M - -import PureScript.Values -import PureScript.Types -import PureScript.Names -import PureScript.Kinds -import PureScript.Declarations - -import Control.Monad (forM_) -import Control.Monad.State -import Control.Monad.Error - -typeCheckAll :: [Declaration] -> Check () -typeCheckAll [] = return () -typeCheckAll (DataDeclaration name args dctors : rest) = do - rethrow (("Error in type constructor " ++ name ++ ": ") ++) $ do - env <- getEnv - guardWith (name ++ " is already defined") $ not $ M.member name (types env) - ctorKind <- kindsOf (Just name) args (mapMaybe snd dctors) - putEnv $ env { types = M.insert name (ctorKind, Data) (types env) } - forM_ dctors $ \(dctor, maybeTy) -> - rethrow (("Error in data constructor " ++ name ++ ": ") ++) $ do - env' <- getEnv - guardWith (dctor ++ " is already defined") $ not $ M.member dctor (dataConstructors env') - let retTy = foldl TypeApp (TypeConstructor name) (map TypeVar args) - let dctorTy = maybe retTy (\ty -> Function [ty] retTy) maybeTy - let polyType = PolyType args dctorTy - putEnv $ env' { dataConstructors = M.insert dctor polyType (dataConstructors env') } - typeCheckAll rest -typeCheckAll (TypeSynonymDeclaration name args ty : rest) = do - rethrow (("Error in type synonym " ++ name ++ ": ") ++) $ do - env <- getEnv - guardWith (name ++ " is already defined") $ not $ M.member name (types env) - kind <- kindsOf (Just name) args [ty] - putEnv $ env { types = M.insert name (kind, TypeSynonym) (types env) - , typeSynonyms = M.insert name (args, ty) (typeSynonyms env) } - typeCheckAll rest -typeCheckAll (TypeDeclaration name ty : ValueDeclaration name' val : rest) | name == name' = - typeCheckAll (ValueDeclaration name (TypedValue val ty) : rest) -typeCheckAll (TypeDeclaration name _ : _) = throwError $ "Orphan type declaration for " ++ show name -typeCheckAll (ValueDeclaration name val : rest) = do - rethrow (("Error in declaration " ++ show name ++ ": ") ++) $ do - env <- getEnv - case M.lookup name (names env) of - Just ty -> throwError $ show name ++ " is already defined" - Nothing -> do - ty <- typeOf name val - putEnv (env { names = M.insert name (ty, Value) (names env) }) - typeCheckAll rest -typeCheckAll (ExternDataDeclaration name kind : rest) = do - env <- getEnv - guardWith (name ++ " is already defined") $ not $ M.member name (types env) - putEnv $ env { types = M.insert name (kind, TypeSynonym) (types env) } - typeCheckAll rest -typeCheckAll (ExternDeclaration name ty : rest) = do - rethrow (("Error in extern declaration " ++ show name ++ ": ") ++) $ do - env <- getEnv - kind <- kindOf ty - guardWith "Expected kind *" $ kind == Star - case M.lookup name (names env) of - Just _ -> throwError $ show name ++ " is already defined" - Nothing -> putEnv (env { names = M.insert name (ty, Extern) (names env) }) - typeCheckAll rest -typeCheckAll (FixityDeclaration _ name : rest) = do - typeCheckAll rest - env <- getEnv - guardWith ("Fixity declaration with no binding: " ++ name) $ M.member (Op name) $ names env diff --git a/src/PureScript/TypeChecker/Kinds.hs b/src/PureScript/TypeChecker/Kinds.hs deleted file mode 100644 --- a/src/PureScript/TypeChecker/Kinds.hs +++ /dev/null @@ -1,183 +0,0 @@ ------------------------------------------------------------------------------ --- --- Module : PureScript.TypeChecker.Kinds --- Copyright : (c) Phil Freeman 2013 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- --- | --- ------------------------------------------------------------------------------ - -{-# LANGUAGE DeriveDataTypeable #-} - -module PureScript.TypeChecker.Kinds ( - KindConstraint(..), - KindSolution(..), - kindsOf, - kindOf -) where - -import Data.List -import Data.Maybe (fromMaybe) -import Data.Function -import Data.Data - -import PureScript.Types -import PureScript.Kinds -import PureScript.Declarations -import PureScript.TypeChecker.Monad -import PureScript.CodeGen.Pretty.Kinds -import PureScript.CodeGen.Pretty.Types - -import Control.Monad.State -import Control.Monad.Error - -import Control.Applicative -import Control.Arrow (Kleisli(..), (***)) -import qualified Control.Category as C - -import qualified Data.Map as M - -data KindConstraintOrigin - = DataDeclOrigin - | TypeOrigin Type - | RowOrigin Row deriving (Show, Data, Typeable) - -prettyPrintKindConstraintOrigin :: KindConstraintOrigin -> String -prettyPrintKindConstraintOrigin (DataDeclOrigin) = "data declaration" -prettyPrintKindConstraintOrigin (TypeOrigin ty) = prettyPrintType ty -prettyPrintKindConstraintOrigin (RowOrigin row) = prettyPrintRow row - -data KindConstraint = KindConstraint Int Kind KindConstraintOrigin deriving (Show, Data, Typeable) - -newtype KindSolution = KindSolution { runKindSolution :: Int -> Kind } - -emptyKindSolution :: KindSolution -emptyKindSolution = KindSolution KUnknown - -kindOf :: PolyType -> Check Kind -kindOf (PolyType idents ty) = do - ns <- replicateM (length idents) fresh - (cs, n, m) <- kindConstraints (M.fromList (zip idents ns)) ty - solution <- solveKindConstraints cs emptyKindSolution - return $ starIfUnknown $ runKindSolution solution n - -kindsOf :: Maybe String -> [String] -> [Type] -> Check Kind -kindsOf name args ts = do - tyCon <- fresh - nargs <- replicateM (length args) fresh - (cs, ns, m) <- kindConstraintsAll (maybe id (`M.insert` tyCon) name $ M.fromList (zip args nargs)) ts - let extraConstraints = - KindConstraint tyCon (foldr (FunKind . KUnknown) Star nargs) DataDeclOrigin - : zipWith (\n arg -> KindConstraint n Star (TypeOrigin arg)) ns ts - solution <- solveKindConstraints (extraConstraints ++ cs) emptyKindSolution - return $ starIfUnknown $ runKindSolution solution tyCon - -starIfUnknown :: Kind -> Kind -starIfUnknown (KUnknown _) = Star -starIfUnknown (FunKind k1 k2) = FunKind (starIfUnknown k1) (starIfUnknown k2) -starIfUnknown k = k - -kindConstraintsAll :: M.Map String Int -> [Type] -> Check ([KindConstraint], [Int], M.Map String Int) -kindConstraintsAll m [] = return ([], [], m) -kindConstraintsAll m (t:ts) = do - (cs, n1, m') <- kindConstraints m t - (cs', ns, m'') <- kindConstraintsAll m' ts - return (KindConstraint n1 Star (TypeOrigin t) : cs ++ cs', n1:ns, m'') - -kindConstraints :: M.Map String Int -> Type -> Check ([KindConstraint], Int, M.Map String Int) -kindConstraints m a@(Array t) = do - me <- fresh - (cs, n1, m') <- kindConstraints m t - return (KindConstraint n1 Star (TypeOrigin t) : KindConstraint me Star (TypeOrigin a) : cs, me, m') -kindConstraints m o@(Object row) = do - me <- fresh - (cs, r, m') <- kindConstraintsForRow m row - return (KindConstraint me Star (TypeOrigin o) : KindConstraint r Row (RowOrigin row) : cs, me, m') -kindConstraints m f@(Function args ret) = do - me <- fresh - (cs, ns, m') <- kindConstraintsAll m args - (cs', retN, m'') <- kindConstraints m' ret - return (KindConstraint retN Star (TypeOrigin ret) : KindConstraint me Star (TypeOrigin f) : zipWith (\n arg -> KindConstraint n Star (TypeOrigin arg)) ns args ++ cs ++ cs', me, m'') -kindConstraints m (TypeVar v) = - case M.lookup v m of - Just u -> return ([], u, m) - Nothing -> throwError $ "Unbound type variable " ++ v -kindConstraints m c@(TypeConstructor v) = do - env <- getEnv - me <- fresh - case M.lookup v m of - Nothing -> case M.lookup v (types env) of - Nothing -> throwError $ "Unknown type constructor '" ++ v ++ "'" - Just (kind, _) -> return ([KindConstraint me kind (TypeOrigin c)], me, m) - Just u -> return ([KindConstraint me (KUnknown u) (TypeOrigin c)], me, m) -kindConstraints m a@(TypeApp t1 t2) = do - me <- fresh - (cs1, n1, m1) <- kindConstraints m t1 - (cs2, n2, m2) <- kindConstraints m1 t2 - return (KindConstraint n1 (FunKind (KUnknown n2) (KUnknown me)) (TypeOrigin a) : cs1 ++ cs2, me, m2) -kindConstraints m t = do - me <- fresh - return ([KindConstraint me Star (TypeOrigin t)], me, m) - -kindConstraintsForRow :: M.Map String Int -> Row -> Check ([KindConstraint], Int, M.Map String Int) -kindConstraintsForRow m r@(RowVar v) = do - me <- case M.lookup v m of - Just u -> return u - Nothing -> fresh - return ([KindConstraint me Row (RowOrigin r)], me, M.insert v me m) -kindConstraintsForRow m r@REmpty = do - me <- fresh - return ([KindConstraint me Row (RowOrigin r)], me, m) -kindConstraintsForRow m r@(RCons _ ty row) = do - me <- fresh - (cs1, n1, m1) <- kindConstraints m ty - (cs2, n2, m2) <- kindConstraintsForRow m1 row - return (KindConstraint me Row (RowOrigin r) : KindConstraint n1 Star (TypeOrigin ty) : KindConstraint n2 Row (RowOrigin r) : cs1 ++ cs2, me, m2) - -solveKindConstraints :: [KindConstraint] -> KindSolution -> Check KindSolution -solveKindConstraints [] s = return s -solveKindConstraints all@(KindConstraint n k t : cs) s = do - (cs', s') <- rethrow (\err -> "Error in " ++ prettyPrintKindConstraintOrigin t ++ ": " ++ err) $ do - guardWith "Occurs check failed" $ not $ kindOccursCheck False n k - let s' = KindSolution $ replaceUnknownKind n k . runKindSolution s - cs' <- fmap concat $ mapM (substituteKindConstraint n k) cs - return (cs', s') - solveKindConstraints cs' s' - -substituteKindConstraint :: Int -> Kind -> KindConstraint -> Check [KindConstraint] -substituteKindConstraint n k (KindConstraint m l t) - | n == m = unifyKinds t k l - | otherwise = return [KindConstraint m (replaceUnknownKind n k l) t] - -replaceUnknownKind :: Int -> Kind -> Kind -> Kind -replaceUnknownKind n k = f - where - f (KUnknown m) | m == n = k - f (FunKind k1 k2) = FunKind (f k2) (f k2) - f other = other - -unifyKinds :: KindConstraintOrigin -> Kind -> Kind -> Check [KindConstraint] -unifyKinds _ (KUnknown u1) (KUnknown u2) | u1 == u2 = return [] -unifyKinds t (KUnknown u) k = do - guardWith "Occurs check failed" $ not $ kindOccursCheck False u k - return [KindConstraint u k t] -unifyKinds t k (KUnknown u) = do - guardWith "Occurs check failed" $ not $ kindOccursCheck False u k - return [KindConstraint u k t] -unifyKinds _ Star Star = return [] -unifyKinds _ Row Row = return [] -unifyKinds t (FunKind k1 k2) (FunKind k3 k4) = do - cs1 <- unifyKinds t k1 k3 - cs2 <- unifyKinds t k2 k4 - return $ cs1 ++ cs2 -unifyKinds _ k1 k2 = throwError $ "Cannot unify " ++ prettyPrintKind k1 ++ " with " ++ prettyPrintKind k2 ++ "." - -kindOccursCheck :: Bool -> Int -> Kind -> Bool -kindOccursCheck b u (KUnknown u') | u == u' = b -kindOccursCheck _ u (FunKind k1 k2) = kindOccursCheck True u k1 || kindOccursCheck True u k2 -kindOccursCheck _ _ _ = False diff --git a/src/PureScript/TypeChecker/Monad.hs b/src/PureScript/TypeChecker/Monad.hs deleted file mode 100644 --- a/src/PureScript/TypeChecker/Monad.hs +++ /dev/null @@ -1,67 +0,0 @@ ------------------------------------------------------------------------------ --- --- Module : PureScript.TypeChecker.Monad --- Copyright : (c) Phil Freeman 2013 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- --- | --- ------------------------------------------------------------------------------ - -{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleInstances #-} - -module PureScript.TypeChecker.Monad where - -import PureScript.Types -import PureScript.Kinds -import PureScript.Names - -import Control.Applicative -import Control.Monad.State -import Control.Monad.Error - -import Control.Arrow ((***), first, second) - -import qualified Data.Map as M - -data NameKind = Value | Extern deriving Show - -data TypeDeclarationKind = Data | ExternData | TypeSynonym deriving Show - -data Environment = Environment - { names :: M.Map Ident (PolyType, NameKind) - , types :: M.Map String (Kind, TypeDeclarationKind) - , dataConstructors :: M.Map String PolyType - , typeSynonyms :: M.Map String ([String], Type) - } - -emptyEnvironment :: Environment -emptyEnvironment = Environment M.empty M.empty M.empty M.empty - -newtype Check a = Check { unCheck :: StateT (Environment, Int) (Either String) a } deriving (Functor, Monad, Applicative, MonadPlus, MonadState (Environment, Int), MonadError String) - -getEnv :: Check Environment -getEnv = fmap fst get - -putEnv :: Environment -> Check () -putEnv env = fmap (first (const env)) get >>= put - -fresh :: Check Int -fresh = do - (env, n) <- get - put (env, n + 1) - return n - -check :: Check a -> Either String (a, Environment) -check = fmap (second fst) . flip runStateT (emptyEnvironment, 0) . unCheck - -guardWith :: (MonadError e m) => e -> Bool -> m () -guardWith _ True = return () -guardWith e False = throwError e - -rethrow :: (MonadError e m) => (e -> e) -> m a -> m a -rethrow f = flip catchError $ \e -> throwError (f e) diff --git a/src/PureScript/TypeChecker/Synonyms.hs b/src/PureScript/TypeChecker/Synonyms.hs deleted file mode 100644 --- a/src/PureScript/TypeChecker/Synonyms.hs +++ /dev/null @@ -1,56 +0,0 @@ ------------------------------------------------------------------------------ --- --- Module : PureScript.TypeChecker.Synonyms --- Copyright : (c) Phil Freeman 2013 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- --- | --- ------------------------------------------------------------------------------ - -{-# LANGUAGE Rank2Types #-} - -module PureScript.TypeChecker.Synonyms ( - saturateTypeSynonym, - saturateAllTypeSynonyms -) where - -import PureScript.Types -import PureScript.Declarations - -import Data.Maybe (fromMaybe) -import Data.Data -import Data.Generics -import Control.Arrow -import Control.Monad.Writer -import Control.Monad.Error -import qualified Data.Map as M - -buildTypeSubstitution :: String -> Int -> Type -> Either String (Maybe Type) -buildTypeSubstitution name n = go n [] - where - go :: Int -> [Type] -> Type -> Either String (Maybe Type) - go 0 args (TypeConstructor ctor) | name == ctor = return (Just $ SaturatedTypeSynonym ctor args) - go n _ (TypeConstructor ctor) | n > 0 && name == ctor = throwError $ "Partially applied type synonym " ++ name - go n args (TypeApp f arg) = go (n - 1) (arg:args) f - go _ _ _ = return Nothing - -everywhereM' :: (Monad m, Data d) => (forall d. (Data d) => d -> m d) -> d -> m d -everywhereM' f x = do - y <- f x - gmapM (everywhereM' f) y - -saturateTypeSynonym :: (Data d) => String -> Int -> d -> Either String d -saturateTypeSynonym name n = everywhereM' (mkM replace) - where - replace t = fmap (fromMaybe t) $ buildTypeSubstitution name n t - -saturateAllTypeSynonyms :: (Data d) => [(String, Int)] -> d -> Either String d -saturateAllTypeSynonyms syns d = foldM (\d (name, n) -> saturateTypeSynonym name n d) d syns - - - diff --git a/src/PureScript/TypeChecker/Types.hs b/src/PureScript/TypeChecker/Types.hs deleted file mode 100644 --- a/src/PureScript/TypeChecker/Types.hs +++ /dev/null @@ -1,626 +0,0 @@ ------------------------------------------------------------------------------ --- --- Module : PureScript.TypeChecker.Types --- Copyright : (c) Phil Freeman 2013 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- --- | --- ------------------------------------------------------------------------------ - -{-# LANGUAGE DeriveDataTypeable #-} - -module PureScript.TypeChecker.Types ( - TypeConstraint(..), - TypeSolution(..), - typeOf -) where - -import Debug.Trace - -import Data.List -import Data.Function -import qualified Data.Data as D -import Data.Generics (everywhere, everywhereM, everything, mkT, mkM, mkQ, extM, extQ) - -import PureScript.Values -import PureScript.Types -import PureScript.Kinds -import PureScript.Names -import PureScript.TypeChecker.Monad -import PureScript.TypeChecker.Kinds -import PureScript.TypeChecker.Synonyms -import PureScript.CodeGen.Pretty.Types -import PureScript.CodeGen.Pretty.Kinds -import PureScript.CodeGen.Pretty.Values - -import Control.Monad.State -import Control.Monad.Error - -import Control.Applicative -import Control.Arrow (Kleisli(..), (***), (&&&), first) -import qualified Control.Category as C - -import qualified Data.Map as M - -data TypeConstraintOrigin - = ValueOrigin Value - | BinderOrigin Binder - | AssignmentTargetOrigin Ident deriving (Show, D.Data, D.Typeable) - -prettyPrintOrigin :: TypeConstraintOrigin -> String -prettyPrintOrigin (ValueOrigin val) = prettyPrintValue val -prettyPrintOrigin (BinderOrigin binder) = prettyPrintBinder binder -prettyPrintOrigin (AssignmentTargetOrigin ident) = show ident - -data TypeConstraint - = TypeConstraint Int Type TypeConstraintOrigin - | RowConstraint Int Row TypeConstraintOrigin deriving (Show, D.Data, D.Typeable) - -newtype TypeSolution = TypeSolution { runTypeSolution :: (Int -> Type, Int -> Row) } - -emptyTypeSolution :: TypeSolution -emptyTypeSolution = TypeSolution (TUnknown, RUnknown) - -isFunction :: Value -> Bool -isFunction (Abs _ _) = True -isFunction (TypedValue untyped _) = isFunction untyped -isFunction _ = False - -allConstraints :: Ident -> Value -> Check ([TypeConstraint], Int) -allConstraints name val | isFunction val = do - me <- fresh - (cs, n) <- typeConstraints (M.singleton name me) val - return (TypeConstraint me (TUnknown n) (ValueOrigin val): cs, n) -allConstraints _ val = typeConstraints M.empty val - -typeOf :: Ident -> Value -> Check PolyType -typeOf name val = do - (cs, n) <- allConstraints name val - desugared <- replaceAllTypeSynonyms cs - solution <- solveTypeConstraints desugared emptyTypeSolution - let ty = fst (runTypeSolution solution) n - allUnknownsBecameQuantified desugared solution ty - return $ varIfUnknown $ desaturateAllTypeSynonyms $ setifyAll ty - -allUnknownsBecameQuantified :: [TypeConstraint] -> TypeSolution -> Type -> Check () -allUnknownsBecameQuantified cs solution ty = do - let - typesMentioned = findUnknownTypes ty - unknownTypes = nub $ flip concatMap cs $ \c -> case c of - TypeConstraint u t _ -> u : findUnknownTypes t - RowConstraint _ r _ -> findUnknownTypes r - unsolvedTypes = filter (\n -> TUnknown n == fst (runTypeSolution solution) n) unknownTypes - guardWith "Unsolved type variable" $ null $ unsolvedTypes \\ typesMentioned - let - rowsMentioned = findUnknownRows ty - unknownRows = nub $ flip concatMap cs $ \c -> case c of - TypeConstraint _ t _ -> findUnknownRows t - RowConstraint u r _ -> u : findUnknownRows r - unsolvedRows = filter (\n -> RUnknown n == snd (runTypeSolution solution) n) unknownRows - guardWith "Unsolved row variable" $ null $ unsolvedRows \\ rowsMentioned - -setify :: Row -> Row -setify = rowFromList . first (M.toList . M.fromList) . rowToList - -setifyAll :: (D.Data d) => d -> d -setifyAll = everywhere (mkT setify) - -findUnknownTypes :: (D.Data d) => d -> [Int] -findUnknownTypes = everything (++) (mkQ [] f) - where - f :: Type -> [Int] - f (TUnknown n) = [n] - f _ = [] - -findTypeVars :: (D.Data d) => d -> [String] -findTypeVars = everything (++) (mkQ [] f) - where - f :: Type -> [String] - f (TypeVar v) = [v] - f _ = [] - -findUnknownRows :: (D.Data d) => d -> [Int] -findUnknownRows = everything (++) (mkQ [] f) - where - f :: Row -> [Int] - f (RUnknown n) = [n] - f _ = [] - -varIfUnknown :: Type -> PolyType -varIfUnknown ty = - let - (ty', m) = flip runState M.empty $ everywhereM (flip extM g $ mkM f) ty - in - PolyType (sort $ nub $ M.elems m ++ findTypeVars ty) ty' - where - f :: Type -> State (M.Map Int String) Type - f (TUnknown n) = do - m <- get - case M.lookup n m of - Nothing -> do - let name = 't' : show (M.size m) - put $ M.insert n name m - return $ TypeVar name - Just name -> return $ TypeVar name - f t = return t - g :: Row -> State (M.Map Int String) Row - g (RUnknown n) = do - m <- get - case M.lookup n m of - Nothing -> do - let name = 'r' : show (M.size m) - put $ M.insert n name m - return $ RowVar name - Just name -> return $ RowVar name - g r = return r - -replaceTypeVars :: M.Map String Type -> Type -> Type -replaceTypeVars m = everywhere (mkT replace) - where - replace (TypeVar v) = case M.lookup v m of - Just ty -> ty - _ -> TypeVar v - replace t = t - -replaceVarsWithUnknowns :: [String] -> Type -> Check Type -replaceVarsWithUnknowns idents = flip evalStateT M.empty . everywhereM (flip extM f $ mkM g) - where - f :: Type -> StateT (M.Map String Int) Check Type - f (TypeVar var) | var `elem` idents = do - m <- get - n <- lift fresh - case M.lookup var m of - Nothing -> do - put (M.insert var n m) - return $ TUnknown n - Just u -> return $ TUnknown u - f t = return t - g :: Row -> StateT (M.Map String Int) Check Row - g (RowVar var) | var `elem` idents = do - m <- get - n <- lift fresh - case M.lookup var m of - Nothing -> do - put (M.insert var n m) - return $ RUnknown n - Just u -> return $ RUnknown u - g r = return r - -replaceAllTypeSynonyms :: (D.Data d) => d -> Check d -replaceAllTypeSynonyms d = do - env <- getEnv - let syns = map (\(name, (args, _)) -> (name, length args)) . M.toList $ typeSynonyms env - either throwError return $ saturateAllTypeSynonyms syns d - -desaturateAllTypeSynonyms :: (D.Data d) => d -> d -desaturateAllTypeSynonyms = everywhere (mkT replace) - where - replace (SaturatedTypeSynonym name args) = foldl TypeApp (TypeConstructor name) args - replace t = t - -replaceType :: (D.Data d) => Int -> Type -> d -> d -replaceType n t = everywhere (mkT go) - where - go (TUnknown m) | m == n = t - go t = t - -replaceRow :: (D.Data d) => Int -> Row -> d -> d -replaceRow n r = everywhere (mkT go) - where - go (RUnknown m) | m == n = r - go r = r - -typeOccursCheck :: Int -> Type -> Check () -typeOccursCheck u (TUnknown _) = return () -typeOccursCheck u t = when (occursCheck u t) $ throwError $ "Occurs check failed: " ++ show u ++ " = " ++ prettyPrintType t - -rowOccursCheck :: Int -> Row -> Check () -rowOccursCheck u (RUnknown _) = return () -rowOccursCheck u r = when (occursCheck u r) $ throwError $ "Occurs check failed: " ++ show u ++ " = " ++ prettyPrintRow r - -occursCheck :: (D.Data d) => Int -> d -> Bool -occursCheck u = everything (||) $ flip extQ g $ mkQ False f - where - f (TUnknown u') | u' == u = True - f _ = False - g (RUnknown u') | u' == u = True - g _ = False - -typesToRow :: [(String, Type)] -> Row -typesToRow [] = REmpty -typesToRow ((name, ty):tys) = RCons name ty (typesToRow tys) - -rowToList :: Row -> ([(String, Type)], Row) -rowToList (RCons name ty row) = let (tys, rest) = rowToList row - in ((name, ty):tys, rest) -rowToList r = ([], r) - -rowFromList :: ([(String, Type)], Row) -> Row -rowFromList ([], r) = r -rowFromList ((name, t):ts, r) = RCons name t (rowFromList (ts, r)) - -ensureNoDuplicateProperties :: [(String, Value)] -> Check () -ensureNoDuplicateProperties ps = guardWith "Duplicate property names" $ length (nub . map fst $ ps) == length ps - -typeConstraints :: M.Map Ident Int -> Value -> Check ([TypeConstraint], Int) -typeConstraints _ v@(NumericLiteral _) = do - me <- fresh - return ([TypeConstraint me Number (ValueOrigin v)], me) -typeConstraints _ v@(StringLiteral _) = do - me <- fresh - return ([TypeConstraint me String (ValueOrigin v)], me) -typeConstraints _ v@(BooleanLiteral _) = do - me <- fresh - return ([TypeConstraint me Boolean (ValueOrigin v)], me) -typeConstraints m v@(ArrayLiteral vals) = do - all <- mapM (typeConstraints m) vals - let (cs, ns) = (concatMap fst &&& map snd) all - me <- fresh - return (cs ++ zipWith (\n el -> TypeConstraint me (Array $ TUnknown n) (ValueOrigin el)) ns vals, me) -typeConstraints m u@(Unary op val) = do - (cs, n1) <- typeConstraints m val - me <- fresh - return (cs ++ unaryOperatorConstraints u op n1 me, me) -typeConstraints m b@(Binary op left right) = do - (cs1, n1) <- typeConstraints m left - (cs2, n2) <- typeConstraints m right - me <- fresh - return (cs1 ++ cs2 ++ binaryOperatorConstraints b op n1 n2 me, me) -typeConstraints m v@(ObjectLiteral ps) = do - ensureNoDuplicateProperties ps - all <- mapM (typeConstraints m . snd) ps - let (cs, ns) = (concatMap fst &&& map snd) all - me <- fresh - let tys = zipWith (\(name, _) u -> (name, TUnknown u)) ps ns - return (TypeConstraint me (Object (typesToRow tys)) (ValueOrigin v) : cs, me) -typeConstraints m v@(ObjectUpdate o ps) = do - ensureNoDuplicateProperties ps - (cs1, n1) <- typeConstraints m o - all <- mapM (typeConstraints m . snd) ps - let (cs2, ns) = (concatMap fst &&& map snd) all - row <- fresh - let tys = zipWith (\(name, _) u -> (name, TUnknown u)) ps ns - return (TypeConstraint n1 (Object (rowFromList (tys, RUnknown row))) (ValueOrigin v) : cs1 ++ cs2, n1) -typeConstraints m v@(Indexer index val) = do - (cs1, n1) <- typeConstraints m index - (cs2, n2) <- typeConstraints m val - me <- fresh - return (TypeConstraint n1 Number (ValueOrigin index) : TypeConstraint n2 (Array (TUnknown me)) (ValueOrigin v) : cs1 ++ cs2, me) -typeConstraints m v@(Accessor prop val) = do - (cs, n1) <- typeConstraints m val - me <- fresh - rest <- fresh - return (TypeConstraint n1 (Object (RCons prop (TUnknown me) (RUnknown rest))) (ValueOrigin v) : cs, me) -typeConstraints m v@(Abs args ret) = do - ns <- replicateM (length args) fresh - let m' = m `M.union` M.fromList (zip args ns) - (cs, n') <- typeConstraints m' ret - me <- fresh - return (TypeConstraint me (Function (map TUnknown ns) (TUnknown n')) (ValueOrigin v) : cs, me) -typeConstraints m v@(App f xs) = do - (cs1, n1) <- typeConstraints m f - all <- mapM (typeConstraints m) xs - let (cs2, ns) = (concatMap fst &&& map snd) all - me <- fresh - return (TypeConstraint n1 (Function (map TUnknown ns) (TUnknown me)) (ValueOrigin v) : cs1 ++ cs2, me) -typeConstraints m v@(Var var) = - case M.lookup var m of - Nothing -> do - env <- getEnv - case M.lookup var (names env) of - Nothing -> throwError $ show var ++ " is undefined" - Just (PolyType idents ty, _) -> do - me <- fresh - replaced <- replaceVarsWithUnknowns idents ty - return ([TypeConstraint me replaced (ValueOrigin v)], me) - Just u -> do - me <- fresh - return ([TypeConstraint u (TUnknown me) (ValueOrigin v)], me) -typeConstraints m (Block ss) = do - ret <- fresh - (cs, allCodePathsReturn, _) <- typeConstraintsForBlock m M.empty ret ss - guardWith "Block is missing a return statement" allCodePathsReturn - return (cs, ret) -typeConstraints m v@(Constructor c) = do - env <- getEnv - case M.lookup c (dataConstructors env) of - Nothing -> throwError $ "Constructor " ++ c ++ " is undefined" - Just (PolyType idents ty) -> do - me <- fresh - replaced <- replaceVarsWithUnknowns idents ty - return ([TypeConstraint me replaced (ValueOrigin v)], me) -typeConstraints m (Case val binders) = do - (cs1, n1) <- typeConstraints m val - ret <- fresh - cs2 <- typeConstraintsForBinders m n1 ret binders - return (cs1 ++ cs2, ret) -typeConstraints m v@(IfThenElse cond th el) = do - (cs1, n1) <- typeConstraints m cond - (cs2, n2) <- typeConstraints m th - (cs3, n3) <- typeConstraints m el - return (TypeConstraint n1 Boolean (ValueOrigin cond) : TypeConstraint n2 (TUnknown n3) (ValueOrigin v) : cs1 ++ cs2 ++ cs3, n2) -typeConstraints m v@(TypedValue val poly@(PolyType idents ty)) = do - kind <- kindOf poly - guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star - (cs, n1) <- typeConstraints m val - return (TypeConstraint n1 ty (ValueOrigin v) : cs, n1) - -unaryOperatorConstraints :: Value -> UnaryOperator -> Int -> Int -> [TypeConstraint] -unaryOperatorConstraints v Negate val result = [TypeConstraint val Number (ValueOrigin v), TypeConstraint result Number (ValueOrigin v)] -unaryOperatorConstraints v Not val result = [TypeConstraint val Boolean (ValueOrigin v), TypeConstraint result Boolean (ValueOrigin v)] -unaryOperatorConstraints v BitwiseNot val result = [TypeConstraint val Number (ValueOrigin v), TypeConstraint result Number (ValueOrigin v)] - -binaryOperatorConstraints :: Value -> BinaryOperator -> Int -> Int -> Int -> [TypeConstraint] -binaryOperatorConstraints v Add = symBinOpConstraints v Number -binaryOperatorConstraints v Subtract = symBinOpConstraints v Number -binaryOperatorConstraints v Multiply = symBinOpConstraints v Number -binaryOperatorConstraints v Divide = symBinOpConstraints v Number -binaryOperatorConstraints v Modulus = symBinOpConstraints v Number -binaryOperatorConstraints v LessThan = asymBinOpConstraints v Number Boolean -binaryOperatorConstraints v LessThanOrEqualTo = asymBinOpConstraints v Number Boolean -binaryOperatorConstraints v GreaterThan = asymBinOpConstraints v Number Boolean -binaryOperatorConstraints v GreaterThanOrEqualTo = asymBinOpConstraints v Number Boolean -binaryOperatorConstraints v BitwiseAnd = symBinOpConstraints v Number -binaryOperatorConstraints v BitwiseOr = symBinOpConstraints v Number -binaryOperatorConstraints v BitwiseXor = symBinOpConstraints v Number -binaryOperatorConstraints v ShiftLeft = symBinOpConstraints v Number -binaryOperatorConstraints v ShiftRight = symBinOpConstraints v Number -binaryOperatorConstraints v ZeroFillShiftRight = symBinOpConstraints v Number -binaryOperatorConstraints v EqualTo = equalityBinOpConstraints v -binaryOperatorConstraints v NotEqualTo = equalityBinOpConstraints v -binaryOperatorConstraints v And = symBinOpConstraints v Boolean -binaryOperatorConstraints v Or = symBinOpConstraints v Boolean -binaryOperatorConstraints v Concat = symBinOpConstraints v String - -equalityBinOpConstraints :: Value -> Int -> Int -> Int -> [TypeConstraint] -equalityBinOpConstraints v left right result = [TypeConstraint left (TUnknown right) (ValueOrigin v), TypeConstraint result Boolean (ValueOrigin v)] - -symBinOpConstraints :: Value -> Type -> Int -> Int -> Int -> [TypeConstraint] -symBinOpConstraints v ty = asymBinOpConstraints v ty ty - -asymBinOpConstraints :: Value -> Type -> Type -> Int -> Int -> Int -> [TypeConstraint] -asymBinOpConstraints v ty res left right result = [TypeConstraint left ty (ValueOrigin v), TypeConstraint right ty (ValueOrigin v), TypeConstraint result res (ValueOrigin v)] - -typeConstraintsForBinder :: Int -> Binder -> Check ([TypeConstraint], M.Map Ident Int) -typeConstraintsForBinder _ NullBinder = return ([], M.empty) -typeConstraintsForBinder val b@(StringBinder _) = constantBinder b val String -typeConstraintsForBinder val b@(NumberBinder _) = constantBinder b val Number -typeConstraintsForBinder val b@(BooleanBinder _) = constantBinder b val Boolean -typeConstraintsForBinder val b@(VarBinder name) = do - me <- fresh - return ([TypeConstraint me (TUnknown val) (BinderOrigin b)], M.singleton name me) -typeConstraintsForBinder val b@(NullaryBinder ctor) = do - env <- getEnv - case M.lookup ctor (dataConstructors env) of - Just (PolyType args ret) -> do - ret' <- replaceVarsWithUnknowns args ret - return ([TypeConstraint val ret' (BinderOrigin b)], M.empty) - _ -> throwError $ "Constructor " ++ ctor ++ " is not defined" -typeConstraintsForBinder val b@(UnaryBinder ctor binder) = do - env <- getEnv - case M.lookup ctor (dataConstructors env) of - Just (PolyType idents f@(Function [_] _)) -> do - obj <- fresh - (Function [ty] ret) <- replaceVarsWithUnknowns idents f - (cs, m1) <- typeConstraintsForBinder obj binder - return (TypeConstraint val ret (BinderOrigin b) : TypeConstraint obj ty (BinderOrigin b) : cs, m1) - Just _ -> throwError $ ctor ++ " is not a unary constructor" - _ -> throwError $ "Constructor " ++ ctor ++ " is not defined" -typeConstraintsForBinder val b@(ObjectBinder props) = do - row <- fresh - rest <- fresh - (cs, m1) <- typeConstraintsForProperties row (RUnknown rest) props - return (TypeConstraint val (Object (RUnknown row)) (BinderOrigin b) : cs, m1) - where - typeConstraintsForProperties :: Int -> Row -> [(String, Binder)] -> Check ([TypeConstraint], M.Map Ident Int) - typeConstraintsForProperties nrow row [] = return ([RowConstraint nrow row (BinderOrigin b)], M.empty) - typeConstraintsForProperties nrow row ((name, binder):binders) = do - propTy <- fresh - (cs1, m1) <- typeConstraintsForBinder propTy binder - (cs2, m2) <- typeConstraintsForProperties nrow (RCons name (TUnknown propTy) row) binders - return (cs1 ++ cs2, m1 `M.union` m2) -typeConstraintsForBinder val b@(ArrayBinder binders rest) = do - el <- fresh - all <- mapM (typeConstraintsForBinder el) binders - let (cs1, m1) = (concatMap fst &&& M.unions . map snd) all - let arrayConstraint = TypeConstraint val (Array (TUnknown el)) (BinderOrigin b) - case rest of - Nothing -> return (arrayConstraint : cs1, m1) - Just binder -> do - (cs2, m2) <- typeConstraintsForBinder val binder - return (arrayConstraint : cs1 ++ cs2, m1 `M.union` m2) -typeConstraintsForBinder val b@(NamedBinder name binder) = do - me <- fresh - (cs, m) <- typeConstraintsForBinder val binder - return (TypeConstraint me (TUnknown val) (BinderOrigin b) : cs, M.insert name me m) -typeConstraintsForBinder val b@(GuardedBinder cond binder) = do - (cs1, m) <- typeConstraintsForBinder val binder - (cs2, n) <- typeConstraints m cond - return (TypeConstraint n Boolean (ValueOrigin cond) : cs1 ++ cs2, m) - -constantBinder :: Binder -> Int -> Type -> Check ([TypeConstraint], M.Map Ident Int) -constantBinder b val ty = return ([TypeConstraint val ty (BinderOrigin b)], M.empty) - -typeConstraintsForBinders :: M.Map Ident Int -> Int -> Int -> [(Binder, Value)] -> Check [TypeConstraint] -typeConstraintsForBinders _ _ _ [] = return [] -typeConstraintsForBinders m nval ret ((binder, val):bs) = do - (cs1, m1) <- typeConstraintsForBinder nval binder - (cs2, n2) <- typeConstraints (m `M.union` m1) val - cs3 <- typeConstraintsForBinders m nval ret bs - return (TypeConstraint n2 (TUnknown ret) (BinderOrigin binder) : cs1 ++ cs2 ++ cs3) - -assignVariable :: Ident -> M.Map Ident Int -> Check () -assignVariable name m = - case M.lookup name m of - Nothing -> return () - Just _ -> throwError $ "Variable with name " ++ show name ++ " already exists." - -typeConstraintsForStatement :: M.Map Ident Int -> M.Map Ident Int -> Int -> Statement -> Check ([TypeConstraint], Bool, M.Map Ident Int) -typeConstraintsForStatement m mass ret (VariableIntroduction name val) = do - assignVariable name (m `M.union` mass) - (cs1, n1) <- typeConstraints m val - return (cs1, False, M.insert name n1 mass) -typeConstraintsForStatement m mass ret (Assignment ident val) = do - (cs1, n1) <- typeConstraints m val - case M.lookup ident mass of - Nothing -> throwError $ "No local variable with name " ++ show ident - Just ty -> - return (TypeConstraint n1 (TUnknown ty) (AssignmentTargetOrigin ident) : cs1, False, mass) -typeConstraintsForStatement m mass ret (While val inner) = do - (cs1, n1) <- typeConstraints m val - (cs2, allCodePathsReturn, _) <- typeConstraintsForBlock m mass ret inner - return (TypeConstraint n1 Boolean (ValueOrigin val) : cs1 ++ cs2, allCodePathsReturn, mass) -typeConstraintsForStatement m mass ret (If ifst) = do - (cs, allCodePathsReturn) <- typeConstraintsForIfStatement m mass ret ifst - return (cs, allCodePathsReturn, mass) -typeConstraintsForStatement m mass ret (For ident start end inner) = do - assignVariable ident (m `M.union` mass) - (cs1, n1) <- typeConstraints (m `M.union` mass) start - (cs2, n2) <- typeConstraints (m `M.union` mass) end - let mass1 = M.insert ident n1 mass - (cs3, allCodePathsReturn, _) <- typeConstraintsForBlock (m `M.union` mass1) mass1 ret inner - return (TypeConstraint n1 Number (ValueOrigin start) : TypeConstraint n2 Number (ValueOrigin end) : cs1 ++ cs2 ++ cs3, allCodePathsReturn, mass) -typeConstraintsForStatement m mass ret (ForEach ident vals inner) = do - assignVariable ident (m `M.union` mass) - val <- fresh - (cs1, n1) <- typeConstraints (m `M.union` mass) vals - let mass1 = M.insert ident val mass - (cs2, allCodePathsReturn, _) <- typeConstraintsForBlock (m `M.union` mass1) mass1 ret inner - guardWith "Cannot return from within a foreach block" $ not allCodePathsReturn - return (TypeConstraint n1 (Array (TUnknown val)) (ValueOrigin vals) : cs1 ++ cs2, False, mass) -typeConstraintsForStatement m mass ret (Return val) = do - (cs1, n1) <- typeConstraints (m `M.union` mass) val - return (TypeConstraint n1 (TUnknown ret) (ValueOrigin val) : cs1, True, mass) - -typeConstraintsForIfStatement :: M.Map Ident Int -> M.Map Ident Int -> Int -> IfStatement -> Check ([TypeConstraint], Bool) -typeConstraintsForIfStatement m mass ret (IfStatement val thens Nothing) = do - (cs1, n1) <- typeConstraints m val - (cs2, _, _) <- typeConstraintsForBlock m mass ret thens - return (TypeConstraint n1 Boolean (ValueOrigin val) : cs1 ++ cs2, False) -typeConstraintsForIfStatement m mass ret (IfStatement val thens (Just elses)) = do - (cs1, n1) <- typeConstraints m val - (cs2, allCodePathsReturn1, _) <- typeConstraintsForBlock m mass ret thens - (cs3, allCodePathsReturn2) <- typeConstraintsForElseStatement m mass ret elses - return (TypeConstraint n1 Boolean (ValueOrigin val) : cs1 ++ cs2 ++ cs3, allCodePathsReturn1 && allCodePathsReturn2) - -typeConstraintsForElseStatement :: M.Map Ident Int -> M.Map Ident Int -> Int -> ElseStatement -> Check ([TypeConstraint], Bool) -typeConstraintsForElseStatement m mass ret (Else elses) = do - (cs, allCodePathsReturn, _) <- typeConstraintsForBlock m mass ret elses - return (cs, allCodePathsReturn) -typeConstraintsForElseStatement m mass ret (ElseIf ifst) = do - (cs, allCodePathsReturn) <- typeConstraintsForIfStatement m mass ret ifst - return (cs, allCodePathsReturn) - -typeConstraintsForBlock :: M.Map Ident Int -> M.Map Ident Int -> Int -> [Statement] -> Check ([TypeConstraint], Bool, M.Map Ident Int) -typeConstraintsForBlock _ mass _ [] = return ([], False, mass) -typeConstraintsForBlock m mass ret (s:ss) = do - (cs1, b1, mass1) <- typeConstraintsForStatement (m `M.union` mass) mass ret s - case (b1, ss) of - (True, []) -> return (cs1, True, mass1) - (True, _) -> throwError "Unreachable code" - (False, ss) -> do - (cs2, b2, mass2) <- typeConstraintsForBlock m mass1 ret ss - return (cs1 ++ cs2, b2, mass2) - -solveTypeConstraints :: [TypeConstraint] -> TypeSolution -> Check TypeSolution -solveTypeConstraints [] s = return s -solveTypeConstraints all@(TypeConstraint n t o:cs) s = do - (cs', s') <- rethrow (\err -> "Error in " ++ prettyPrintOrigin o ++ ": " ++ err) $ do - typeOccursCheck n t - let s' = let (f, g) = runTypeSolution s - in TypeSolution (replaceType n t . f, replaceType n t . g) - cs' <- fmap concat $ mapM (substituteTypeInConstraint n t) cs - return (cs', s') - solveTypeConstraints cs' s' -solveTypeConstraints (RowConstraint n r o:cs) s = do - (cs', s') <- rethrow (\err -> "Error in " ++ prettyPrintOrigin o ++ ": " ++ err) $ do - rowOccursCheck n r - let s' = let (f, g) = runTypeSolution s - in TypeSolution (replaceRow n r . f, replaceRow n r . g) - cs' <- fmap concat $ mapM (substituteRowInConstraint n r) cs - return (cs', s') - solveTypeConstraints cs' s' - -substituteTypeInConstraint :: Int -> Type -> TypeConstraint -> Check [TypeConstraint] -substituteTypeInConstraint n s (TypeConstraint m t v) - | n == m = unifyTypes v s t - | otherwise = return [TypeConstraint m (replaceType n s t) v] -substituteTypeInConstraint n s (RowConstraint m r v) - = return [RowConstraint m (replaceType n s r) v] - -substituteRowInConstraint :: Int -> Row -> TypeConstraint -> Check [TypeConstraint] -substituteRowInConstraint n r (TypeConstraint m t v) - = return [TypeConstraint m (replaceRow n r t) v] -substituteRowInConstraint n r (RowConstraint m r1 v) - | m == n = unifyRows v r r1 - | otherwise = return [RowConstraint m (replaceRow n r r1) v] - -unifyTypes :: TypeConstraintOrigin -> Type -> Type -> Check [TypeConstraint] -unifyTypes _ (TUnknown u1) (TUnknown u2) | u1 == u2 = return [] -unifyTypes o (TUnknown u) t = do - typeOccursCheck u t - return [TypeConstraint u t o] -unifyTypes o t (TUnknown u) = do - typeOccursCheck u t - return [TypeConstraint u t o] -unifyTypes o (SaturatedTypeSynonym name1 args1) (SaturatedTypeSynonym name2 args2) | name1 == name2 = - fmap concat $ zipWithM (unifyTypes o) args1 args2 -unifyTypes o (SaturatedTypeSynonym name args) ty = do - env <- getEnv - case M.lookup name (typeSynonyms env) of - Just (synArgs, body) -> do - let m = M.fromList $ zip synArgs args - let replaced = replaceTypeVars m body - unifyTypes o replaced ty - Nothing -> error "Type synonym was not defined" -unifyTypes o ty s@(SaturatedTypeSynonym _ _) = unifyTypes o s ty -unifyTypes _ Number Number = return [] -unifyTypes _ String String = return [] -unifyTypes _ Boolean Boolean = return [] -unifyTypes o (Array s) (Array t) = unifyTypes o s t -unifyTypes o (Object row1) (Object row2) = unifyRows o row1 row2 -unifyTypes o (Function args1 ret1) (Function args2 ret2) = do - guardWith "Function applied to incorrect number of args" $ length args1 == length args2 - cs1 <- fmap concat $ zipWithM (unifyTypes o) args1 args2 - cs2 <- unifyTypes o ret1 ret2 - return $ cs1 ++ cs2 -unifyTypes _ (TypeVar v1) (TypeVar v2) | v1 == v2 = return [] -unifyTypes _ (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = return [] -unifyTypes o (TypeApp t1 t2) (TypeApp t3 t4) = do - cs1 <- unifyTypes o t1 t3 - cs2 <- unifyTypes o t2 t4 - return $ cs1 ++ cs2 -unifyTypes _ t1 t2 = throwError $ "Cannot unify " ++ prettyPrintType t1 ++ " with " ++ prettyPrintType t2 ++ "." - -unifyRows :: TypeConstraintOrigin -> Row -> Row -> Check [TypeConstraint] -unifyRows o r1 r2 = - let - (s1, r1') = rowToList r1 - (s2, r2') = rowToList r2 - int = [ (t1, t2) | (name, t1) <- s1, (name', t2) <- s2, name == name' ] - sd1 = [ (name, t1) | (name, t1) <- s1, name `notElem` map fst s2 ] - sd2 = [ (name, t2) | (name, t2) <- s2, name `notElem` map fst s1 ] - in do - cs1 <- fmap concat $ mapM (uncurry $ unifyTypes o) int - cs2 <- unifyRows' o sd1 r1' sd2 r2' - return $ cs1 ++ cs2 - where - unifyRows' :: TypeConstraintOrigin -> [(String, Type)] -> Row -> [(String, Type)] -> Row -> Check [TypeConstraint] - unifyRows' o [] (RUnknown u) sd r = do - rowOccursCheck u r - return [RowConstraint u (rowFromList (sd, r)) o] - unifyRows' o sd r [] (RUnknown u) = do - rowOccursCheck u r - return [RowConstraint u (rowFromList (sd, r)) o] - unifyRows' o ns@((name, ty):row) r others (RUnknown u) | not (occursCheck u (ty, row)) = do - u' <- fresh - cs <- unifyRows' o row r others (RUnknown u') - return (RowConstraint u (RCons name ty (RUnknown u')) o : cs) - unifyRows' _ [] REmpty [] REmpty = return [] - unifyRows' _ [] (RowVar v1) [] (RowVar v2) | v1 == v2 = return [] - unifyRows' _ sd1 r1 sd2 r2 = throwError $ "Cannot unify " ++ prettyPrintRow (rowFromList (sd1, r1)) ++ " with " ++ prettyPrintRow (rowFromList (sd2, r2)) ++ "." diff --git a/src/PureScript/Types.hs b/src/PureScript/Types.hs deleted file mode 100644 --- a/src/PureScript/Types.hs +++ /dev/null @@ -1,43 +0,0 @@ ------------------------------------------------------------------------------ --- --- Module : Purescript.Types --- Copyright : (c) Phil Freeman 2013 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- --- | --- ------------------------------------------------------------------------------ - -{-# LANGUAGE DeriveDataTypeable #-} - -module PureScript.Types where - -import Data.Data - -data Type - = TUnknown Int - | Number - | String - | Boolean - | Array Type - | Object Row - | Function [Type] Type - | TypeVar String - | TypeConstructor String - | TypeApp Type Type - | SaturatedTypeSynonym String [Type] deriving (Show, Eq, Data, Typeable) - -data PolyType = PolyType [String] Type deriving (Show, Eq, Data, Typeable) - -data Row - = RUnknown Int - | RowVar String - | REmpty - | RCons String Type Row deriving (Show, Eq, Data, Typeable) - -monoType :: Type -> PolyType -monoType = PolyType [] diff --git a/src/PureScript/Values.hs b/src/PureScript/Values.hs deleted file mode 100644 --- a/src/PureScript/Values.hs +++ /dev/null @@ -1,97 +0,0 @@ ------------------------------------------------------------------------------ --- --- Module : PureScript.Values --- Copyright : (c) Phil Freeman 2013 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- --- | --- ------------------------------------------------------------------------------ - -{-# LANGUAGE DeriveDataTypeable #-} - -module PureScript.Values where - -import PureScript.Types -import PureScript.Names - -import Data.Data - -data UnaryOperator - = Negate - | Not - | BitwiseNot deriving (Show, Eq, Data, Typeable) - -data BinaryOperator - = Add - | Subtract - | Multiply - | Divide - | Modulus - | EqualTo - | NotEqualTo - | LessThan - | LessThanOrEqualTo - | GreaterThan - | GreaterThanOrEqualTo - | And - | Or - | BitwiseAnd - | BitwiseOr - | BitwiseXor - | ShiftLeft - | ShiftRight - | ZeroFillShiftRight - | Concat deriving (Show, Eq, Data, Typeable) - -data Value - = NumericLiteral (Either Integer Double) - | StringLiteral String - | BooleanLiteral Bool - | Unary UnaryOperator Value - | Binary BinaryOperator Value Value - | ArrayLiteral [Value] - | Indexer Value Value - | ObjectLiteral [(String, Value)] - | Accessor String Value - | ObjectUpdate Value [(String, Value)] - | Abs [Ident] Value - | App Value [Value] - | Var Ident - | IfThenElse Value Value Value - | Block [Statement] - | Constructor String - | Case Value [(Binder, Value)] - | TypedValue Value PolyType deriving (Show, Data, Typeable) - -data Statement - = VariableIntroduction Ident Value - | Assignment Ident Value - | While Value [Statement] - | For Ident Value Value [Statement] - | ForEach Ident Value [Statement] - | If IfStatement - | Return Value deriving (Show, Data, Typeable) - -data IfStatement = IfStatement Value [Statement] (Maybe ElseStatement) deriving (Show, Data, Typeable) - -data ElseStatement - = Else [Statement] - | ElseIf IfStatement deriving (Show, Data, Typeable) - -data Binder - = NullBinder - | BooleanBinder Bool - | StringBinder String - | NumberBinder (Either Integer Double) - | VarBinder Ident - | NullaryBinder String - | UnaryBinder String Binder - | ObjectBinder [(String, Binder)] - | ArrayBinder [Binder] (Maybe Binder) - | NamedBinder Ident Binder - | GuardedBinder Value Binder deriving (Show, Data, Typeable) diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -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