Source

cadastr / src / cd_Typeinfo.ml

Full commit
module Typeinfo
 =
  struct

    open Cdt;

    value ti_no_type_id = Type_id.next ()
    ;

    value ti_no : ti 'a
     =
      let type_name = "no_type" in
      let type_desc = Simple "no_type" in
      let type_id = ti_no_type_id in
      object
        method type_id = type_id;
        method type_name = type_name;
        method type_desc = type_desc;
        method meths =
          failwith "Typeinfo.ti_no#meths: can't use methods of ti_no"
        ;

        method put_func _ =
          failwith "Typeinfo.ti_no#put_func: no storage"
        ;

        method get_exn _ = 
          failwith "Typeinfo.ti_no#get_exn: no_storage"
        ;
      end
    ;



    module No
     =
      struct
        value no meth =
          raise (No meth (ti_no :> uti))
        ;

        value eq
         : 'a -> 'a -> bool
         = fun _ _ ->
             no "eq"
        ;

        value cmp
         : 'a -> 'a -> cmp_res
         = fun _ _ ->
             no "cmp"
        ;

      end
    ;


    value entype_eq
     : #ti 'a -> ubox -> ('a -> 'a -> bool)
     = fun ta uf ->
         entype_func2 ta ta ti_bool__base uf
    ;


    value get_meth_eq_untyped
     : #ti 'a -> ubox
     = fun ta ->
         get_meth_untyped "eq" ta
    ;


    value get_meth_eq
     : #ti 'a -> ('a -> 'a -> bool)
     = fun ta ->
         try
           entype_eq ta (get_meth_eq_untyped ta)
         with
         [ No_meth -> No.eq
         | e -> raise e
         ]
    ;


    value get_meth_cmp_untyped
     : #ti 'a -> ubox
     = fun ti ->
         get_meth_untyped "cmp" ti
    ;


    value entype_cmp
     : #ti 'a -> ubox -> ('a -> 'a -> cmp_res)
     = fun ti uf ->
         entype_func2 ti ti ti_cmp_res__base uf
    ;


    value get_meth_cmp
     : #ti 'a -> ('a -> 'a -> cmp_res)
     = fun ta ->
         try
           entype_cmp ta (get_meth_cmp_untyped ta)
         with
         [ No_meth -> No.cmp
         | e -> raise e
         ]
    ;


    value get_meth_eq_same
     : #ti 'a -> #ti 'a -> ('a -> 'a -> bool)
     = fun ta1 ta2 ->
         let uf1 = get_meth_eq_untyped ta1
         and uf2 = get_meth_eq_untyped ta2 in
         if uf1 != uf2
         then
           failwith "Cdt.get_meth_eq_same: both 'eq' methods should be equal"
         else
           entype_eq ta1 uf1
    ;


    (**********)


    value cmp_of_compare compare =
      fun a b ->
        match compare a b with
        [ 0 -> EQ
        | x when x < 0 -> LT
        | _ -> GT
        ]
    ;

    value perv_cmp = fun x y ->
      match Pervasives.compare x y with
      [ 0 -> EQ
      | x when x < 0 -> LT
      | _ -> GT
      ]
    ;

    value perv_hash = Hashtbl.hash;


    (*********************)

    (* [?eq] is derived from [~cmp] if not specified *)

    (* receives all possible functions; could be changed in every new version.
       [?eq] is derived from [~cmp] if not specified

    value tifull ~cmp ?eq ~hash ~show ?(type_desc=Simple) () =


    value ttuple2 (ti1 : #ti _) (ti2 : #ti _) =


    value ti_option (ti : #ti _) =
      let ti : tiall _ = ti#tiopt in
      ((
      tifull
        ~cmp:(fun a b ->
                match (a, b) with
                [ (None, None) -> EQ
                | (None, Some _) -> LT
                | (Some _, None) -> GT
                | (Some va, Some vb) -> ti#cmp va vb
                ])
        ~eq:(fun a b ->
               match (a, b) with
               [ (None, None) -> True
               | (Some _, None) | (None, Some _) -> False
               | (Some va, Some vb) -> ti#eq va vb
               ])
        ~hash:(fun a ->
                 match a with
                 [ None -> 0
                 | Some va -> ti#hash va
                 ])
        ~show:(fun a ->
                 match a with
                 [ None -> "None"
                 | Some va -> Printf.sprintf "(Some %s)" (ti#show va)
                 ])
        ()
      ) :> ti _)
    ;


    *)



(*
    вроде бы достаточно только подставить правильный type_desc
    для работы этого:

    value ti_option2 (ti_a : #ti _) =
      ti_sum_type ~name:"option" ~params:[ti_a] & fun
      [ None -> ti_variant "None" [| |]
      | Some v_a -> ti_variant "Some" [| ubox ti_a v_a |]
      ]
    ;
*)



(* старье:
    open Cd_Ops;
    open Printf;

    value rec timono_cmp
     : timono -> (ubox -> ubox -> cmp_res)
     = fun ti ->
         let r = ti#type_desc in
         let type_name = "<unknown>" (* todo: add type names *) in
         let o = ti#on_storage in
         let module O = (value o : ON_STORAGE) in
         match r with
         [ Simple ->
             fun a b ->
               use2 ~o (fun () -> O.opt_cmp 0 1) a b
 
         | Sum_type destruct_sum_type ->
             fun a b ->
               let (vn1, args1) = use1 ~o destruct_sum_type a
               and (vn2, args2) = use1 ~o destruct_sum_type b in
               match compare vn1 vn2 with
               [ 0 ->
                   let len = Array.length args1 in
                   if len <> Array.length args2
                   then
                     type_error & sprintf
                       "cmp on sum type %S: different count of args"
                       type_name
                   else
                     inner 0
                     where rec inner i =
                       if i = len
                       then EQ
                       else
                         let a = args1.(i)
                         and b = args2.(i) in
                         let r1 = a.ub_timono
                         and r2 = b.ub_timono in
                         if r1 != r2
                         then
                           type_error & sprintf
                             "cmp on sum type %S, argument %i: \
                                rtti doesn't match"
                             type_name i
                         else
                           match timono_cmp r1 a b with
                           [ EQ -> inner (i + 1)
                           | (LT | GT) as r -> r
                           ]
               | x when x > 0 -> GT
               | _ (* when _ < 0 *) -> LT
               ]

         | Dispatch_method dm ->
             timono_cmp (dm `Cmp)

         | Record_type destruct_record ->
             fun a b ->
               let fields1 = use1 ~o destruct_record a
               and fields2 = use1 ~o destruct_record b in
               let len = Array.length fields1 in
               if len <> Array.length fields2
               then
                 type_error & sprintf "cmp on record type %S: \
                     different count of fields"
                   type_name
               else
                 inner 0
                 where rec inner i =
                   if i = len
                   then EQ
                   else
                     let (fn1, fv1) = fields1.(i)
                     and (fn2, fv2) = fields2.(i) in
                     if fn1 <> fn2
                     then
                       type_error & sprintf "cmp on record type %S: \
                           different names/order of fields"
                         type_name
                     else
                       let t = fv1.ub_timono in
                       if t != fv2.ub_timono
                       then
                         type_error & sprintf "cmp on record type %S, \
                             argument %i: \
                             rtti doesn't match"
                           type_name
                           i
                       else
                         timono_cmp t fv1 fv2
         ]
    ;


    value ti_option2_hiding (ti_a : #ti _) =
      ti_sum_type ~name:"option" ~params:[ti_a] & fun
      [ None -> ti_variant "None" [| |]
      | Some v_a -> ti_methods & fun
          [ "show" -> ti_variant "Some" [| ubox ti_string "<hidden>" |]
          | _ -> ti_variant "Some" [| ubox ti_a v_a |]
          ]
      ]
    ;

*)


  end  (* Typeinfo *)
;