Commits

camlspotter  committed b402acc

now working? phantomz?

  • Participants
  • Parent commits 2d9e82d

Comments (0)

Files changed (12)

 # OCAMLPPFLAGS= -syntax camlp4o -package sexplib.syntax
 
 # OCamlGeneratedFiles(parser.ml lexer.ml)
+OCamlGeneratedFiles(phantomy.ml phantomy.mli)
 
 LIBFILES[] =
    base
    hashSet
    xformat
    phantom
-#   phantom2
+   phantomz
    spot
 
 LIB = spotlib
 
 MyOCamlPackage($(LIB), $(LIBFILES), $(EMPTY), $(EMPTY))
 
-# PHANTOM_GEN[] =
-#    xlist
-#    xformat
-#    gen_phantom
-# 
+PHANTOM_GEN[] =
+   xlist
+   xformat
+   gen_phantom
+
 # MyOCamlProgram(gen_phantom, $(PHANTOM_GEN))
-# 
-# phantom2.ml: phantom2_head.ml phantom2_tail.ml gen_phantom.run
-#     ./gen_phantom.run ml > $@
-# 
-# phantom2.mli: phantom2_head.mli phantom2_tail.mli gen_phantom.run
-#     ./gen_phantom.run mli > $@
-# 
-# clean:
-# 	rm -f phantom2.ml phantom2.mli
+
+PHANTOMY_GEN[] =
+   xlist
+   xformat
+   gen_phantomy
+
+MyOCamlProgram(gen_phantomy, $(PHANTOMY_GEN))
+
+phantomy.ml: phantomy_head.ml gen_phantomy.run
+	./gen_phantomy.run ml > $@
+
+phantomy.mli: phantomy_head.mli gen_phantomy.run
+	./gen_phantomy.run mli > $@
+
+PHANTOMZ_GEN[] =
+   xlist
+   xformat
+   gen_phantomz
+
+MyOCamlProgram(gen_phantomz, $(PHANTOMZ_GEN))
+
+phantomz.ml: phantomz_head.ml gen_phantomz.run
+	./gen_phantomz.run ml > $@
+
+phantomz.mli: phantomz_head.mli gen_phantomz.run
+	./gen_phantomz.run mli > $@
+
 
 let (^.) f g = fun x -> f (g x)
 let (^$) f x = f x
+

File gen_phantomy.ml

+open Format
+open Xformat
+open Xlist
+
+let argtype ppf n = fprintf ppf "('p%d, 'c) t" n
+
+let arguments ppf = function
+  | 0 -> fprintf ppf "()"
+  | n -> 
+      (list (fun ppf -> fprintf ppf " ")
+        (fun ppf i -> fprintf ppf "(t%d : %a)" i argtype i)) ppf
+        (from_to 1 n)
+
+let typ_tsn name ppf = function
+  | 0 -> fprintf ppf "'%s ts0" name
+  | n ->
+      fprintf ppf "(%a, '%s) ts%d"
+        (list (fun ppf -> fprintf ppf ", ")
+           (fun ppf i -> fprintf ppf "'p%d" i)) (from_to 1 n)
+        name
+        n
+
+let typ_get ppf = function
+  | 0 -> fprintf ppf "unit"
+  | n -> (list (fun ppf -> fprintf ppf " * ") argtype) ppf (from_to 1 n)
+
+let typ ppf n =
+  fprintf ppf "type %a = <@." (typ_tsn "c") n;
+  fprintf ppf "  list : 'c list;@.";
+  fprintf ppf "  array : 'c array;@.";
+  fprintf ppf "  get : %a;@." typ_get n;
+  for i = 1 to n do
+    fprintf ppf "  get%d : %a;@." i argtype i
+  done;
+  (* fprintf ppf "  map : 'd. ('c -> 'd) -> %a@." (typ_tsn "d") n; *)
+  fprintf ppf ">@.@."
+
+let def ppf n =
+  fprintf ppf "let c%d %a : %a = object@." n arguments n (typ_tsn "c") n;
+  fprintf ppf "  inherit ['c] ts [%a]@."
+    (list (fun ppf -> fprintf ppf "; ")
+       (fun ppf i -> fprintf ppf "t%d" i))
+    (from_to 1 n);
+  fprintf ppf "  method get = (%a)@."
+    (list (fun ppf -> fprintf ppf ", ")
+       (fun ppf i -> fprintf ppf "t%d" i))
+    (from_to 1 n);
+  for i = 1 to n do
+    fprintf ppf "  method get%d = t%d@." i i
+  done;
+  fprintf ppf "end@.@."
+
+let sig_ ppf n =
+  fprintf ppf "val c%d : %a -> %a@.@." 
+    n
+    (if n = 0 then fun ppf _ -> fprintf ppf "unit"
+     else list (fun ppf -> fprintf ppf " -> ") argtype) (from_to 1 n)
+    (typ_tsn "c") n
+
+(* 
+type ('p1, ... 'pX, 'c) tsX = object
+   list : 'c list
+   array : 'c array
+   get : ...
+   getn : ...
+end
+
+let cX (t1 : ('p1, 'c) t) .. = object
+  inherit unknowns [t1; ... ]
+  method get = (t1, ..., tn)
+  method get1 = t1
+  ...
+end
+*)
+ 
+let max = 10
+
+let cat fn =
+  let ic = open_in fn in
+  let rec loop () =
+    let l = input_line ic in
+    printf "%s\n" l;
+    loop ()
+  in
+  try loop () with _ -> close_in ic
+
+let _ =
+  Arg.parse [] (function 
+    | "ml" ->
+        printf "(* This is an autogenerated file. Do not edit. *)@.@.";
+        cat "phantomy_head.ml";
+        for i = 0 to max do
+          typ stdout i;
+          def stdout i
+        done;
+    | "mli" ->
+        printf "(* This is an autogenerated file. Do not edit. *)@.@.";
+        cat "phantomy_head.mli";
+        for i = 0 to max do
+          typ stdout i;
+          sig_ stdout i
+        done;
+    | _ -> failwith "give ml or mli")
+    "gen_phantom [ml|mli]"
+
+
+  

File gen_phantomz.ml

+open Format
+open Xformat
+open Xlist
+
+(*
+      unit
+      'a1 * unit
+      'a1 * ('a2 * unit)
+      'a1 * ('a2 * ('a3 * unit))
+*)
+let tpl_exp last ppf n = 
+  let rec tpl x ppf = function
+    | 0 -> fprintf ppf last
+    | n -> fprintf ppf "('a%d * %a)" x (tpl (x+1)) (n-1) 
+  in
+  tpl 1 ppf n
+
+let tpl ppf = function
+  | 0 -> fprintf ppf "tpl0"
+  | 1 -> fprintf ppf "'a1 tpl1"
+  | n -> 
+      fprintf ppf "(%a) tpl%d"
+        (list (fun ppf -> fprintf ppf ",")
+           (fun ppf i -> fprintf ppf "'a%d" i)) (from_to 1 n)
+        n
+
+let tpl_def ppf = function
+  | 0 -> fprintf ppf "type tpl0 = unit@."
+  | 1 -> fprintf ppf "type %a = %a@." tpl 1 (tpl_exp "unit") 1
+  | n -> 
+      fprintf ppf "type %a = %a@."
+        tpl n
+        (tpl_exp "unit") n
+
+let sig_ ppf n =
+  fprintf ppf "val c%d : %a(%a,'cont) ts@."
+    n
+    (list (fun _ppf -> ())
+       (fun ppf i -> fprintf ppf "('a%d,'cont) t -> " i)) (from_to 1 n)
+    tpl n
+ 
+let sig_d ppf n =
+  fprintf ppf "val d%d : (%a,'cont) ts -> %a@."
+    n
+    tpl n
+    (list (fun ppf -> fprintf ppf " * ")
+       (fun ppf i -> fprintf ppf "('a%d, 'cont) t" i)) (from_to 1 n)
+ 
+let sig_get ppf n =
+  fprintf ppf "val get%d : (%a, 'cont) ts -> ('a%d, 'cont) t@."
+    n
+    (tpl_exp "_") n
+    n
+ 
+let max = 10
+
+let cat fn =
+  let ic = open_in fn in
+  let rec loop () =
+    let l = input_line ic in
+    printf "%s\n" l;
+    loop ()
+  in
+  try loop () with _ -> close_in ic
+
+let _ =
+  Arg.parse [] (function 
+    | "ml" ->
+        printf "(* This is an autogenerated file. Do not edit. *)@.@.";
+        cat "phantomz_head.ml";
+        for i = 0 to max do
+          tpl_def stdout i
+        done;
+    | "mli" ->
+        printf "(* This is an autogenerated file. Do not edit. *)@.@.";
+        cat "phantomz_head.mli";
+        for i = 0 to max do
+          tpl_def stdout i
+        done;
+        for i = 0 to max do
+          sig_ stdout i
+        done;
+        for i = 1 to max do
+          sig_d stdout i
+        done;
+        for i = 1 to max do
+          sig_get stdout i
+        done;
+    | _ -> failwith "give ml or mli")
+    "gen_phantom [ml|mli]"
+
+
+  
 type ('phantom, 'cont) t
-type ('phantom, 'cont) ts
 
 (* Rather than open Phantom, I recommend to open Phantom.Open *)
 module Open : sig
 
 val unsafe : 'cont -> ('unsafe, 'cont) t
 (** [unsafe v] lifts up [v] of [elt] to one with any phantom. Use with care. *)
-val unsafe_list : 'cont list -> ('unsafe, 'cont) ts
-(** [unsafe_list ls] lifts up [ls] of [elt list] to a list with any phantom. Use with care. *)
 val magic : ('a, 'cont) t -> ('unsafe, 'cont) t
 (** [magic v] changes the phantom ov [v]. Use with care. *)
 
+type ('phantom, 'cont) ts
+  (* phantom heterogeneous 'cont list *)
+
+val unsafe_list : 'cont list -> ('unsafe, 'cont) ts
+(** [unsafe_list ls] lifts up [ls] of [elt list] to a list with any phantom. Use with care. *)
 val to_list : ('a, 'cont) ts -> 'cont list
 val to_unknown_list : ('a, 'cont) ts -> (unknown, 'cont) t list
 val to_array : ('a, 'cont) ts -> 'cont array

File phantomy_head.ml

+type ('phantom, 'content) t = 'content
+
+module Open = struct
+  type unknown
+  let unknown : unknown = Obj.magic 0
+  let (!<) x = x
+  let (!>) x = x
+  let (!?) x = x
+end
+include Open
+let unsafe x = x
+let magic x = x
+
+class ['content] ts (ls : 'content list) = object
+  method list = ls
+  method array = Array.of_list ls
+end
+
+let to_list (v : 'c #ts) = v#list
+let to_unknown_list (v : 'c #ts) = v#list
+let to_array (v : 'c #ts) = v#array
+let to_unknown_array (v : 'c #ts) = v#array
+let of_unknown_list (vs : (unknown, 'c) t list) : 'c ts = new ts vs
+let of_unknown_array (vs : (unknown, 'c) t array) : 'c ts = new ts (Array.to_list vs)
+let of_list (vs : 'c list) : 'c ts = new ts vs
+let of_array (vs : 'c array) : 'c ts = new ts (Array.to_list vs)
+
+let length (v : 'c #ts) = List.length v#list
+

File phantomy_head.mli

+type ('phantom, 'cont) t
+
+(* Rather than open Phantom, I recommend to open Phantom.Open *)
+module Open : sig
+  type unknown 
+  val unknown : unknown
+  val (!<) : ('a, 'cont) t -> 'cont
+  (** Forget the phantom *)
+  val (!>) : 'cont -> (unknown, 'cont) t
+  (** Safe lift up with the unknown phantom *)
+  val (!?) : ('a, 'cont) t -> (unknown, 'cont) t
+  (** Forget the phantom *)
+end
+type unknown = Open.unknown
+val unknown : Open.unknown
+val (!<) : ('a, 'cont) t -> 'cont
+val (!>) : 'cont -> (unknown, 'cont) t
+val (!?) : ('a, 'cont) t -> (unknown, 'cont) t
+
+val unsafe : 'cont -> ('unsafe, 'cont) t
+(** [unsafe v] lifts up [v] of [elt] to one with any phantom. Use with care. *)
+val magic : ('a, 'cont) t -> ('unsafe, 'cont) t
+(** [magic v] changes the phantom ov [v]. Use with care. *)
+
+class ['a] ts : 'a list -> object method array : 'a array method list : 'a list end
+  (* phantom heterogeneous 'cont list, the base class *)
+
+(** [unsafe_list ls] lifts up [ls] of [elt list] to a list with any phantom. Use with care. *)
+val to_list : 'cont #ts -> 'cont list
+val to_unknown_list : 'cont #ts -> (unknown, 'cont) t list
+val to_array : 'cont #ts -> 'cont array
+val to_unknown_array : 'cont #ts -> (unknown, 'cont) t array
+val of_unknown_list : (unknown, 'cont) t list -> 'cont ts
+val of_unknown_array : (unknown, 'cont) t array -> 'cont ts
+val of_list : 'cont list -> 'cont ts
+val of_array : 'cont array -> 'cont ts
+val length : 'cont #ts -> int
+

File phantomz_head.ml

+type ('phantom, 'content) t = 'content
+type ('phantom, 'content) ts = 'content list
+
+module Open = struct
+  type unknown
+  let unknown : unknown = Obj.magic 0
+  let (!<) x = x
+  let (!>) x = x
+  let (!?) x = x
+end
+include Open
+let unsafe x = x
+let unsafe_list x = x
+let magic x = x
+
+let to_list v = v
+let to_unknown_list v = v
+let to_array = Array.of_list
+let to_unknown_array = Array.of_list
+let of_unknown_list v = v
+let of_unknown_array = Array.to_list
+let unsafe_of_list v = v
+let unsafe_of_array = Array.to_list
+
+let length = List.length 
+
+let c0 = []
+let c1 t = [t]
+let c2 t1 t2 = [t1; t2]
+let c3 t1 t2 t3 = [t1; t2; t3]
+let c4 t1 t2 t3 t4 = [t1; t2; t3; t4]
+let c5 t1 t2 t3 t4 t5 = [t1; t2; t3; t4; t5]
+let c6 t1 t2 t3 t4 t5 t6 = [t1; t2; t3; t4; t5; t6]
+let c7 t1 t2 t3 t4 t5 t6 t7 = [t1; t2; t3; t4; t5; t6; t7]
+let c8 t1 t2 t3 t4 t5 t6 t7 t8 = [t1; t2; t3; t4; t5; t6; t7; t8]
+let c9 t1 t2 t3 t4 t5 t6 t7 t8 t9 = [t1; t2; t3; t4; t5; t6; t7; t8; t9]
+let c10 t1 t2 t3 t4 t5 t6 t7 t8 t9 t10 = [t1; t2; t3; t4; t5; t6; t7; t8; t9; t10]
+
+let d1 = function [t] -> t | _ -> assert false
+let d2 = function [t1; t2] -> (t1, t2) | _ -> assert false
+let d3 = function [t1; t2; t3] -> (t1, t2, t3) | _ -> assert false
+let d4 = function [t1; t2; t3; t4] -> (t1, t2, t3, t4) | _ -> assert false
+let d5 = function [t1; t2; t3; t4; t5] -> (t1, t2, t3, t4, t5) | _ -> assert false
+let d6 = function [t1; t2; t3; t4; t5; t6] -> (t1, t2, t3, t4, t5, t6) | _ -> assert false
+let d7 = function [t1; t2; t3; t4; t5; t6; t7] -> (t1, t2, t3, t4, t5, t6, t7) | _ -> assert false
+let d8 = function [t1; t2; t3; t4; t5; t6; t7; t8] -> (t1, t2, t3, t4, t5, t6, t7, t8) | _ -> assert false
+let d9 = function [t1; t2; t3; t4; t5; t6; t7; t8; t9] -> (t1, t2, t3, t4, t5, t6, t7, t8, t9) | _ -> assert false
+let d10 = function [t1; t2; t3; t4; t5; t6; t7; t8; t9; t10] -> (t1, t2, t3, t4, t5, t6, t7, t8, t9, t10) | _ -> assert false
+
+let get1 l = List.nth l 1
+let get2 l = List.nth l 2
+let get3 l = List.nth l 3
+let get4 l = List.nth l 4
+let get5 l = List.nth l 5
+let get6 l = List.nth l 6
+let get7 l = List.nth l 7
+let get8 l = List.nth l 8
+let get9 l = List.nth l 9
+let get10 l = List.nth l 10
+

File phantomz_head.mli

+type ('phantom, 'cont) t
+
+(* Rather than open Phantom, I recommend to open Phantom.Open *)
+module Open : sig
+  type unknown 
+  val unknown : unknown
+  val (!<) : ('a, 'cont) t -> 'cont
+  (** Forget the phantom *)
+  val (!>) : 'cont -> (unknown, 'cont) t
+  (** Safe lift up with the unknown phantom *)
+  val (!?) : ('a, 'cont) t -> (unknown, 'cont) t
+  (** Forget the phantom *)
+end
+type unknown = Open.unknown
+val unknown : Open.unknown
+val (!<) : ('a, 'cont) t -> 'cont
+val (!>) : 'cont -> (unknown, 'cont) t
+val (!?) : ('a, 'cont) t -> (unknown, 'cont) t
+
+val unsafe : 'cont -> ('unsafe, 'cont) t
+(** [unsafe v] lifts up [v] of [elt] to one with any phantom. Use with care. *)
+val magic : ('a, 'cont) t -> ('unsafe, 'cont) t
+(** [magic v] changes the phantom ov [v]. Use with care. *)
+
+type ('phantom, 'cont) ts
+  (* phantom heterogeneous 'cont list *)
+
+val unsafe_list : 'cont list -> ('unsafe, 'cont) ts
+(** [unsafe_list ls] lifts up [ls] of [elt list] to a list with any phantom. Use with care. *)
+val to_list : ('a, 'cont) ts -> 'cont list
+val to_unknown_list : ('a, 'cont) ts -> (unknown, 'cont) t list
+val to_array : ('a, 'cont) ts -> 'cont array
+val to_unknown_array : ('a, 'cont) ts -> (unknown, 'cont) t array
+val of_unknown_list : (unknown, 'cont) t list -> (unknown, 'cont) ts
+val of_unknown_array : (unknown, 'cont) t array -> (unknown, 'cont) ts
+val unsafe_of_list : 'cont list -> ('unsafe, 'cont) ts
+val unsafe_of_array : 'cont array -> ('unsafe, 'cont) ts
+val length : ('a, 'cont) ts -> int
+
+(* This encoding is correct only if the parameter cannot be the unit or a tuple *)
   include Xformat
 end
 
-(* module Phantom_intf = Phantom_intf *)
-module Phantom = Phantom
+module Phantom = Phantomz
 
 type t = formatter
 
+let stdout = std_formatter
+let stderr = err_formatter
+
 let rec list sep f ppf = function
   | [] -> ()
   | [x] -> f ppf x
 open Format
 
 type t = formatter
+
+val stdout : t
+val stderr : t
+
 val list : (t -> unit) -> (t -> 'a -> unit) -> t -> 'a list -> unit