From 3a084afe6b6b205f8152b0eab6d92d4f43a654cd Mon Sep 17 00:00:00 2001 From: Mart Lubbers Date: Thu, 28 Mar 2019 14:19:02 +0100 Subject: [PATCH] Add structured types for parsing and type checking --- Makefile | 2 +- ast.dcl | 3 +-- ast.icl | 7 +++---- check.icl | 25 +++++++++++++------------ int.icl | 3 --- parse.icl | 13 +++++-------- tests/preamble.mfp | 20 +++++++++++++------- 7 files changed, 36 insertions(+), 37 deletions(-) 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; -- 2.20.1