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