From 3b47ccd04e95476b2d7dae0f7b2d0fea5d27cde9 Mon Sep 17 00:00:00 2001
From: Mart Lubbers <mart@martlubbers.net>
Date: Wed, 27 Mar 2019 08:47:24 +0100
Subject: [PATCH] start with adts

---
 ast.dcl   | 10 +++++++++-
 ast.icl   | 10 ++++++++++
 check.dcl |  7 +++----
 check.icl | 10 ++--------
 minfp.icl |  2 +-
 parse.dcl |  4 ++--
 parse.icl | 42 ++++++++++++++++++++++++++++++++++++------
 7 files changed, 63 insertions(+), 22 deletions(-)

diff --git a/ast.dcl b/ast.dcl
index 72fdf2c..b7c29ef 100644
--- 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
--- 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
--- 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
--- 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
--- 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
--- 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
--- 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
-- 
2.20.1