Add structured types for parsing and type checking

diff --git a/Makefile b/Makefile
index df14afd..b24d5af 100644 (file)
--- a/Makefile
+++ b/Makefile
@@ -1,5 +1,5 @@
 CLM?=clm
-CLMFLAGS?=-nr -aC,-generic_fusion
+CLMFLAGS?=-nr
 CLMLIBS?=-IL Platform
 
 all: minfp

diff --git a/ast.dcl b/ast.dcl
index b7c29ef..55f98dd 100644 (file)
--- a/ast.dcl
+++ b/ast.dcl
@@ -11,7 +11,6 @@ from int import :: Eval
 :: Expression
        = Lit Value
        | Var [Char]
-       | Tuple Expression Expression
        | App Expression Expression
        | Lambda [Char] Expression
        | Let [([Char], Expression)] Expression
@@ -25,9 +24,9 @@ from int import :: Eval
 
 :: Type
        = TVar [Char]
-       | TTuple Type Type
        | TInt
        | TBool
+       | TApp Type Type
        | (-->) infixr 9 Type Type
 
 instance toString Function, Expression, Value, Type, TypeDef

diff --git a/ast.icl b/ast.icl
index 2c6c306..20d2ca3 100644 (file)
--- a/ast.icl
+++ b/ast.icl
@@ -13,7 +13,6 @@ instance toString Expression where
        toString (Var s) = toString s
        toString (App l r) = concat ["(", toString l, " ", toString r, ")"]
        toString (Lambda a e) = concat ["(\\", toString a, ". ", toString e, ")"]
-       toString (Tuple a b) = concat ["(", toString a, ", ", toString b, ")"]
        toString (Let ns r) = concat
                [ "let ", concat [concat ["\t", toString n, " = ", toString v, "\n"]\\(n, v)<-ns]
                , "in\n", toString r]
@@ -22,16 +21,16 @@ instance toString Expression where
 instance toString Value where
        toString (Int i) = toString i
        toString (Bool b) = toString b
-       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 (TApp a b) = concat ["(", toString a, " ", toString b, ")"]
        toString (a --> b) = concat ["(", toString a, " -> ", toString b, ")"]
 
 instance toString TypeDef where
-       toString (TypeDef name args def) = ""
+       toString (TypeDef name args def) = join " " ["::",toString name:map toString args]
+               +++ " = " +++ join " | " [join " " [toString c:map toString d]\\(c, d)<-def]

diff --git a/check.icl b/check.icl
index 62a43a9..cbd58f6 100644 (file)
--- a/check.icl
+++ b/check.icl
@@ -16,22 +16,25 @@ import Text
 
 import ast, scc
 
+import StdDebug
+
 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)
+check tdfs
+       # dups = filter (\x->length x > 1) (groupBy (\(Function i _ _) (Function j _ _)->i == j) functions)
        | length dups > 0 = Left ["Duplicate functions: ":[toString n\\[(Function n _ _):_]<-dups]]
-       = case partition (\a->a=:(Function ['start'] _ _)) fs of
+       = case partition (\a->a=:(Function ['start'] _ _)) functions of
                ([], _) = Left ["No start function defined"]
                ([Function _ [] e:_], fs)
                        # e = makeExpression fs e
-                       = (\x->(e, x)) <$> runInfer (infer (fromList builtin) e)
+                       = tuple e <$> runInfer (infer (fromList (conses ++ builtin)) e)
                ([Function _ _ _:_], _) = Left ["Start cannot have arguments"]
 where
+       functions = rights tdfs
+       conses = flatten $ map (\(TypeDef n t cs)->
+               let cons = Forall t o foldr (-->) (foldl TApp (TVar n) (map TVar t))
+               in map (appSnd cons) cs) $ lefts tdfs
        builtin =
                [(['_if'],  Forall [['a']] $ TBool --> TVar ['a'] --> TVar ['a'] --> TVar ['a'])
-               ,(['_fst'], Forall [['a'], ['b']] $ TTuple (TVar ['a']) (TVar ['b']) --> TVar ['a'])
-               ,(['_snd'], Forall [['a'], ['b']] $ TTuple (TVar ['a']) (TVar ['b']) --> TVar ['b'])
                ,(['_eq'],  Forall [] $ TInt --> TInt --> TBool)
                ,(['_mul'], Forall [] $ TInt --> TInt --> TInt)
                ,(['_add'], Forall [] $ TInt --> TInt --> TInt)
@@ -84,10 +87,12 @@ class Substitutable a where
 instance Substitutable Type where
        apply s t=:(TVar v) = fromMaybe t (get v s)
        apply s (t1 --> t2) = apply s t1 --> apply s t2
+       apply s (TApp t1 t2) = TApp (apply s t1) (apply s t2)
        apply _ x = x
        
        ftv (TVar v) = [v]
        ftv (t1 --> t2) = on union ftv t1 t2
+       ftv (TApp t1 t2) = on union ftv t1 t2
        ftv _ = []
 
 instance Substitutable Scheme where
@@ -121,7 +126,7 @@ unify (TVar a) t
 unify t (TVar a) = unify (TVar a) t
 unify TInt TInt = pure newMap
 unify TBool TBool = pure newMap
-unify (TTuple l r) (TTuple l` r`)
+unify (TApp l r) (TApp l` r`)
        = unify l l`
        >>= \s1->on unify (apply s1) r r`
        >>= \s2->pure (s1 oo s2)
@@ -150,10 +155,6 @@ infer env (App e1 e2)
        >>= \(s1, t1)->infer (apply s1 env) e2
        >>= \(s2, t2)->unify (apply s2 t1) (t2 --> tv)
        >>= \s3->      pure (s3 oo s2 oo s1, apply s3 tv)
-infer env (Tuple a b)
-       =              infer env a
-       >>= \(s1, t1)->infer env b
-       >>= \(s2, t2)->pure (s1 oo s2, TTuple t1 t2)
 infer env (Lambda x b)
        =              fresh
        >>= \tv->      infer ('Data.Map'.put x (Forall [] tv) env) b

diff --git a/int.icl b/int.icl
index 0fb8087..5467559 100644 (file)
--- a/int.icl
+++ b/int.icl
@@ -24,8 +24,6 @@ int e = evalStateT (eval e)
        ,(['_add'], binop \(Int i) (Int j)->Int  (i + j))
        ,(['_mul'], binop \(Int i) (Int j)->Int  (i * j))
        ,(['_div'], binop \(Int i) (Int j)->Int  (i / j))
-       ,(['_fst'], Builtin \t->eval t >>= \(a ** b)->pure a)
-       ,(['_snd'], Builtin \t->eval t >>= \(a ** b)->pure b)
        ]
 where
        binop :: (Value Value -> Value) -> Value
@@ -36,7 +34,6 @@ eval (Let ns rest) = sequence [eval v >>= \v->modify (\vs->[(n, v):vs])\\(n, v)<
 eval (Lit v) = pure v
 eval (Var v) = gets (lookup v) >>= maybe (liftT (Left [toString v +++ " not found"])) pure
 eval (Lambda a b) = pure (Lambda` a b)
-eval (Tuple a b) = pure (a ** b)
 eval (App e1 e2) = eval e1 >>= \v->case v of
        (Lambda` v b) = eval (sub v e2 b)
        (Builtin f) = f e2 >>= eval

diff --git a/parse.icl b/parse.icl
index 00e0c26..b80bebb 100644 (file)
--- a/parse.icl
+++ b/parse.icl
@@ -115,11 +115,10 @@ where
 
        pCons = tuple <$> pId <*> many pType
 
-       pType
-               =   TInt  <$ pTop ? (\t->t=:(TTIdent ['Int']))
-               <|> TBool <$ pTop ? (\t->t=:(TTIdent ['Bool']))
-               <|> TVar  <$> pId
-               <|> pBrack pType
+       pType =   TInt  <$ pTop ? (\t->t=:(TTIdent ['Int']))
+             <|> TBool <$ pTop ? (\t->t=:(TTIdent ['Bool']))
+             <|> TVar  <$> pId
+             <|> pBrack (pChainr ((-->) <$ pToken (TTOp ['->'])) $ pChainl (pure TApp) pType)
 
        pId = (\(TTIdent i)->i) <$> pTop ? (\t->t=:(TTIdent _))
        pOp = (\(TTOp i)->i) <$> pTop ? (\t->t=:(TTOp _))
@@ -149,9 +148,7 @@ where
                        (map fst $ sortBy (on (<) snd) ifxs)
                $   pChainl (pure App)
                $   Lambda <$ pToken (TTOp ['\\']) <*> pId <* pToken (TTOp ['.']) <*> pExpression
-               <|> pBrack (   Tuple <$> pExpression <* pToken (TTOp [',']) <*> pExpression
-                              <|> Var <$> pOp
-                              <|> pExpression)
+               <|> pBrack (Var <$> pOp <|> pExpression)
                <|> Lit o Int <$> pInt
                <|> (\(TTBool i)->Lit (Bool i)) <$> pTop ? (\t->t=:(TTBool _))
                <|> (\x->Var ['_':x]) <$ pToken (TTIdent ['code']) <*> pId

diff --git a/tests/preamble.mfp b/tests/preamble.mfp
index 250ceb1..a04ee7a 100644 (file)
--- a/tests/preamble.mfp
+++ b/tests/preamble.mfp
@@ -1,9 +1,15 @@
-:: List a = Nil Int;
+:: List a = Nil | Cons a (List a);
+:: Tuple a b = Tuple a b;
+:: Either a b = Left a | Right b;
+:: Maybe a = Nothing | Just a;
+:: St s a = St (s -> Tuple a s);
 
 //Function application
 $ ifxr 0 x y = x y;
 //Reverse function application
 & ifxr 0 x y = y x;
+//Flip
+flip f x y = f y x;
 //Composition
 .. ifxr 9 f g x = f (g x);
 
@@ -12,8 +18,8 @@ $ ifxr 0 x y = x y;
 * ifxl 7 = code mul;
 - ifxl 6 = code sub;
 + ifxl 6 = code add;
-fst = code fst;
-snd = code snd;
+//fst = code fst;
+//snd = code snd;
 
 on f g a b = f (g a) (g b);
 
@@ -26,9 +32,9 @@ id x = x;
 even i = if (i == 0) True (odd (i - 1));
 odd i = if (i == 0) False (even (i - 1));
 
-uncurry f t = f (fst t) (snd t);
+//uncurry f t = f (fst t) (snd t);
 
-return a = \s. (a, s);
->>= ifxr 0 ma atmb = \s. uncurry atmb (ma s);
+return a = St $ Tuple a;
+//>>= ifxr 0 ma atmb = \s. uncurry atmb (ma s);
 
-start = 42; //fst ((return 41 >>= \x. return (x + 1)) 4);
+start = St;