Commits

Anonymous committed 5bfa672

+ tuples

Comments (0)

Files changed (3)

 
     type t 'a 'b = ('a * 'b);
 
-    value monomap f (a, b) = (f a, f b);
+    value map_mono f (a, b) = (f a, f b);
+
+
+
+    open Cdt
+    ;
+
+    class ti ['z]
+    ?cmp ?eq ?hash ?show
+    (ti1 : #Cdt.ti 'a)
+    (ti2 : #Cdt.ti 'b)
+    () =
+      object (self : #tifull ('a * 'b))
+
+        constraint 'z = ('a * 'b);
+
+        inherit Cdt.ti ['z] ()
+        ;
+
+        method type_desc = Tuple
+          (fun ub ->
+             let (a, b) = (uget_exn self ub) in
+             [| ubox ti1 a ; ubox ti2 b |]
+          )
+        ;
+
+        inherit tifull_ops [_] ?cmp ?eq ?hash ?show ()
+        ;
+
+      end
+    ;
 
   end
 ;
       | Record_type of (R.ubox -> array (field_name * ubox))
       | Dispatch_method of (meth_name -> type_desc)
       | Lambda of R.uti and R.uti and (unit -> R.ubox)
+      | Tuple of (R.ubox -> array R.ubox)
       ]
     and ubox =
       { ub_store : ub_store_cmd -> unit
       | Record_type of (R.ubox -> array (field_name * R.ubox))
       | Dispatch_method of (meth_name -> type_desc)
       | Lambda of R.uti and R.uti and (unit -> R.ubox)
+      | Tuple of (R.ubox -> array R.ubox)
       ]
     ;
 
             " -> "
             (List.map uti_type_name arrow_components)
          )
+   | Tuple _destr -> "(some tuple)"
    ]
 
 and get_lambda_spine uti type_desc =
    [ ( Simple _
      | Sum_type _
      | Record_type _
+     | Tuple _
      ) ->
          [uti]
 
      | Simple _
      | Sum_type _
      | Record_type _
+     | Tuple _
          ->
            failwith "Cdt.expect_abs: functional type expected"
 
         | None ->
             let xargs = xgetargs binop_meth_name
             and yargs = ygetargs binop_meth_name in
-            let args_len = Array.length xargs
-            and yargs_len = Array.length yargs in
-            if args_len <> yargs_len
-            then
-              fail uti "sum type destructs to different count \
-                    of arguments (%i <> %i)"
-                args_len yargs_len
-            else
-              inner 0
-              where rec inner i =
-                if i = args_len
-                then binop_finish
-                else
-                  let xarg = xargs.(i)
-                  and yarg = yargs.(i) in
-                  match binop_is_result (binop_struc_ubox xarg yarg) with
-                  [ Some r -> r
-                  | None -> inner (i + 1)
-                  ]
+            binop_struc_tuple uti "sum type" xargs yargs
         ]
 
+    | Tuple destr ->
+        let xargs = destr ux in
+        let yargs = destr uy in
+        binop_struc_tuple uti "sum type" xargs yargs
+
     | Record_type destr ->
         let xfields = destr ux in
         let yfields = destr uy in
         fail uti "structural %s failed on functional type" binop_meth_name
     ]
 
+  and binop_struc_tuple uti tuple_type_kind xargs yargs =
+    let args_len = Array.length xargs
+    and yargs_len = Array.length yargs in
+    if args_len <> yargs_len
+    then
+      fail uti "%s destructs to different count \
+            of arguments (%i <> %i)"
+        tuple_type_kind args_len yargs_len
+    else
+      inner 0
+      where rec inner i =
+        if i = args_len
+        then binop_finish
+        else
+          let xarg = xargs.(i)
+          and yarg = yargs.(i) in
+          match binop_is_result (binop_struc_ubox xarg yarg) with
+          [ Some r -> r
+          | None -> inner (i + 1)
+          ]
+
   and binop_struc_ubox
     ux uy =
       let utix = ux.ub_uti in
   ~unop_reduce_sum_type
   ~unop_reduce_record
   ~unop_res_ti
+  ~unop_reduce_tuple
  =
   let fail uti fmt = Printf.ksprintf
     (fun reason ->
         let args = Array.map unop_struc_ubox (xgetargs unop_meth_name) in
         unop_reduce_sum_type xname args
 
+    | Tuple destr ->
+        let xargs = destr ux in
+        let args = Array.map unop_struc_ubox xargs in
+        unop_reduce_tuple args
+
     | Record_type destr ->
         let xfields = destr ux in
         unop_reduce_record
          )
       )
     ~unop_res_ti:ti_string__base
+    ~unop_reduce_tuple:
+      (fun strs ->
+         let b = Buffer.create 20 in
+         let add s = Buffer.add_string b s in
+         let nstrs = Array.length strs in
+         ( add "("
+         ; inner 0
+           where rec inner i =
+             if i = nstrs
+             then ()
+             else
+               ( if i <> 0
+                 then add ", "
+                 else ()
+               ; add strs.(i)
+               ; inner (i + 1)
+               )
+         ; add ")"
+         ; Buffer.contents b
+         )
+      )
 ;
 
 
          Hashtbl.hash fields
       )
     ~unop_res_ti:ti_int__base
+    ~unop_reduce_tuple:Hashtbl.hash
 ;
 
 
 ;
 
 value my_ti_int =
-  new tifull ~cmp:my_cmp_int ~hash:Hashtbl.hash (Simple "my_int") ()
+  new tifull
+    ~cmp:my_cmp_int ~hash:Hashtbl.hash (Simple "my_int")
+    ~show:string_of_int
+    ()
 ;
 
 value cdt_test3 () =
 ;
 
 
-
 type my_rec =
   { f_int : int
   ; f_string : string
 ;
 
 
+value my_ti_tuple = new Tuple2.ti my_ti_option_int ti_string ()
+;
+
+
+value cdt_test8 () =
+  let test_data =
+    [ ((None, "abc"), "(None, abc)")
+    ; ((Some 123, "def"), "(Some 123, def)")
+    ]
+  in
+  List.iter
+    (fun (arg, expected) ->
+       let got = my_ti_tuple#show arg in
+       assert_equal ~printer:(fun x -> x) expected got
+    )
+    test_data
+;
+
+
+value cdt_test9 () =
+  let test_values =
+    [ (None, "a")
+    ; (None, "z")
+    ; (Some 10, "d")
+    ; (Some 20, "e")
+    ; (Some 10, "f")
+    ; (Some 20, "a")
+    ; (Some 10, "z")
+    ; (Some 10, "d")
+    ; (None, "z")
+    ]
+  in
+    List.iter
+      (fun val1 ->
+         List.iter
+           (fun val2 ->
+              let cmp12got = my_ti_tuple#cmp val1 val2 in
+              let cmp1 = my_ti_option_int#cmp (fst val1) (fst val2) in
+              let cmp2 = ti_string#cmp (snd val1) (snd val2) in
+              let cmp12expected =
+                match (cmp1, cmp2) with
+                [ ((LT | GT as r), _) -> r
+                | (EQ, r) -> r
+                ]
+              in
+              assert_equal ~printer:ti_cmp_res#show cmp12expected cmp12got
+           )
+           test_values
+      )
+      test_values
+;
+
+
 value cdt_tests =
   [ "cdt_test1" >:: cdt_test1
   ; "cdt_test2" >:: cdt_test2
   ; "cdt_test5" >:: cdt_test5
   ; "cdt_test6" >:: cdt_test6
   ; "cdt_test7" >:: cdt_test7
+  ; "cdt_test8" >:: cdt_test8
+  ; "cdt_test9" >:: cdt_test9
   ]
 ;