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