start with adts

diff --git a/ast.dcl b/ast.dcl
index 72fdf2c..b7c29ef 100644 (file)
--- a/ast.dcl
+++ b/ast.dcl
@@ -6,6 +6,7 @@ from StdOverloaded import class toString
 from int import :: Eval
 
 :: Function = Function [Char] [[Char]] Expression
+:: TypeDef = TypeDef [Char] [[Char]] [([Char], [Type])]
 
 :: Expression
        = Lit Value
@@ -22,4 +23,11 @@ from int import :: Eval
        | Lambda` [Char] Expression
        | Builtin (Expression -> Eval Expression)
 
-instance toString Function, Expression, Value
+:: Type
+       = TVar [Char]
+       | TTuple Type Type
+       | TInt
+       | TBool
+       | (-->) infixr 9 Type Type
+
+instance toString Function, Expression, Value, Type, TypeDef

diff --git a/ast.icl b/ast.icl
index 0c30c46..2c6c306 100644 (file)
--- a/ast.icl
+++ b/ast.icl
@@ -25,3 +25,13 @@ instance toString Value where
        toString (a ** b) = toString (Tuple a b)
        toString (Lambda` v a) = toString (Lambda v a)
        toString (Builtin a) = "builtin"
+
+instance toString Type where
+       toString (TVar a) = toString a
+       toString (TTuple a b) = concat ["(", toString a, ",", toString b, ")"]
+       toString TInt = "Int"
+       toString TBool = "Bool"
+       toString (a --> b) = concat ["(", toString a, " -> ", toString b, ")"]
+
+instance toString TypeDef where
+       toString (TypeDef name args def) = ""

diff --git a/check.dcl b/check.dcl
index ca07ffa..3c2c8b2 100644 (file)
--- a/check.dcl
+++ b/check.dcl
@@ -2,11 +2,10 @@ definition module check
 
 from StdOverloaded import class toString
 from Data.Either import :: Either
-from ast import :: Function, :: Expression
+from ast import :: Function, :: Expression, :: Type, :: TypeDef
 
 :: Scheme = Forall [[Char]] Type
-:: Type = TVar [Char] | TTuple Type Type | TInt | TBool | (-->) infixr 9 Type Type
 
-instance toString Scheme, Type
+instance toString Scheme
 
-check :: [Function] -> Either [String] (Expression, [([Char], Scheme)])
+check :: [Either TypeDef Function] -> Either [String] (Expression, [([Char], Scheme)])

diff --git a/check.icl b/check.icl
index ce09647..62a43a9 100644 (file)
--- a/check.icl
+++ b/check.icl
@@ -16,8 +16,9 @@ import Text
 
 import ast, scc
 
-check :: [Function] -> Either [String] (Expression, [([Char], Scheme)])
+check :: [Either TypeDef Function] -> Either [String] (Expression, [([Char], Scheme)])
 check fs
+       # fs = [v\\(Right v)<-fs]
        # dups = filter (\x->length x > 1) (groupBy (\(Function i _ _) (Function j _ _)->i == j) fs)
        | length dups > 0 = Left ["Duplicate functions: ":[toString n\\[(Function n _ _):_]<-dups]]
        = case partition (\a->a=:(Function ['start'] _ _)) fs of
@@ -60,13 +61,6 @@ instance toString Scheme where
        toString (Forall [] t) = toString t
        toString (Forall as t) = concat ["A.", join " " (map toString as), ": ", toString t]
 
-instance toString Type where
-       toString (TVar a) = toString a
-       toString (TTuple a b) = concat ["(", toString a, ",", toString b, ")"]
-       toString TInt = "Int"
-       toString TBool = "Bool"
-       toString (a --> b) = concat ["(", toString a, " -> ", toString b, ")"]
-
 :: TypeEnv :== Map [Char] Scheme
 :: Subst :== Map [Char] Type
 

diff --git a/minfp.icl b/minfp.icl
index 5e2a377..6036ffd 100644 (file)
--- a/minfp.icl
+++ b/minfp.icl
@@ -44,7 +44,7 @@ Start w
        # mstr = case mode of
                MHelp = Left [usageInfo ("Usage: " +++ argv0 +++ " [opts]\n") opts]
                MLex = map (nl o toString) <$> lex cs
-               MParse = map (nl o toString) <$> (lex cs >>= parse)
+               MParse = map (nl o either toString toString) <$> (lex cs >>= parse)
                MType = map (\(t, s)->nl (toString t +++ " :: " +++ toString s)) o snd <$> (lex cs >>= parse >>= check)
                MInterpret = pure o toString <$> (lex cs >>= parse >>= check >>= int o fst)
                MGen = lex cs >>= parse >>= check >>= gen o fst

diff --git a/parse.dcl b/parse.dcl
index 6ee56d6..2349c5d 100644 (file)
--- a/parse.dcl
+++ b/parse.dcl
@@ -2,9 +2,9 @@ definition module parse
 
 from StdOverloaded import class toString
 from Data.Either import :: Either
-from ast import :: Function
+from ast import :: Function, :: TypeDef
 
 :: Token
 instance toString Token
 lex :: [Char] -> Either [String] [Token]
-parse :: [Token] -> Either [String] [Function]
+parse :: [Token] -> Either [String] [Either TypeDef Function]

diff --git a/parse.icl b/parse.icl
index 956ca60..50539f8 100644 (file)
--- a/parse.icl
+++ b/parse.icl
@@ -9,17 +9,21 @@ import Data.GenEq
 import Data.Functor
 import Data.Func
 import Data.List
+import Data.Tuple
 import Text.GenPrint
 import StdEnv
 
 import ast
 
+cons x xs = [x:xs]
+
 (<:>) infixl 0 :: a (m [a]) -> m [a] | Functor m
-(<:>) l r = (\xs->[l:xs]) <$> r
+(<:>) l r = cons l <$> r
 
 :: Token
        = TTEq | TTSemiColon | TTLambda | TTDot | TTBrackOpen | TTBrackClose
        | TTComma | TTBool Bool | TTInt Int | TTOp [Char] | TTIdent [Char]
+       | TTDColon | TTPipe
 
 derive gEq Token
 derive gPrint Token
@@ -55,6 +59,8 @@ lex [t:ts]
                | i =: [','] = TTComma <:> lex ts
                | i =: ['.'] = TTDot <:> lex ts
                | i =: ['\\'] = TTLambda <:> lex ts
+               | i =: ['::'] = TTDColon <:> lex ts
+               | i =: ['|'] = TTPipe <:> lex ts
                = TTOp i <:> lex ts
        = Left ["Unexpected: " +++ toString t +++ " ord: " +++ toString (toInt t)]
 where
@@ -88,12 +94,36 @@ pChainl op p = foldl (flip ($)) <$> p <*> many (flip <$> op <*> p)
 pChainr :: (Parser (a a -> a)) (Parser a) -> Parser a
 pChainr op p = flip ($) <$> p <*> (flip <$> op <*> pChainr op p) <|> p
 
-parse :: [Token] -> Either [String] [Function]
+parse :: [Token] -> Either [String] [Either TypeDef Function]
 parse ts = fst <$> runStateT (reverse <$> pAST <* pEof) {tokens=ts, ifxs=[]}
 where
-       pAST :: Parser [Function]
-       pAST = many pFunction >>= mapM \(id, args, body)->Function id args <$
-               modify (\t->{t & tokens=body}) <*> pExpression <* pEof
+       pAST :: Parser [Either TypeDef Function]
+       pAST = many (Right <$> pFunction <|> Left <$> pTypeDef)
+               >>= mapM (either (pure o Left) \(id, args, body)->Right o
+                       Function id args <$ modify (\t->{t & tokens=body}) <*> pExpression <* pEof)
+
+       pTypeDef :: Parser TypeDef
+       pTypeDef = TypeDef
+               <$  pToken TTDColon
+               <*> pId
+               <*> many pId
+               <*  pToken TTEq
+               <*> (cons <$> pCons <*> many (pToken TTPipe *> pCons))
+               <*  pToken TTSemiColon
+
+       pCons = tuple <$> pId <*> many pType
+
+       pType
+               =   TInt  <$ pTop ? (\t->t=:(TTIdent ['Int']))
+               <|> TBool <$ pTop ? (\t->t=:(TTIdent ['Bool']))
+               <|> TVar  <$> pId
+               <|> 
+:: Type
+       = TVar [Char]
+       | TTuple Type Type
+       | TInt
+       | TBool
+       | (-->) infixr 9 Type Type
 
        pId = (\(TTIdent i)->i) <$> pTop ? (\t->t=:(TTIdent _))
        pOp = (\(TTOp i)->i) <$> pTop ? (\t->t=:(TTOp _))
@@ -101,7 +131,7 @@ where
 
        pFunction :: Parser ([Char], [[Char]], [Token])
        pFunction
-               =   (\x y z->(x, y, z))
+               =   tuple3
                <$> (pFunId <|> pId)
                <*> many pId
                <*  pToken TTEq