something something tuples

diff --git a/ast.dcl b/ast.dcl
index 4dfad17..72fdf2c 100644 (file)
--- 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 (file)
--- 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 (file)
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 (file)
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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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);