tuples

src/exec.ml

@@ -41,9 +41,11 @@ let rec exp_captures bound = function
   | EInt _ | EBool _ | EFnB _ -> []
   | EVar x -> if List.mem x bound then [] else [x]
   | EFn (x, _, e) -> exp_captures (x::bound) e
-  | EApp (e1, e2) -> List.concat_map (exp_captures bound) [e1;e2]
+  | ETuple (e1, e2) | EApp (e1, e2) ->
+      List.concat_map (exp_captures bound) [e1;e2]
   | EIf (b, e1, e2) -> List.concat_map (exp_captures bound) [b;e1;e2]
   | EScope s -> fst (stmt_captures bound s)
+  | EProj (_, e) -> exp_captures bound e
 and stmt_captures bound = function
   | SExp e | SAsgn (_, e) -> (exp_captures bound e, bound)
   | SDecl (x, _) -> ([], [x])
@@ -72,6 +74,11 @@ let rec eval (m: mem) (e: exp) : value =
       | VBool b -> eval m (if b then e1 else e2)
       | _ -> raise (Failure "not a bool"))
   | EScope s -> fst (exec m s)
+  | ETuple (e1, e2) -> VTuple (eval m e1, eval m e2)
+  | EProj (b, e) ->
+      (match eval m e with
+      | VTuple (v1, v2) -> if b then v1 else v2
+      | _ -> raise (Failure "not a tuple"))
 and exec (m: mem) (s: stmt) =
   match s with
   | SExp e -> eval m e, m

src/lexer.mll

@@ -15,6 +15,7 @@ rule token = parse
   | '-' { MINUS }
   | '*' { TIMES }
   | '/' { DIVIDE }
+  | ',' { COMMA }
   | '<' { LT }
   | '>' { GT }
   | "<=" { LE }
@@ -23,6 +24,8 @@ rule token = parse
   | "&&" { AND }
   | "||" { OR }
   | "->" { ARROW }
+  | "1P" { PROJ1 }
+  | "2P" { PROJ2 }
   | "if" { IF }
   | "then" { THEN }
   | "else" { ELSE }

src/parser.mly

@@ -2,8 +2,8 @@
   open Types
   let app2 x a b = EApp (EApp (EVar x, a), b)
 %}
-%token LPAREN RPAREN LBRACE RBRACE
-%token SEMICOLON COLON EQUAL ARROW
+%token LPAREN RPAREN LBRACE RBRACE PROJ1 PROJ2
+%token SEMICOLON COLON EQUAL ARROW COMMA
 %token OR AND PLUS MINUS TIMES DIVIDE LT GT LE GE EQ
 %token IF THEN ELSE TRUE FALSE FN LET EOF
 %token<int> NUM
@@ -19,7 +19,9 @@
 %left PLUS MINUS
 %left TIMES DIVIDE
 %nonassoc LT GT LE GE EQ
+%nonassoc PROJ1 PROJ2
 %nonassoc NUM VAR
+%left COMMA
 %right LPAREN RPAREN
 %nonassoc EOF
 %right ARROW
@@ -31,6 +33,7 @@
 
 parse_typ:
   | parse_typ ARROW parse_typ { TFn ($1,$3) }
+  | parse_typ TIMES parse_typ { TProd ($1,$3) }
   | typ { $1 }
 
 typ:
@@ -79,6 +82,10 @@ parse_exp:
       { app2 "ge" $1 $3 }
   | parse_exp EQ parse_exp
       { app2 "eq" $1 $3 }
+  | parse_exp COMMA parse_exp
+      { ETuple ($1,$3) }
+  | PROJ1 parse_exp { EProj (true,$2) }
+  | PROJ2 parse_exp { EProj (false,$2) }
   | FN LPAREN VAR COLON parse_typ RPAREN parse_exp
       { EFn ($3,$5,$7) }
   | LBRACE parse_stmt RBRACE { EScope $2 }

src/types.ml

@@ -4,6 +4,7 @@ type var = string
 type typ =
   | TInt
   | TBool
+  | TProd of (typ * typ)
   | TFn of (typ * typ)
 [@@deriving show]
 
@@ -20,6 +21,8 @@ type exp =
   | EApp of (exp * exp)
   | EIf of (exp * exp * exp)
   | EScope of stmt
+  | ETuple of (exp * exp)
+  | EProj of (bool * exp)
 [@@deriving show]
 and stmt =
   | SExp of exp
@@ -34,6 +37,7 @@ and value =
   | VBool of bool
   | VFn of (mem * var * exp)
   | VFnB of (mem * fnb)
+  | VTuple of (value * value)
 [@@deriving show]
 
 let rec typchk_exp tc = function
@@ -66,6 +70,14 @@ let rec typchk_exp tc = function
       (match typchk_stmt tc s with
       | Some (t, _) -> Some t
       | _ -> None)
+  | ETuple (e1, e2) ->
+      (match typchk_exp tc e1, typchk_exp tc e2 with
+      | Some t1, Some t2 -> Some (TProd (t1, t2))
+      | _, _ -> None)
+  | EProj (b, e) ->
+      (match typchk_exp tc e with
+      | Some (TProd (t1, t2)) -> Some (if b then t1 else t2)
+      | _ -> None)
 and typchk_stmt tc = function
   | SExp e ->
       (match typchk_exp tc e with