From: Mart Lubbers <mart@martlubbers.net>
Date: Wed, 20 Mar 2019 09:22:30 +0000 (+0100)
Subject: something something tuples
X-Git-Url: https://git.martlubbers.net/?a=commitdiff_plain;h=30fe47b3f24d662ed475015599a56739896bc23b;p=minfp.git

something something tuples
---

diff --git a/ast.dcl b/ast.dcl
index 4dfad17..72fdf2c 100644
--- a/ast.dcl
+++ b/ast.dcl
@@ -10,6 +10,7 @@ from int import :: Eval
 :: Expression
 	= Lit Value
 	| Var [Char]
+	| Tuple Expression Expression
 	| App Expression Expression
 	| Lambda [Char] Expression
 	| Let [([Char], Expression)] Expression
@@ -17,6 +18,7 @@ from int import :: Eval
 :: Value
 	= Int Int
 	| Bool Bool
+	| ** infix 9 Expression Expression
 	| Lambda` [Char] Expression
 	| Builtin (Expression -> Eval Expression)
 
diff --git a/ast.icl b/ast.icl
index 5579c3b..0c30c46 100644
--- a/ast.icl
+++ b/ast.icl
@@ -12,7 +12,8 @@ instance toString Expression where
 	toString (Lit v) = toString v
 	toString (Var s) = toString s
 	toString (App l r) = concat ["(", toString l, " ", toString r, ")"]
-	toString (Lambda a e) = concat ["(\\", toString a, ".", toString e, ")"]
+	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]
@@ -21,5 +22,6 @@ 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"
diff --git a/builtin.dcl b/builtin.dcl
deleted file mode 100644
index 1d2606a..0000000
--- a/builtin.dcl
+++ /dev/null
@@ -1,5 +0,0 @@
-definition module builtin
-
-from check import :: Scheme
-
-builtin :: [([Char], Scheme)]
diff --git a/builtin.icl b/builtin.icl
deleted file mode 100644
index 33c67e6..0000000
--- a/builtin.icl
+++ /dev/null
@@ -1,13 +0,0 @@
-implementation module builtin
-
-import Data.Func
-import check
-
-builtin :: [([Char], Scheme)]
-builtin =
-	[(['_if'],  Forall [['_ift']] $ TBool --> TVar ['_ift'] --> TVar ['_ift'] --> TVar ['_ift'])
-	,(['_eq'],  Forall [['_eq']]  $ TInt --> TInt --> TBool)
-	,(['_mul'], Forall [['_mul']] $ TInt --> TInt --> TInt)
-	,(['_add'], Forall [['_add']] $ TInt --> TInt --> TInt)
-	,(['_sub'], Forall [['_sub']] $ TInt --> TInt --> TInt)
-	]
diff --git a/check.dcl b/check.dcl
index da6c1f9..ca07ffa 100644
--- a/check.dcl
+++ b/check.dcl
@@ -5,7 +5,7 @@ from Data.Either import :: Either
 from ast import :: Function, :: Expression
 
 :: Scheme = Forall [[Char]] Type
-:: Type = TVar [Char] | TInt | TBool | (-->) infixr 9 Type Type
+:: Type = TVar [Char] | TTuple Type Type | TInt | TBool | (-->) infixr 9 Type Type
 
 instance toString Scheme, Type
 
diff --git a/check.icl b/check.icl
index a18a378..574c178 100644
--- a/check.icl
+++ b/check.icl
@@ -14,7 +14,7 @@ import Data.Map => qualified put, union, difference, find, updateAt
 import Data.Maybe
 import Text
 
-import ast, scc, builtin
+import ast, scc
 
 check :: [Function] -> Either [String] (Expression, [([Char], Scheme)])
 check fs
@@ -26,6 +26,16 @@ check fs
 			# e = makeExpression fs e
 			= (\x->(e, x)) <$> runInfer (infer (fromList builtin) e)
 		([Function _ _ _:_], _) = Left ["Start cannot have arguments"]
+where
+	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)
+		,(['_sub'], Forall [] $ TInt --> TInt --> TInt)
+		]
 
 makeExpression :: [Function] Expression -> Expression
 makeExpression fs start = foldr mkExpr start $ scc [(l, vars e [])\\(l, e)<-nicefuns]
@@ -51,6 +61,7 @@ instance toString Scheme where
 
 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, ")"]
@@ -115,6 +126,10 @@ 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 l l`
+	>>= \s1->on unify (apply s1) r r`
+	>>= \s2->pure (s1 oo s2)
 unify t1 t2 = err ["Cannot unify: ", toString t1, " with ", toString t2]
 
 unifyl :: [Type] -> Infer Subst
@@ -140,6 +155,10 @@ 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 5467559..0fb8087 100644
--- a/int.icl
+++ b/int.icl
@@ -24,6 +24,8 @@ 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
@@ -34,6 +36,7 @@ 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 8dc29af..956ca60 100644
--- a/parse.icl
+++ b/parse.icl
@@ -17,7 +17,9 @@ import ast
 (<:>) infixl 0 :: a (m [a]) -> m [a] | Functor m
 (<:>) l r = (\xs->[l:xs]) <$> r
 
-:: Token = TTEq | TTSemiColon | TTLambda | TTDot | TTBrackOpen | TTBrackClose | TTBool Bool | TTInt Int | TTOp [Char] | TTIdent [Char]
+:: Token
+	= TTEq | TTSemiColon | TTLambda | TTDot | TTBrackOpen | TTBrackClose
+	| TTComma | TTBool Bool | TTInt Int | TTOp [Char] | TTIdent [Char]
 
 derive gEq Token
 derive gPrint Token
@@ -50,6 +52,7 @@ lex [t:ts]
 	| isOp t
 		# (i, ts) = span isOp [t:ts]
 		| i =: ['='] = TTEq <:> lex ts
+		| i =: [','] = TTComma <:> lex ts
 		| i =: ['.'] = TTDot <:> lex ts
 		| i =: ['\\'] = TTLambda <:> lex ts
 		= TTOp i <:> lex ts
@@ -94,6 +97,7 @@ where
 
 	pId = (\(TTIdent i)->i) <$> pTop ? (\t->t=:(TTIdent _))
 	pOp = (\(TTOp i)->i) <$> pTop ? (\t->t=:(TTOp _))
+	pBrack p = pToken TTBrackOpen *> p <* pToken TTBrackClose
 
 	pFunction :: Parser ([Char], [[Char]], [Token])
 	pFunction
@@ -116,8 +120,9 @@ where
 			(map fst $ sortBy (on (<) snd) ifxs)
 		$   pChainl (pure App)
 		$   Lambda <$ pToken TTLambda <*> pId <* pToken TTDot <*> pExpression
-		<|> Var <$ pToken TTBrackOpen <*> pOp <* pToken TTBrackClose
-		<|> pToken TTBrackOpen *> pExpression <* pToken TTBrackClose
+		<|> pBrack (   Tuple <$> pExpression <* pToken TTComma <*> pExpression
+			       <|> Var <$> pOp
+			       <|> pExpression)
 		<|> (\(TTInt i)->Lit (Int i)) <$> pTop ? (\t->t=:(TTInt _))
 		<|> (\(TTBool i)->Lit (Bool i)) <$> pTop ? (\t->t=:(TTBool _))
 		<|> (\x->Var ['_':x]) <$ pId ? ((==)['code']) <*> pId
diff --git a/tests/preamble.mfp b/tests/preamble.mfp
index 70fc870..176004a 100644
--- a/tests/preamble.mfp
+++ b/tests/preamble.mfp
@@ -2,12 +2,16 @@
 $ ifxr 0 x y = x y;
 //Reverse function application
 & ifxr 0 x y = y x;
+//Composition
+.. ifxr 9 f g x = f (g x);
 
 //Arithmetic operators
 == ifxl 7 = code eq;
 * ifxl 7 = code mul;
 - ifxl 6 = code sub;
 + ifxl 6 = code add;
+fst = code fst;
+snd = code snd;
 
 on f g a b = f (g a) (g b);
 
@@ -19,3 +23,10 @@ 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);
+
+return a = \s. (a, s);
+>>= ifxr 0 ma atmb = \s. uncurry atmb (ma s);
+
+start = fst ((return 41 >>= \x. return (x + 1)) 4);