Anonymous avatar Anonymous committed b93926f

classes changes

Comments (0)

Files changed (2)

 ;
 
 
+value u_app2
+ : ubox -> ubox -> ubox -> ubox
+ = fun uf ua ub ->
+     u_app (u_app uf ua) ub
+;
+
+
 value entype_abs
  : #ti 'a -> ubox -> ('a -> ubox)
  = fun ta uf ->
 
 
 
-class virtual ticmp_register ['a] =
-  object (self : #tti 'a)
+value check_equal_uti
+ : #uti -> #uti -> unit
+ = fun u1 u2 ->
+     if u1#type_id = u2#type_id
+     then ()
+     else failwith "check_equal_uti: types differ (%S <> %S)"
+            (uti_type_name u1)
+            (uti_type_name u2)
+;
 
-    method virtual cmp : 'a -> 'a -> cmp_res;
+
+value cmp_of_compare_res = fun
+  [ 0 -> EQ
+  | x when x < 0 -> LT
+  | _ (* when x > 0 *) -> GT
+  ]
+;
+
+value string_cmp (a : string) b =
+  cmp_of_compare_res (Pervasives.compare a b)
+;
+
+value string_eq (a : string) b =
+  (a = b)
+;
+
+
+value binop_struc_gen
+  ~binop_meth_name
+  ~binop_constructor
+  ~binop_is_result
+  ~binop_finish
+  ~binop_res_ti
+ =
+  let fail uti fmt = Printf.ksprintf
+    (fun reason ->
+       failwith "structural %s failed on type %S: %s"
+         binop_meth_name
+         (uti_type_name uti)
+         reason
+    )
+    fmt
+  in
+  let rec binop_struc uti ux uy =
+    let () = check_equal_uti uti ux.ub_uti in
+    let () = check_equal_uti uti uy.ub_uti in
+    binop_struc_typedesc uti uti#type_desc ux uy
+
+  and binop_struc_typedesc uti type_desc ux uy =
+    match type_desc with
+    [ Simple tn -> fail uti "it's simple type %S" tn
+    | Sum_type destr ->
+        let (xname, xargs) = destr ux in
+        let (yname, yargs) = destr uy in
+        match binop_is_result (binop_constructor xname yname) with
+        [ Some r -> r
+        | None ->
+            let args_len = Array.length xargs in
+            let 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)
+                  ]
+        ]
+
+    | Record_type destr ->
+        let xfields = destr ux in
+        let yfields = destr uy in
+        let nfields = Array.length xfields in
+        let ynfields = Array.length yfields in
+        if nfields != ynfields
+        then
+          fail uti "record type destructs to different count \
+                of fields (%i <> %i)"
+            nfields ynfields
+        else
+          inner 0
+          where rec inner i =
+            if i = nfields
+            then binop_finish
+            else
+              let (xname, xval) = xfields.(i) in
+              let (yname, yval) = yfields.(i) in
+              if xname <> yname
+              then
+                fail uti "record type should destruct to the same fields \
+                      in the same order (now: field %i: %S <> %S)"
+                  i xname yname
+              else
+                match binop_is_result (binop_struc_ubox xval yval) with
+                [ Some r -> r
+                | None -> inner (i + 1)
+                ]
+
+    | Dispatch_method dm ->
+        binop_struc_typedesc uti (dm binop_meth_name) ux uy
+
+    | Lambda _ _ _ ->
+        fail uti "structural %s failed on functional type" binop_meth_name
+    ]
+
+  and binop_struc_ubox
+    ux uy =
+      let utix = ux.ub_uti in
+      let utiy = uy.ub_uti in
+      let () = check_equal_uti utix utiy in
+      let ubinop = get_meth_untyped binop_meth_name utix in
+      let ubinopy = get_meth_untyped binop_meth_name utiy in
+      if ubinop != ubinopy
+      then
+        fail utix "cmp_ubox failed: %S methods must be equal"
+          binop_meth_name
+      else
+        uget_exn binop_res_ti (u_app2 ubinop ux uy)
+  in
+    binop_struc
+;
+
+
+value rec cmp_struc
+ : #uti -> ubox -> ubox -> cmp_res
+ =
+  binop_struc_gen
+    ~binop_meth_name:"cmp"
+    ~binop_constructor:string_cmp
+    ~binop_is_result:
+      (fun [ (LT | GT) as r -> Some r | EQ -> None ])
+    ~binop_finish:EQ
+    ~binop_res_ti:ti_cmp_res__base
+;
+
+
+
+value rec eq_struc
+ : #uti -> ubox -> ubox -> bool
+ =
+  binop_struc_gen
+    ~binop_meth_name:"eq"
+    ~binop_constructor:string_eq
+    ~binop_is_result:
+      (fun [ False -> Some False | True -> None ])
+    ~binop_finish:True
+    ~binop_res_ti:ti_bool__base
+;
+
+
+class virtual ticmp_ ['a] ?cmp () =
+  object (self (* : #ticmp_register 'a *) )
+
+    method cmp
+     : 'a -> 'a -> cmp_res
+     =
+      match cmp with
+      [ None ->
+          fun x y -> cmp_struc (self :> uti) (ubox self x) (ubox self y)
+      | Some cmp ->
+          cmp
+      ]
+    ;
 
     initializer
       uti_add_meth self "cmp"
   end
 ;
 
-class virtual ticmp_ ['a] ~cmp () =
-  object (_self : #ticmp_register 'a)
-    method cmp = cmp;
-    inherit ticmp_register ['a];
-  end
-;
 
+class virtual tieq_ ['a] ?eq () =
+  object (self : #tti 'a)
 
-value check_equal_uti
- : #uti -> #uti -> unit
- = fun u1 u2 ->
-     if u1#type_id = u2#type_id
-     then ()
-     else failwith "check_equal_uti: types differ (%S <> %S)"
-            (uti_type_name u1)
-            (uti_type_name u2)
-;
-
-
-value cmp_of_compare_res = fun
-  [ 0 -> EQ
-  | x when x < 0 -> LT
-  | _ (* when x > 0 *) -> GT
-  ]
-;
-
-value string_cmp (a : string) b =
-  cmp_of_compare_res (Pervasives.compare a b)
-;
-
-
-value rec cmp_struc uti ux uy : cmp_res =
-  let () = check_equal_uti uti ux.ub_uti in
-  let () = check_equal_uti uti uy.ub_uti in
-  let fail fmt = Printf.ksprintf
-    (fun reason ->
-       failwith "structural compare failed on type %S: %s"
-         (uti_type_name uti)
-         reason
-    )
-    fmt
-  in
-  match uti#type_desc with
-  [ Simple tn -> fail "it's simple type %S" tn
-  | Sum_type destr ->
-      let (xname, xargs) = destr ux in
-      let (yname, yargs) = destr uy in
-      match string_cmp xname yname with
-      [ (LT | GT) as r -> r
-      | EQ ->
-          let args_len = Array.length xargs in
-          let yargs_len = Array.length yargs in
-          if args_len <> yargs_len
-          then
-            fail "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 EQ
-              else
-                let xarg = xargs.(i)
-                and yarg = yargs.(i) in
-                match cmp_ubox xarg yarg with
-                [ (LT | GT) as r -> r
-                | EQ -> inner (i + 1)
-                ]
+    method eq
+     : 'a -> 'a -> bool
+     =
+      match eq with
+      [ None ->
+          fun x y -> eq_struc (self :> uti) (ubox self x) (ubox self y)
+      | Some eq ->
+          eq
       ]
-
-  | Record_type destr ->
-      let xfields = destr ux in
-      let yfields = destr uy in
-      let nfields = Array.length xfields in
-      let ynfields = Array.length yfields in
-      if nfields != ynfields
-      then fail "record type destructs to different count of fields (%i <> %i)"
-             nfields ynfields
-      else
-        inner 0
-        where rec inner i =
-          if i = nfields
-          then EQ
-          else
-            let (xname, xval) = xfields.(i) in
-            let (yname, yval) = yfields.(i) in
-            if xname <> yname
-            then fail "record type should destruct to the same fields \
-                       in the same order (now: field %i: %S <> %S)"
-                      i xname yname
-            else
-              match cmp_ubox xval yval with
-              [ (LT | GT) as r -> r
-              | EQ -> inner (i + 1)
-              ]
-
-  | Dispatch_method dm ->
-      cmp_struc (dm "cmp") ux uy
-  | Lambda _ _ _ ->
-      failwith "structural compare failed on functional type"
-  ]
-
-and cmp_ubox ux uy =
-  let utix = ux.ub_uti in
-  let utiy = uy.ub_uti in
-  let () = check_equal_uti utix utiy in
-  let ucmp = get_meth_untyped "cmp" utix in
-  let ucmpy = get_meth_untyped "cmp" utiy in
-  if ucmp != ucmpy
-  then failwith "cmp_ubox failed: \"cmp\" methods must be equal"
-  else
-    uget_exn ti_cmp_res__base (u_app (u_app ucmp ux) uy)
-;
-
-(* todo: отгенерить cmp_struc на более общий случай, например,
-   eq_struc -- на "бинарные операции с указанными условиями
-   остановки"
-*)
-
-
-
-class virtual ticmp_struc ['a] =
-  object (self : #tti 'a)
-    method cmp
-     : 'a -> 'a -> cmp_res
-     = fun x y -> cmp_struc (self :> uti) (ubox self x) (ubox self y)
     ;
-  end
-;
-
-
-class virtual tieq_ ['a] ~eq () =
-  object (self : #tti 'a)
-    method eq = eq;
 
     initializer
       uti_add_meth self "eq"
         (let ti__t_bool = ti_abs (self :> tti _) ti_bool__base in
          let ti__t_t_bool = ti_abs (self :> tti _) ti__t_bool in
-         ubox ti__t_t_bool eq
+         ubox ti__t_t_bool self#eq
         )
     ;
   end
 ;
 
 
-value eq_of_opt ?eq ~cmp =
-  match eq with
-  [ None -> fun a b -> EQ == cmp a b
-  | Some eq -> eq
-  ]
-;
+class virtual tihash_ ['a] ?hash () =
+  object (self : #tti 'a)
 
-class virtual ticmpeq_ ['a] ~cmp ?eq () =
-  let eq = eq_of_opt ?eq ~cmp in
-  object
-    inherit ticmp_ ['a] ~cmp ();
-    inherit tieq_ ['a] ~eq ();
-  end
-;
-
-
-class virtual tihash_ ['a] ~hash () =
-  object (self : #tti 'a)
-    method hash = hash;
+    method hash =
+      match hash with
+      [ Some hash -> hash
+      | None -> failwith "tihash: structural hashing is not implemented now"
+      ]
+    ;
 
     initializer
       uti_add_meth self "hash"
         (let ti__t_int = ti_abs (self :> tti _) ti_int__base in
-         ubox ti__t_int hash
+         ubox ti__t_int self#hash
         )
     ;
   end
     | Some x -> x
     ] in
   object (self : #tti 'a)
+
     method show = show;
 
     initializer
 ;
 
 
-class tieq ['a] ~eq ?show type_desc =
+value eq_of_opt ~eq ~cmp =
+  match (eq, cmp) with
+  [ (None, Some cmp) -> Some (fun a b -> EQ == cmp a b)
+  | (eq, _) -> eq
+  ]
+;
+
+
+class virtual ticmpeq_ ['a] ?cmp ?eq () =
+  let eq = eq_of_opt ~eq ~cmp in
   object
-    inherit ti_type_descd ['a] type_desc;
-    inherit tieq_ ['a] ~eq ();
+    inherit ticmp_ ['a] ?cmp ();
+    inherit tieq_ ['a] ?eq ();
   end
 ;
 
-class ticmpeq ['a] ~cmp ?eq ?show type_desc =
+
+class ticmp ['a] ?cmp type_desc () =
   object
+    inherit ticmp_ ['a] ?cmp ();
     inherit ti_type_descd ['a] type_desc;
-    inherit ticmpeq_ ['a] ~cmp ?eq ();
   end
 ;
 
 
-(****)
-
-class virtual tifull_ops ['a] ~cmp ?eq ~hash ~show =
+class tieq ['a] ?eq type_desc () =
   object
-    inherit ticmpeq_ ['a] ~cmp ?eq ();
-    inherit tihash_ ['a] ~hash ();
-    inherit tishow_ ['a] ~show ();
+    inherit tieq_ ['a] ?eq ();
+    inherit ti_type_descd ['a] type_desc;
   end
 ;
 
-class tifull ['a] ~cmp ?eq ~hash ~show type_desc =
+
+class ticmpeq ['a] ?cmp ?eq type_desc () =
   object
+    inherit ticmpeq_ ['a] ?cmp ?eq ();
     inherit ti_type_descd ['a] type_desc;
-    inherit tifull_ops ['a] ~cmp ?eq ~hash ~show;
   end
 ;
 
 
+(****)
+
+class virtual tifull_ops ['a] ?cmp ?eq ?hash ?show () =
+  object
+    inherit ticmpeq_ ['a] ?cmp ?eq ();
+    inherit tihash_ ['a] ?hash ();
+    inherit tishow_ ['a] ?show ();
+  end
+;
+
+class tifull ['a] ?cmp ?eq ?hash ?show type_desc =
+  object
+    inherit ti_type_descd ['a] type_desc;
+    inherit tifull_ops ['a] ?cmp ?eq ?hash ?show ();
+  end
+;
+
+
 class tifull_on_tti ['a]
-  ~cmp ?eq ~hash ~show
+  ?cmp ?eq ?hash ?show
   ?type_desc
   (tti : #tti 'a)
  =
   object
     inherit ti_based_on ['a] ?type_desc (tti : #tti 'a);
-    inherit tifull_ops ['a] ~cmp ?eq ~hash ~show;
+    inherit tifull_ops ['a] ?cmp ?eq ?hash ?show ();
   end
 ;
 
       )
     ;
 
+    inherit ticmpeq_ ['a] ?cmp:None ?eq:None ()
+    ;
 
-    inherit ticmp_struc ['a]
-    ;
-    inherit ticmp_register ['a]
-    ;
   end
 ;
 
 ;
 
 
+(***********************************************)
+
+
 value ti_option
  : #ti 'a -> #ti (option 'a)
  = fun ti_a ->
 
 
 value timod_cmp_of_ticmp
- : #ticmp_ 'a -> (module TICMP with type t = 'a)
+ : #ticmp 'a -> (module TICMP with type t = 'a)
  = fun (type a) t ->
      let cmp = t#cmp in
      (module
   if a < b then LT else if a = b then EQ else GT
 ;
 
-value my_ti_int = new ticmpeq ~cmp:my_cmp_int (Simple "my_int")
+value my_ti_int =
+  new ticmpeq ~cmp:my_cmp_int (Simple "my_int") ()
 ;
 
 value cdt_test3 () =
 (*****)
 
 value ti_int_eq = new tieq
-  ~show:string_of_int
   ~eq:(fun x y -> 0 = Pervasives.compare x y)
   (Simple "int_eq")
+  ()
 ;
 
 value ti_int_cmp = new ticmpeq
-  ~show:string_of_int
   ~cmp:perv_cmp
   (Simple "int_cmp")
+  ()
 ;
 
 
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.