From: Mart Lubbers <mart@martlubbers.net>
Date: Thu, 28 Mar 2019 13:19:02 +0000 (+0100)
Subject: Add structured types for parsing and type checking
X-Git-Url: https://git.martlubbers.net/?a=commitdiff_plain;h=3a084afe6b6b205f8152b0eab6d92d4f43a654cd;p=minfp.git

Add structured types for parsing and type checking
---

diff --git a/Makefile b/Makefile
index df14afd..b24d5af 100644
--- 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
--- 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
--- 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
--- 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
--- 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
--- 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
--- 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;