Implement type system preprocessing.

.gitignore

@@ -4,4 +4,5 @@ Contua.cabal
 .idea
 *.aux
 *.log
+out
 *.gz

Contua.iml

@@ -11,29 +11,26 @@
     <orderEntry type="inheritedJdk" />
     <orderEntry type="sourceFolder" forTests="false" />
     <orderEntry type="library" name="base-4.12.0.0" level="project" />
-    <orderEntry type="library" name="ghc-prim-0.5.3" level="project" />
-    <orderEntry type="library" name="integer-gmp-1.0.2.0" level="project" />
+    <orderEntry type="library" name="hspec-2.6.1" level="project" />
+    <orderEntry type="library" name="hspec-megaparsec-2.0.0" level="project" />
     <orderEntry type="library" name="megaparsec-7.0.4" level="project" />
     <orderEntry type="library" name="mtl-2.2.2" level="project" />
+    <orderEntry type="library" name="parser-combinators-1.0.1" level="project" />
     <orderEntry type="library" name="text-1.2.3.1" level="project" />
+    <orderEntry type="library" name="transformers-0.5.6.2" level="project" />
+    <orderEntry type="library" name="ghc-prim-0.5.3" level="project" />
+    <orderEntry type="library" name="integer-gmp-1.0.2.0" level="project" />
+    <orderEntry type="library" name="QuickCheck-2.12.6.1" level="project" />
+    <orderEntry type="library" name="hspec-core-2.6.1" level="project" />
+    <orderEntry type="library" name="hspec-discover-2.6.1" level="project" />
+    <orderEntry type="library" name="hspec-expectations-0.8.2" level="project" />
+    <orderEntry type="library" name="containers-0.6.0.1" level="project" />
     <orderEntry type="library" name="bytestring-0.10.8.2" level="project" />
     <orderEntry type="library" name="case-insensitive-1.2.0.11" level="project" />
-    <orderEntry type="library" name="containers-0.6.0.1" level="project" />
     <orderEntry type="library" name="deepseq-1.4.4.0" level="project" />
-    <orderEntry type="library" name="parser-combinators-1.0.1" level="project" />
     <orderEntry type="library" name="scientific-0.3.6.2" level="project" />
-    <orderEntry type="library" name="transformers-0.5.6.2" level="project" />
     <orderEntry type="library" name="array-0.5.3.0" level="project" />
     <orderEntry type="library" name="binary-0.8.6.0" level="project" />
-    <orderEntry type="library" name="hashable-1.2.7.0" level="project" />
-    <orderEntry type="library" name="integer-logarithms-1.0.2.2" level="project" />
-    <orderEntry type="library" name="primitive-0.6.4.0" level="project" />
-    <orderEntry type="library" name="hspec-2.6.1" level="project" />
-    <orderEntry type="library" name="hspec-megaparsec-2.0.0" level="project" />
-    <orderEntry type="library" name="QuickCheck-2.12.6.1" level="project" />
-    <orderEntry type="library" name="hspec-core-2.6.1" level="project" />
-    <orderEntry type="library" name="hspec-discover-2.6.1" level="project" />
-    <orderEntry type="library" name="hspec-expectations-0.8.2" level="project" />
     <orderEntry type="library" name="erf-2.0.0.0" level="project" />
     <orderEntry type="library" name="random-1.1" level="project" />
     <orderEntry type="library" name="template-haskell-2.14.0.0" level="project" />
@@ -47,6 +44,9 @@
     <orderEntry type="library" name="quickcheck-io-0.2.0" level="project" />
     <orderEntry type="library" name="setenv-0.1.1.3" level="project" />
     <orderEntry type="library" name="stm-2.5.0.0" level="project" />
+    <orderEntry type="library" name="hashable-1.2.7.0" level="project" />
+    <orderEntry type="library" name="integer-logarithms-1.0.2.2" level="project" />
+    <orderEntry type="library" name="primitive-0.6.4.0" level="project" />
     <orderEntry type="library" name="time-1.8.0.2" level="project" />
     <orderEntry type="library" name="ghc-boot-th-8.6.4" level="project" />
     <orderEntry type="library" name="pretty-1.1.3.6" level="project" />

app/Main.hs

@@ -7,6 +7,7 @@ import Control.Monad
 import Parser.TypeDefs
 import Control.Monad.Trans.Maybe
 import TypeSystem.TypeSystem
+import TypeSystem.Preprocessor
 
 {- | Prints the contents of all files in the arguments. -}
 catMain :: IO ()
@@ -18,7 +19,7 @@ oneFileParser :: IO ()
 oneFileParser = do
   fname:_ <- getArgs
   contents <- readFile fname
-  print $ parseProgram fname contents >>= typeCheck
+  print $ parseProgram fname contents >>= typeCheck . preprocess
 
 main :: IO ()
 main = oneFileParser

package.yaml

@@ -28,6 +28,7 @@ dependencies:
 - parser-combinators
 - hspec >= 2.6.1
 - hspec-megaparsec
+- containers
 
 library:
   source-dirs: src

src/Parser/Expr.hs

@@ -16,18 +16,18 @@ funDecl =
   FunDecl
     <$> type_
     <* symbol "::"
-    <*> identifier
-    <*> many (EVar <$> identifier)
+    <*> identifier -- function name
+    <*> many identifier -- args
     <* symbol "="
-    <*> expr
+    <*> expr -- body
     <* symbol ";"
 
 
 lambda :: Parser Expr
 lambda =
   ELambda
     <$ keyword "fn"
-    <*> many (EVar <$> identifier)
+    <*> many identifier
     <* symbol "."
     <*> expr
 
@@ -51,7 +51,7 @@ letExpr :: Parser Expr
 letExpr =
   ELet
     <$ keyword "let"
-    <*> expr
+    <*> identifier
     <* symbol "="
     <*> expr
     <* keyword "in"
@@ -63,8 +63,7 @@ matchExpr =
     <$ keyword "match"
     <*> expr
     <* keyword "with"
-    <* optional (symbol "|")
-    <*> ((,) <$> expr <* symbol "=>" <*> expr) `sepBy` symbol "|"
+    <*> some ((,) <$ symbol "|" <*> expr <* symbol "=>" <*> expr)
 
 exprTerm :: Parser Expr
 exprTerm = choice

src/Parser/Parser.hs

@@ -1,5 +1,6 @@
 module Parser.Parser
     ( parseProgram
+    , ParserError
     , program
     ) where
 

src/Parser/TypeDefs.hs

@@ -4,7 +4,7 @@ import           Data.List.NonEmpty
 
 data AST = AST [TypeDecl] [FunDecl] deriving (Show, Eq)
 
-data FunDecl = FunDecl Type Name [Expr] Expr deriving (Show, Eq)
+data FunDecl = FunDecl { fnType :: Type, fnName :: Name, fnArgs :: [Name], fnBody :: Expr } deriving (Show, Eq)
 
 data TypeVariant = TypeVariant TypeName [Type] deriving (Show, Eq)
 
@@ -17,17 +17,44 @@ data Type =
   | TList Type
   | TFun Type Type
   | TApply Type Type
+  | TPattern
   deriving (Show, Eq)
 
-infixr 8 ^->^
-infixl 9 ^$$^
+-- | Type construction helpers.
+
+mkETypeName :: String -> Expr
+mkETypeName = ETypeName . TypeName
+
+mkTCtor :: String -> Type
+mkTCtor = TCtor . TypeName
+
+aType, intType, aListType, boolType :: Type
+intType = mkTCtor "Int"
+boolType = mkTCtor "Bool"
+aType = TAbstract "a"
+aListType = TList aType
+
+binaryType, unaryType :: Type -> Type
+binaryType t = t ^->^ t ^->^ t
+unaryType t = t ^->^ t
 
+
+data Pattern =
+    Name
+  | PTApply TypeName Pattern
+  | PCons Pattern Pattern
+  | PList Pattern
+  deriving (Show, Eq)
+
+infixr 8 ^->^
 (^->^) = TFun
+
+infixl 9 ^$$^
 (^$$^) = TApply
 
 type Name = String
 
-type TypeName = String
+newtype TypeName = TypeName { unTypeName :: String } deriving (Show, Eq)
 
 data Expr =
     EVar Name
@@ -38,13 +65,13 @@ data Expr =
   | ESub Expr Expr
   | EMul Expr Expr
   | EApply Expr Expr
-  | ELambda [Expr] Expr
+  | ELambda [Name] Expr
   | EListLiteral [Expr]
   | ECons Expr Expr
   | EConcat Expr Expr
   | EIf Expr Expr Expr
   | EMatch Expr [(Expr, Expr)]
-  | ELet Expr Expr Expr
+  | ELet Name Expr Expr
   | EAnd Expr Expr
   | EOr Expr Expr
   | ENot Expr

src/Parser/Utils.hs

@@ -5,6 +5,7 @@ import           Data.Void
 import           Text.Megaparsec                hiding (State)
 import           Text.Megaparsec.Char
 import qualified Text.Megaparsec.Char.Lexer     as L
+import Parser.TypeDefs (TypeName(..))
 
 type Parser = Parsec Void String
 
@@ -74,8 +75,8 @@ identifier =
     "Expected identifier, got keyword."
     (lexeme ((:) <$> lowerChar <*> many alphaNumChar <?> "identifier"))
 
-typeName :: Parser String
-typeName =
+typeName :: Parser TypeName
+typeName = TypeName <$>
   withPredicate
     (`notElem` keywords)
     "Expected typename, got keyword."

src/Semantics/Builtins.hs

@@ -0,0 +1,51 @@
+module Semantics.Builtins where
+
+import qualified Data.Map as Map
+import Data.Map (Map)
+import Data.List (isPrefixOf)
+
+import Parser.TypeDefs
+
+type BuiltinName = String
+
+builtinPrefix :: BuiltinName
+builtinPrefix = "__contua_builtin_"
+
+makeBuiltin :: String -> BuiltinName
+makeBuiltin = (builtinPrefix ++)
+
+isBuiltin :: String -> Bool
+isBuiltin s = builtinPrefix `isPrefixOf` s
+
+addName, subName, negName, mulName, consName, concName, andName, orName, eqName, leqName, notName, ifteName, matchesName :: BuiltinName
+addName = makeBuiltin "addition"
+subName = makeBuiltin "subtraction"
+negName = makeBuiltin "negation"
+mulName = makeBuiltin "multiplication"
+consName = makeBuiltin "list_construction"
+concName = makeBuiltin "concatenation"
+andName = makeBuiltin "logical_and"
+orName = makeBuiltin "logical_or"
+notName = makeBuiltin "logical_not"
+eqName = makeBuiltin "equality"
+leqName = makeBuiltin "less_than_or_equal"
+ifteName = makeBuiltin "if_then_else"
+matchesName = makeBuiltin "pattern_match" -- x matches y
+
+
+builtinTypes :: Map BuiltinName Type
+builtinTypes = Map.fromList
+  [ (addName, binaryType intType)
+  , (subName, binaryType intType)
+  , (negName, unaryType intType)
+  , (mulName, binaryType intType)
+  , (consName, aType ^->^ aListType ^->^ aListType)
+  , (concName, aListType ^->^ aListType ^->^ aListType)
+  , (andName, binaryType boolType)
+  , (orName, binaryType boolType)
+  , (notName, unaryType boolType)
+  , (eqName, intType ^->^ intType ^->^ boolType)
+  , (leqName, intType ^->^ intType ^->^ boolType)
+  , (ifteName, boolType ^->^ intType ^->^ intType ^->^ intType ^->^ intType)
+  , (matchesName, TPattern ^->^ aType ^->^ boolType)
+  ]

src/TypeSystem/DeclarationChecker.hs

@@ -0,0 +1,2 @@
+module TypeSystem.DeclarationChecker where
+

src/TypeSystem/Preprocessor.hs

@@ -0,0 +1,37 @@
+module TypeSystem.Preprocessor where
+
+import TypeSystem.TypeDefs
+import Semantics.Builtins
+import Parser.TypeDefs
+
+preprocess :: AST -> IAST
+preprocess (AST types fns) = IAST types $ map convertFn fns
+  where
+    convertFn (FunDecl fnType fnName fnArgs fnBody) = IFn fnType fnName fnArgs $ desugar fnBody
+
+infixl 9 ^^$
+(^^$) = IEApply
+
+desugar :: Expr -> IExpr
+desugar (EVar x) = IEVar x
+desugar (EInt x) = ILit $ LInt x
+desugar (ETypeName x) = IETypeCtor x
+desugar (EAdd e1 e2) = IEVar addName ^^$ desugar e1 ^^$ desugar e2
+desugar (ESub e1 e2) = IEVar subName ^^$ desugar e1 ^^$ desugar e2
+desugar (EMul e1 e2) = IEVar mulName ^^$ desugar e1 ^^$ desugar e2
+desugar (EApply e1 e2) = IEApply (desugar e1) $ desugar e2
+desugar (ELambda args body) = foldr IEAbstract (desugar body) args
+desugar (EListLiteral list) = foldr (IEApply . IEApply (IEVar consName) . desugar) (ILit LEmptyList) list
+desugar (ECons e1 e2) = IEVar consName ^^$ desugar e1 ^^$ desugar e2
+desugar (EConcat e1 e2) = IEVar concName ^^$ desugar e1 ^^$ desugar e2
+desugar (EAnd e1 e2) = IEVar andName ^^$ desugar e1 ^^$ desugar e2
+desugar (EOr e1 e2) = IEVar orName ^^$ desugar e1 ^^$ desugar e2
+desugar (EEq e1 e2) = IEVar eqName ^^$ desugar e1 ^^$ desugar e2
+desugar (ELeq e1 e2) = IEVar leqName ^^$ desugar e1 ^^$ desugar e2
+desugar (ENeg e) = IEVar negName ^^$ desugar e
+desugar (ENot e) = IEVar notName ^^$ desugar e
+desugar (ELet x e1 e2) = IELet x (desugar e1) $ desugar e2
+desugar (EIf b e1 e2) = IEApply (IEApply (IEVar ifteName ^^$ desugar b) $ desugar e1) $ desugar e2
+desugar (EMatch e pats) =
+  let e' = desugar e
+    in foldr (\(pat, expr) -> IEApply $ IEVar ifteName ^^$ (IEVar matchesName ^^$ e' ^^$ desugar pat) ^^$ desugar expr) (ILit LError) pats

src/TypeSystem/TypeDefs.hs

@@ -0,0 +1,26 @@
+module TypeSystem.TypeDefs where
+
+import Parser.TypeDefs
+
+-- | The I prefix stands for Internal (or intermediate :P)
+
+data IAST = IAST [ITDecl] [IFnDecl] deriving (Show, Eq)
+
+type ITDecl = TypeDecl
+
+data IFnDecl = IFn Type Name [Name] IExpr deriving (Show, Eq)
+
+data IExpr =
+    IEAbstract Name IExpr
+  | IEApply IExpr IExpr
+  | IELet Name IExpr IExpr
+  | IEVar Name
+  | IETypeCtor TypeName
+  | ILit Lit
+  deriving (Show, Eq)
+
+data Lit =
+    LInt Int
+  | LEmptyList
+  | LError
+  deriving (Show, Eq)

src/TypeSystem/TypeSystem.hs

@@ -0,0 +1,8 @@
+module TypeSystem.TypeSystem where
+
+import Parser.Parser
+import Parser.TypeDefs
+import TypeSystem.TypeDefs
+
+typeCheck :: IAST -> Either ParserError IAST
+typeCheck = return