Commits

camlspotter committed 8198498

added _oasis

Comments (0)

Files changed (54)

+(* OASIS_START *)
+(* DO NOT EDIT (digest: 63582a408b9848b727b92904ac3074af) *)
+Authors of spotlib
+Jun FURUSE
+(* OASIS_STOP *)
+(* OASIS_START *)
+(* DO NOT EDIT (digest: fb82508623e0069befe576119f42f4a5) *)
+This is the INSTALL file for the spotlib distribution.
+
+This package uses OASIS to generate its build system. See section OASIS for
+full information. 
+
+Dependencies
+============
+
+In order to compile this package, you will need:
+* ocaml
+* findlib
+
+Installing
+==========
+
+1. Uncompress source directory and got to the root of the package
+2. Run 'ocaml setup.ml -configure'
+3. Run 'ocaml setup.ml -build'
+4. Run 'ocaml setup.ml -install'
+
+Uninstalling
+============
+
+1. Go to the root of the package 
+2. Run 'ocaml setup.ml -uninstall'
+
+OASIS
+=====
+
+OASIS is a software that helps to write setup.ml using a simple '_oasis'
+configuration file. The generated setup only depends on standard OCaml
+installation, no additional library is required.
+
+(* OASIS_STOP *)

META

-name="spotlib"
-version="0.0.1"
-description="Spotter's garbages"
-requires="unix"
-archive(byte)="spotlib.cmo"
-archive(native)="spotlib.cmx"
-linkopts = ""
    include OMyMakefile
    export
 
-OCAMLINCLUDES +=
-
-OCAMLFLAGS    += -annot -w Ae
-OCAMLCFLAGS   +=
-OCAMLOPTFLAGS +=
-OCAML_LINK_FLAGS +=
-OCAML_BYTE_LINK_FLAGS +=
-OCAML_NATIVE_LINK_FLAGS +=
-
-# CAMLP4PACKS[]=
-#     sexplib
-# 
-OCAMLPACKS[]= unix
-
-# 
-# OCAMLDEPFLAGS= -syntax camlp4o -package sexplib.syntax
-# OCAMLPPFLAGS= -syntax camlp4o -package sexplib.syntax
-
-# OCamlGeneratedFiles(parser.ml lexer.ml)
-OCamlGeneratedFiles(phantomy.ml phantomy.mli)
-
-LIBFILES[] =
-   base
-   monad_intf
-   monad
-   option
-   xlist
-   hashSet
-   xformat
-   xhashtbl
-   xstring
-   phantom
-   weaktbl
-   spot
-
-LIB = spotlib
-
-MyOCamlPackage($(LIB), $(LIBFILES), $(EMPTY), $(EMPTY))
-
-PHANTOM_GEN[] =
-   xlist
-   xformat
-   gen_phantom
-
-MyOCamlProgram(gen_phantom, $(PHANTOM_GEN))
-
-phantom.ml: phantom_head.ml gen_phantom.run
-	./gen_phantom.run ml > $@
-
-phantom.mli: phantom_head.mli gen_phantom.run
-	./gen_phantom.run mli > $@
-
+Subdirs()
+OASISFormat: 0.2
+Name:        spotlib
+Version:     1.0.0
+Synopsis:    Camlspotter's personal library
+Authors:     Jun FURUSE
+License:     LGPL-2.0 with OCaml linking exception
+Plugins:      StdFiles (0.2)
+BuildType:    Custom (0.2)
+XCustomBuild: omake
+XCustomInstall: omake install
+
+Library spotlib
+  Path:          lib
+  FindlibName:   spotlib
+  Modules:       Base,
+                 Monad_intf,
+                 Monad,
+                 Option,
+                 Xlist,
+                 HashSet,
+                 Xformat,
+                 Xhashtbl,
+                 Xstring,
+                 Phantom,
+                 Weaktbl,
+                 Spot
+  BuildDepends:  unix

base.ml

-let failwithf fmt = Printf.kprintf failwith fmt
-
-let memoize f =
-  let cache = Hashtbl.create 101 in
-  fun v -> try Hashtbl.find cache v with Not_found ->
-    let r = f v in
-    Hashtbl.replace cache v r;
-    r
-
-let (^.) f g = fun x -> f (g x)
-let (^$) f x = f x
-
-let protect f a ~finally =
-  match try `Ok (f a) with e -> `Exn e with
-  | `Ok v -> finally (); v
-  | `Exn e -> finally (); raise e
-
-let with_time f v =
-  let start = Unix.gettimeofday () in
-  let res = f v in
-  let end_ = Unix.gettimeofday () in
-  res, end_ -. start
-

base.mli

-val failwithf : ('a, unit, string, 'b) format4 -> 'a
-
-val memoize : ('c -> 'd) -> 'c -> 'd
-
-val (^.) : ('b -> 'c) -> ('a -> 'b) -> ('a -> 'c)
-  (** funciton composition: Haskell's (.) *)
-val (^$) : ('a -> 'b) -> 'a -> 'b
-  (** Haskell's ($) *)
-
-val protect : ('a -> 'b) -> 'a -> finally: (unit -> unit) -> 'b
-
-val with_time : ('a -> 'b) -> 'a -> 'b * float
-  (** simple profiling *)
- 

gen_phantom.ml

-open Format
-open Xformat
-open Xlist
-
-let def_c ppf n = 
-  fprintf ppf "let c%d %a = [%a]@."
-    n
-    (list (fun ppf -> fprintf ppf " ")
-       (fun ppf i -> fprintf ppf "t%d" i)) (from_to 0 (n-1))
-    (list (fun ppf -> fprintf ppf "; ")
-       (fun ppf i -> fprintf ppf "t%d" i)) (from_to 0 (n-1))
-
-let def_d ppf n = 
-  fprintf ppf "let d%d = function [%a] -> (%a) | _ -> assert false@."
-    n
-    (list (fun ppf -> fprintf ppf "; ")
-       (fun ppf i -> fprintf ppf "t%d" i)) (from_to 0 (n-1))
-    (list (fun ppf -> fprintf ppf ", ")
-       (fun ppf i -> fprintf ppf "t%d" i)) (from_to 0 (n-1))
-
-let def_get ppf n = fprintf ppf "let get%d l = List.nth l %d@." n n
-
-(*
-      unit
-      'a0 * unit
-      'a0 * ('a1 * unit)
-      'a0 * ('a1 * ('a2 * unit))
-*)
-let type_tpl last ppf n = 
-  let rec tpl x ppf = function
-    | 0 -> fprintf ppf last
-    | n -> fprintf ppf "('a%d * %a)" (x - 1) (tpl (x+1)) (n-1) 
-  in
-  tpl 1 ppf n
-
-let exp_tpl ppf = function
-  | 0 -> fprintf ppf "tpl0"
-  | 1 -> fprintf ppf "'a0 tpl1"
-  | n -> 
-      fprintf ppf "(%a) tpl%d"
-        (list (fun ppf -> fprintf ppf ",")
-           (fun ppf i -> fprintf ppf "'a%d" i)) (from_to 0 (n-1))
-        n
-
-let def_tpl ppf = function
-  | 0 -> fprintf ppf "type tpl0 = unit@."
-  | 1 -> fprintf ppf "type %a = %a@." exp_tpl 1 (type_tpl "unit") 1
-  | n -> 
-      fprintf ppf "type %a = %a@."
-        exp_tpl n
-        (type_tpl "unit") n
-
-let sig_c ppf n =
-  fprintf ppf "val c%d : %a(%a,'c) ts@."
-    n
-    (list (fun _ppf -> ())
-       (fun ppf i -> fprintf ppf "('a%d,'c) t -> " i)) (from_to 0 (n-1))
-    exp_tpl n
- 
-let sig_d ppf n =
-  fprintf ppf "val d%d : (%a,'c) ts -> %a@."
-    n
-    exp_tpl n
-    (list (fun ppf -> fprintf ppf " * ")
-       (fun ppf i -> fprintf ppf "('a%d,'c) t" i)) (from_to 0 (n-1))
- 
-let sig_get ppf n =
-  fprintf ppf "val get%d : (%a,'c) ts -> ('a%d,'c) t@."
-    (n - 1)
-    (type_tpl "_") n
-    (n - 1)
-
-let sig_uncurry ppf = function
-  | 0 -> fprintf ppf "val uncurry0 : (unit -> 'z) -> ((tpl0, 'c) ts -> 'z)@."
-  | n ->
-      fprintf ppf "val uncurry%d : (%a -> 'z) -> ((%a, 'c) ts -> 'z)@."
-        n
-        (list (fun ppf -> fprintf ppf " -> ")
-           (fun ppf i -> fprintf ppf "('a%d,'c) t" i)) (from_to 0 (n-1))
-        exp_tpl n
-
-let def_uncurry ppf = function
-  | 0 -> fprintf ppf "let uncurry0 f _tpl = f ()@."
-  | n ->
-      fprintf ppf "let uncurry%d f tpl = f %a@."
-        n
-        (list (fun ppf -> fprintf ppf " ")
-           (fun ppf i -> fprintf ppf "(get%d tpl : ('a%d,'c) t)" i i)) (from_to 0 (n-1))
-
-let sig_curry ppf = function
-  | 0 -> fprintf ppf "val curry0 : ((tpl0,'c) ts -> 'z) -> unit -> 'z@."
-  | n ->
-      fprintf ppf "val curry%d : ((%a,'c) ts -> 'z) -> (%a -> 'z)@."
-        n
-        exp_tpl n
-        (list (fun ppf -> fprintf ppf " -> ")
-           (fun ppf i -> fprintf ppf "('a%d,'c) t" i)) (from_to 0 (n-1))
-
-let def_curry ppf = function
-  | 0 -> fprintf ppf "let curry0 f () = f c0@."
-  | n ->
-      fprintf ppf "let curry%d f %a = f (c%d %a)@."
-        n
-        (list (fun ppf -> fprintf ppf " ")
-           (fun ppf i -> fprintf ppf "(v%d : ('a%d,'c) t)" i i)) (from_to 0 (n-1))
-        n
-        (list (fun ppf -> fprintf ppf " ")
-           (fun ppf i -> fprintf ppf "v%d" i)) (from_to 0 (n-1))
-
-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 "phantom_head.ml";
-        for i = 0 to max do
-          def_c stdout i
-        done;
-        fprintf stdout "@.";
-        for i = 0 to max do
-          def_d stdout i
-        done;
-        fprintf stdout "@.";
-        for i = 0 to max do
-          def_get stdout i
-        done;
-        fprintf stdout "@.";
-        for i = 0 to max do
-          def_tpl stdout i
-        done;
-        fprintf stdout "@.";
-        for i = 0 to max do
-          def_uncurry stdout i
-        done;
-        fprintf stdout "@.";
-        for i = 0 to max do
-          def_curry stdout i
-        done;
-        fprintf stdout "@.";
-        cat "phantom_tail.ml";
-    | "mli" ->
-        printf "(* This is an autogenerated file. Do not edit. *)@.@.";
-        cat "phantom_head.mli";
-        for i = 0 to max do
-          def_tpl stdout i
-        done;
-        fprintf stdout "@.";
-        for i = 0 to max do
-          sig_c stdout i
-        done;
-        fprintf stdout "@.";
-        for i = 1 to max do
-          sig_d stdout i
-        done;
-        fprintf stdout "@.";
-        for i = 1 to max do
-          sig_get stdout i
-        done;
-        fprintf stdout "@.";
-        for i = 0 to max do
-          sig_uncurry stdout i
-        done;
-        fprintf stdout "@.";
-        for i = 0 to max do
-          sig_curry stdout i
-        done;
-    | _ -> failwith "give ml or mli")
-    "gen_phantom [ml|mli]"

hashSet.ml

-type 'a t = ('a, unit) Hashtbl.t (* poorman's implementation *)
-let create = Hashtbl.create
-let mem = Hashtbl.mem
-let add t k = if not (mem t k) then Hashtbl.add t k ()
-let remove = Hashtbl.remove
-

hashSet.mli

-(* Poorman's implementation of polymorphic hash set *)
-type 'a t
-val create : int -> 'a t
-val mem : 'a t -> 'a -> bool
-val add : 'a t -> 'a -> unit
-val remove : 'a t -> 'a -> unit
-
+name="spotlib"
+version="1.0.0"
+description="Spotter's garbages"
+requires="unix"
+archive(byte)="spotlib.cmo"
+archive(native)="spotlib.cmx"
+linkopts = ""
+OCAMLINCLUDES +=
+
+OCAMLFLAGS    += -annot -w Ae
+OCAMLCFLAGS   +=
+OCAMLOPTFLAGS +=
+OCAML_LINK_FLAGS +=
+OCAML_BYTE_LINK_FLAGS +=
+OCAML_NATIVE_LINK_FLAGS +=
+
+OCAMLPACKS[]= unix
+
+# OCAMLDEPFLAGS= -syntax camlp4o -package sexplib.syntax
+# OCAMLPPFLAGS= -syntax camlp4o -package sexplib.syntax
+
+# OCamlGeneratedFiles(parser.ml lexer.ml)
+OCamlGeneratedFiles(phantomy.ml phantomy.mli)
+
+LIBFILES[] =
+   base
+   monad_intf
+   monad
+   option
+   xlist
+   hashSet
+   xformat
+   xhashtbl
+   xstring
+   phantom
+   weaktbl
+   spot
+
+LIB = spotlib
+
+MyOCamlPackage($(LIB), $(LIBFILES), $(EMPTY), $(EMPTY))
+
+PHANTOM_GEN[] =
+   xlist
+   xformat
+   gen_phantom
+
+MyOCamlProgram(gen_phantom, $(PHANTOM_GEN))
+
+phantom.ml: phantom_head.ml gen_phantom.run
+	./gen_phantom.run ml > $@
+
+phantom.mli: phantom_head.mli gen_phantom.run
+	./gen_phantom.run mli > $@
+
+let failwithf fmt = Printf.kprintf failwith fmt
+
+let memoize f =
+  let cache = Hashtbl.create 101 in
+  fun v -> try Hashtbl.find cache v with Not_found ->
+    let r = f v in
+    Hashtbl.replace cache v r;
+    r
+
+let (^.) f g = fun x -> f (g x)
+let (^$) f x = f x
+
+let protect f a ~finally =
+  match try `Ok (f a) with e -> `Exn e with
+  | `Ok v -> finally (); v
+  | `Exn e -> finally (); raise e
+
+let with_time f v =
+  let start = Unix.gettimeofday () in
+  let res = f v in
+  let end_ = Unix.gettimeofday () in
+  res, end_ -. start
+
+val failwithf : ('a, unit, string, 'b) format4 -> 'a
+
+val memoize : ('c -> 'd) -> 'c -> 'd
+
+val (^.) : ('b -> 'c) -> ('a -> 'b) -> ('a -> 'c)
+  (** funciton composition: Haskell's (.) *)
+val (^$) : ('a -> 'b) -> 'a -> 'b
+  (** Haskell's ($) *)
+
+val protect : ('a -> 'b) -> 'a -> finally: (unit -> unit) -> 'b
+
+val with_time : ('a -> 'b) -> 'a -> 'b * float
+  (** simple profiling *)
+ 

lib/gen_phantom.ml

+open Format
+open Xformat
+open Xlist
+
+let def_c ppf n = 
+  fprintf ppf "let c%d %a = [%a]@."
+    n
+    (list (fun ppf -> fprintf ppf " ")
+       (fun ppf i -> fprintf ppf "t%d" i)) (from_to 0 (n-1))
+    (list (fun ppf -> fprintf ppf "; ")
+       (fun ppf i -> fprintf ppf "t%d" i)) (from_to 0 (n-1))
+
+let def_d ppf n = 
+  fprintf ppf "let d%d = function [%a] -> (%a) | _ -> assert false@."
+    n
+    (list (fun ppf -> fprintf ppf "; ")
+       (fun ppf i -> fprintf ppf "t%d" i)) (from_to 0 (n-1))
+    (list (fun ppf -> fprintf ppf ", ")
+       (fun ppf i -> fprintf ppf "t%d" i)) (from_to 0 (n-1))
+
+let def_get ppf n = fprintf ppf "let get%d l = List.nth l %d@." n n
+
+(*
+      unit
+      'a0 * unit
+      'a0 * ('a1 * unit)
+      'a0 * ('a1 * ('a2 * unit))
+*)
+let type_tpl last ppf n = 
+  let rec tpl x ppf = function
+    | 0 -> fprintf ppf last
+    | n -> fprintf ppf "('a%d * %a)" (x - 1) (tpl (x+1)) (n-1) 
+  in
+  tpl 1 ppf n
+
+let exp_tpl ppf = function
+  | 0 -> fprintf ppf "tpl0"
+  | 1 -> fprintf ppf "'a0 tpl1"
+  | n -> 
+      fprintf ppf "(%a) tpl%d"
+        (list (fun ppf -> fprintf ppf ",")
+           (fun ppf i -> fprintf ppf "'a%d" i)) (from_to 0 (n-1))
+        n
+
+let def_tpl ppf = function
+  | 0 -> fprintf ppf "type tpl0 = unit@."
+  | 1 -> fprintf ppf "type %a = %a@." exp_tpl 1 (type_tpl "unit") 1
+  | n -> 
+      fprintf ppf "type %a = %a@."
+        exp_tpl n
+        (type_tpl "unit") n
+
+let sig_c ppf n =
+  fprintf ppf "val c%d : %a(%a,'c) ts@."
+    n
+    (list (fun _ppf -> ())
+       (fun ppf i -> fprintf ppf "('a%d,'c) t -> " i)) (from_to 0 (n-1))
+    exp_tpl n
+ 
+let sig_d ppf n =
+  fprintf ppf "val d%d : (%a,'c) ts -> %a@."
+    n
+    exp_tpl n
+    (list (fun ppf -> fprintf ppf " * ")
+       (fun ppf i -> fprintf ppf "('a%d,'c) t" i)) (from_to 0 (n-1))
+ 
+let sig_get ppf n =
+  fprintf ppf "val get%d : (%a,'c) ts -> ('a%d,'c) t@."
+    (n - 1)
+    (type_tpl "_") n
+    (n - 1)
+
+let sig_uncurry ppf = function
+  | 0 -> fprintf ppf "val uncurry0 : (unit -> 'z) -> ((tpl0, 'c) ts -> 'z)@."
+  | n ->
+      fprintf ppf "val uncurry%d : (%a -> 'z) -> ((%a, 'c) ts -> 'z)@."
+        n
+        (list (fun ppf -> fprintf ppf " -> ")
+           (fun ppf i -> fprintf ppf "('a%d,'c) t" i)) (from_to 0 (n-1))
+        exp_tpl n
+
+let def_uncurry ppf = function
+  | 0 -> fprintf ppf "let uncurry0 f _tpl = f ()@."
+  | n ->
+      fprintf ppf "let uncurry%d f tpl = f %a@."
+        n
+        (list (fun ppf -> fprintf ppf " ")
+           (fun ppf i -> fprintf ppf "(get%d tpl : ('a%d,'c) t)" i i)) (from_to 0 (n-1))
+
+let sig_curry ppf = function
+  | 0 -> fprintf ppf "val curry0 : ((tpl0,'c) ts -> 'z) -> unit -> 'z@."
+  | n ->
+      fprintf ppf "val curry%d : ((%a,'c) ts -> 'z) -> (%a -> 'z)@."
+        n
+        exp_tpl n
+        (list (fun ppf -> fprintf ppf " -> ")
+           (fun ppf i -> fprintf ppf "('a%d,'c) t" i)) (from_to 0 (n-1))
+
+let def_curry ppf = function
+  | 0 -> fprintf ppf "let curry0 f () = f c0@."
+  | n ->
+      fprintf ppf "let curry%d f %a = f (c%d %a)@."
+        n
+        (list (fun ppf -> fprintf ppf " ")
+           (fun ppf i -> fprintf ppf "(v%d : ('a%d,'c) t)" i i)) (from_to 0 (n-1))
+        n
+        (list (fun ppf -> fprintf ppf " ")
+           (fun ppf i -> fprintf ppf "v%d" i)) (from_to 0 (n-1))
+
+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 "phantom_head.ml";
+        for i = 0 to max do
+          def_c stdout i
+        done;
+        fprintf stdout "@.";
+        for i = 0 to max do
+          def_d stdout i
+        done;
+        fprintf stdout "@.";
+        for i = 0 to max do
+          def_get stdout i
+        done;
+        fprintf stdout "@.";
+        for i = 0 to max do
+          def_tpl stdout i
+        done;
+        fprintf stdout "@.";
+        for i = 0 to max do
+          def_uncurry stdout i
+        done;
+        fprintf stdout "@.";
+        for i = 0 to max do
+          def_curry stdout i
+        done;
+        fprintf stdout "@.";
+        cat "phantom_tail.ml";
+    | "mli" ->
+        printf "(* This is an autogenerated file. Do not edit. *)@.@.";
+        cat "phantom_head.mli";
+        for i = 0 to max do
+          def_tpl stdout i
+        done;
+        fprintf stdout "@.";
+        for i = 0 to max do
+          sig_c stdout i
+        done;
+        fprintf stdout "@.";
+        for i = 1 to max do
+          sig_d stdout i
+        done;
+        fprintf stdout "@.";
+        for i = 1 to max do
+          sig_get stdout i
+        done;
+        fprintf stdout "@.";
+        for i = 0 to max do
+          sig_uncurry stdout i
+        done;
+        fprintf stdout "@.";
+        for i = 0 to max do
+          sig_curry stdout i
+        done;
+    | _ -> failwith "give ml or mli")
+    "gen_phantom [ml|mli]"
+type 'a t = ('a, unit) Hashtbl.t (* poorman's implementation *)
+let create = Hashtbl.create
+let mem = Hashtbl.mem
+let add t k = if not (mem t k) then Hashtbl.add t k ()
+let remove = Hashtbl.remove
+
+(* Poorman's implementation of polymorphic hash set *)
+type 'a t
+val create : int -> 'a t
+val mem : 'a t -> 'a -> bool
+val add : 'a t -> 'a -> unit
+val remove : 'a t -> 'a -> unit
+
+open Monad_intf
+
+module Make(M:S) : T with type 'a t = 'a M.t = struct
+  include M
+
+  let map ~f t = bind t (fun x -> return (f x))
+
+  module Open_ = struct
+    let bind = M.bind
+    let (>>=) = M.bind
+    let (>>|) t f = map ~f t
+    let return = return
+
+    (* Applicative style *)
+    let ( ^<$> ) f t = map ~f t 
+    let ( /<*> ) : ('a -> 'b) t -> 'a t -> 'b t = fun f a ->
+      f >>= fun f -> 
+      a >>= fun a ->
+      return (f a)
+  end
+  include Open_
+  module Open = struct
+    type 'a t = 'a M.t
+    include Open_
+  end
+
+  let ignore a = a >>= fun _ -> return ()
+  let void = ignore
+
+  let rec seq = function
+    | [] -> return []
+    | x::xs -> 
+        x >>= fun x -> 
+        seq xs >>= fun xs ->
+        return (x::xs)
+
+  let rec seq_ = function
+    | [] -> return ()
+    | x::xs -> x >>= fun () -> seq_ xs
+
+  let mapM f ls = seq (List.map f ls)
+
+  let rec for_ i to_ f =
+    if i > to_ then return ()
+    else f i >>= fun () -> for_ (i+1) to_ f
+    
+  let iteri f ls = seq_ (Xlist.mapi f ls)
+
+end
+
+module Make2(M:S2) : T2 with type ('a, 'z) t = ('a, 'z) M.t = struct
+  include M
+
+  let map ~f t = bind t (fun x -> return (f x))
+
+  module Open_ = struct
+    let bind = M.bind
+    let (>>=) = M.bind
+    let (>>|) t f = map ~f t
+    let return = return
+
+    (* Applicative style *)
+    let ( ^<$> ) f t = map ~f t 
+    let ( /<*> ) = fun f a ->
+      f >>= fun f -> 
+      a >>= fun a ->
+      return (f a)
+  end
+  include Open_
+  module Open = struct
+    type ('a, 'z) t = ('a, 'z) M.t
+    include Open_
+  end
+
+  let ignore a = a >>= fun _ -> return ()
+  let void = ignore
+
+  let rec seq = function
+    | [] -> return []
+    | x::xs -> 
+        x >>= fun x -> 
+        seq xs >>= fun xs ->
+        return (x::xs)
+
+  let rec seq_unit = function
+    | [] -> return ()
+    | x::xs -> x >>= fun () -> seq_unit xs
+
+  let mapM f ls = seq (List.map f ls)
+
+  let rec for_ i to_ f =
+    if i > to_ then return ()
+    else f i >>= fun () -> for_ (i+1) to_ f
+    
+  let iteri f ls = seq_unit (Xlist.mapi f ls)
+
+end
+
+open Monad_intf
+module Make(M : S) : T with type 'a t = 'a M.t
+module Make2(M : S2) : T2 with type ('a, 'z) t = ('a, 'z) M.t

lib/monad_intf.ml

+(** Minimum monad interface *)
+module type S = sig
+  type +'a t
+  val return : 'a -> 'a t
+  val bind : 'a t -> ('a -> 'b t) -> 'b t
+end
+
+module type Open = sig
+  type +'a t
+  val bind : 'a t -> ('a -> 'b t) -> 'b t
+  val ( >>= ) : 'a t -> ('a -> 'b t) -> 'b t
+  val ( >>| ) : 'a t -> ('a -> 'b) -> 'b t
+  val return : 'a -> 'a t
+    
+    (** Applicative style binops *)
+    
+  val (^<$>) : ('a -> 'b) -> 'a t -> 'b t
+    (** same as map, <$> in Haskell *)
+    
+  val (/<*>) : ('a -> 'b) t -> 'a t -> 'b t
+  (** <*> in Haskell *)
+end
+
+module type T = sig
+  include Open
+  module Open : Open with type 'a t = 'a t
+
+  val map : f:('a -> 'b) -> 'a t -> 'b t
+  (** fmap in Haskell *)
+
+  val ignore : 'a t -> unit t (* CR jfuruse: ignore is confusing with Pervasives.ignore. Probably it should be superceded by void *)
+  val void : 'a t -> unit t
+
+  val seq : 'a t list -> 'a list t
+    (** sequence in Haskell. Not tail recursive. *)
+  val seq_ : unit t list -> unit t
+    (** sequence_ in Haskell. Tail recursive. *)
+  val mapM : ('a -> 'b t) -> 'a list -> 'b list t
+    (** Not tail recursive *)
+  val iteri : (int -> 'a -> unit t) -> 'a list -> unit t
+  val for_ : int -> int -> (int -> unit t) -> unit t
+end
+
+module type S2 = sig
+  type ('a, 'z) t
+  val return : 'a -> ('a, 'z) t
+  val bind : ('a, 'z) t -> ('a -> ('b, 'z) t) -> ('b, 'z) t
+end
+
+module type Open2 = sig
+  type ('a, 'z) t
+  val bind : ('a, 'z) t -> ('a -> ('b, 'z) t) -> ('b, 'z) t
+  val ( >>= ) : ('a, 'z) t -> ('a -> ('b, 'z) t) -> ('b, 'z) t
+  val ( >>| ) : ('a, 'z) t -> ('a -> 'b) -> ('b, 'z) t
+  val return : 'a -> ('a, 'z) t
+    
+    (** Applicative style binops *)
+    
+  val (^<$>) : ('a -> 'b) -> ('a, 'z) t -> ('b, 'z) t
+    (** same as map, <$> in Haskell *)
+    
+  val (/<*>) : ('a -> 'b, 'z) t -> ('a, 'z) t -> ('b, 'z) t
+  (** <*> in Haskell *)
+end
+
+module type T2 = sig
+  include Open2
+  module Open : Open2 with type ('a, 'z) t = ('a, 'z) t
+
+  val map : f:('a -> 'b) -> ('a, 'z) t -> ('b, 'z) t
+    (** fmap in Haskell *)
+
+  val ignore : ('a, 'z) t -> (unit, 'z) t  (* CR jfuruse: ignore is confusing with Pervasives.ignore. Probably it should be superceded by void *)
+  val void : ('a, 'z) t -> (unit, 'z) t
+
+  val seq : ('a, 'z) t list -> ('a list, 'z) t
+    (** sequence in Haskell. Not tail recursive. *)
+  val seq_unit : (unit, 'z) t list -> (unit, 'z) t
+    (** sequence_ in Haskell. Tail recursive. *)
+  val mapM : ('a -> ('b, 'z) t) -> 'a list -> ('b list, 'z) t
+    (** Not tail recursive *)
+  val iteri : (int -> 'a -> (unit, 'z) t) -> 'a list -> (unit, 'z) t
+  val for_ : int -> int -> (int -> (unit, 'z) t) -> (unit, 'z) t
+end
+include Monad.Make(struct
+  type 'a t = 'a option
+
+  let return v = Some v
+
+  let bind t f = match t with
+    | Some v -> f v
+    | None -> None
+end)
+include Monad_intf.T with type 'a t = 'a option

lib/phantom_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
+
+let map f x = f x
+let combine x y = (x,y)
+
+type ('phantom, 'content) ts = 'content list
+

lib/phantom_head.mli

+(**
+   Opening this module like Spotlib.Spot.Phantom is NOT recommended. 
+   Instead, open Spotlib.Spot.Phantom.Open. Using a module alias is also helpful:
+   
+   module P = Spotlib.Spot.Phantom
+   open P.Open
+*)
+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. *)
+
+val map : ('cont -> 'cont2) -> ('a, 'cont) t -> ('a, 'cont2) t
+val combine : 'tag -> ('a, 'cont) t -> ('a, 'tag * 'cont) t
+
+type ('phantom, 'cont) ts
+(** phantom heterogeneous 'cont list *)
+
+module List : sig
+  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
+  val map : ('cont -> 'cont2) -> ('a, 'cont) ts -> ('a, 'cont2) ts
+  val combine : 'tag list -> ('a, 'cont) ts -> ('a, ('tag * 'cont)) ts
+
+  type ('phantom, 'cont) t = ('phantom, 'cont) ts
+end
+
+(* This encoding is correct only if the parameter cannot be the unit or a tuple *)

lib/phantom_tail.ml

+module List = struct
+  let unsafe_list 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 map = List.map
+  let combine = List.combine
+
+  type ('phantom, 'content) t = ('phantom, 'content) ts
+end
+
+include Base
+
+module Monad_intf = Monad_intf
+module Monad = Monad
+module Option = Option
+module List = struct
+  include List
+  include Xlist
+end
+module Format = struct
+  include Format
+  include Xformat
+end
+module Hashtbl = struct
+  include Hashtbl
+  include Xhashtbl
+end
+module String = struct
+  include String
+  include Xstring
+end
+module Weaktbl = Weaktbl
+module Phantom = Phantom
+(* weak hash table *)
+
+(* bucket array *)
+module Bucket : sig
+  type ('a, 'b) t
+  val create : int -> ('a, 'b) t
+  val add : ('a, 'b) t -> 'a -> 'b -> unit
+  val find : ('a, 'b) t -> ('a -> 'b -> bool) -> ('a * 'b) option
+  (** [find t f]: the first [(k,v)] pair [f k v = true], if exists, is returned as [Some (k,v)].
+      If none found, returns None *)
+  val remove : ('a, 'b) t -> ('a -> 'b -> bool) -> ('a * 'b) option
+  (** [remove t f]: the first [(k,v)] pair [f k v = true], if exists, is removed from [t] and returns the [Some (k,v)].
+      If none found, returns None. *) 
+  val removeq : ('a, 'b) t -> 'a -> 'b option
+  (** [removeq t k] removes the binding of the pointer equal [k] from [t] and returns its value if exists. 
+      Otherwise it returns [None]. *) 
+  val length : ('a, 'b) t -> int 
+(** return the number of full elements *)
+end = struct
+  type ('a, 'b) t = { 
+    mutable keys : 'a Weak.t;
+    mutable values : 'b option array; (* CR: No point of having option. We can safely use Obj *)
+    mutable size : int;               (* size of keys *)
+    init_size : int;                  (* initial size *)
+    mutable cur : int;                (* keys must be all empty from cur to size-1 *)
+    mutable nelems : int;             (* elements in the bucket *)
+  }
+
+  let create size = { 
+    keys = Weak.create size; (* CR size > 0 and max_array_length *) 
+    values = Array.create size None;
+    size = size;
+    init_size = size;
+    cur = 0;
+    nelems = 0;
+  }
+
+  (* If [t == t'], compaction in place. Otherwise, compaction by copy.
+     At compaction by copy, there is no check of destination size.
+  *)
+  let rec compact t t' to_ from = 
+    if from = t.size then begin (* finished. clear from to_ to the end *)
+      for i = to_ to t'.size - 1 do
+        Weak.set t'.keys i None;
+        Array.unsafe_set t'.values i None;
+      done;
+      to_ (* returns # of filled elements *)
+    end else 
+      match Weak.get t.keys from with
+      | None -> compact t t' to_ (from+1)
+      | somev ->
+          Weak.set t'.keys to_ somev;
+          Array.unsafe_set t'.values to_ (Array.unsafe_get t.values from);
+          compact t t' (to_+1) (from+1)
+
+  let compact t t' = compact t t' 0 0
+
+  let enlarge t =
+    let newsize = t.size * 2 in (* CR: Sys.max_array_length *)
+    let keys = t.keys in
+    let keys' = Weak.create newsize in
+    let values = t.values in
+    let values' = Array.create newsize None in
+    Weak.blit keys 0 keys' 0 t.size;
+    Array.blit values 0 values' 0 t.size;
+    t.keys <- keys';
+    t.values <- values';
+    t.size <- newsize;
+    t.cur <- t.size
+
+  let shrink t =
+    let newsize = max (t.size / 2) t.init_size in
+    if newsize < t.nelems then begin
+      let t' = create newsize in (* t' is a different bucket but contents will be copied to t *)
+      (* compaction by copy *)
+      ignore (compact t t');
+      t.keys <- t'.keys;
+      t.values <- t'.values;
+      t.size <- t'.size;
+      t.cur <- t'.cur;
+    end
+      
+  let find_gen t f =
+    let rec find t f i = 
+      if i = t.size then None
+      else
+        match Weak.get t.keys i with
+        | None -> find t f (i+1)
+        | Some k ->
+            match Array.unsafe_get t.values i with
+            | None -> assert false
+            | Some v -> if f k v then Some (k,v,i) else find t f (i+1)
+    in
+    find t f 0
+
+  let find t f = 
+    match find_gen t f with
+    | None -> None
+    | Some (k,v,_) -> Some (k,v)
+
+  let remove t f =
+    match find_gen t f with
+    | None -> None
+    | Some (k,v,i) -> 
+        Weak.set t.keys i None;
+        Array.unsafe_set t.values i None;
+        t.nelems <- t.nelems - 1;
+        shrink t;
+        Some (k,v)
+
+  let compact_and_may_enlarge t = if compact t t = t.size then enlarge t
+
+  let removeq t k = 
+    match remove t (fun k' _v -> k == k') with
+    | Some (_, v) -> Some v
+    | None -> None
+
+  let removeq_gc t k = assert (removeq t k <> None)
+
+  let rec add t k v = 
+    if t.cur < t.size then begin 
+      Gc.finalise (removeq_gc t) k;
+      Weak.set t.keys t.cur (Some k);
+      Array.unsafe_set t.values t.cur (Some v);
+      t.cur <- t.cur + 1;
+      t.nelems <- t.nelems + 1;
+    end else begin
+      (* compact and may enlarge it then try again *)
+      compact_and_may_enlarge t;
+      add t k v
+    end
+
+  let length t = t.nelems
+end
+
+module Make(K : Hashtbl.HashedType) : sig
+  type 'a t
+  val create : int -> 'a t
+  val add : 'a t -> K.t -> 'a -> unit
+  val find : 'a t -> K.t -> (K.t * 'a) option
+  val findq : 'a t -> K.t -> 'a option
+  val mem : 'a t -> K.t -> bool
+  val memq : 'a t -> K.t -> bool
+  val remove : 'a t -> K.t -> (K.t * 'a) option
+  val removeq : 'a t -> K.t -> 'a option
+  val length : 'a t -> int
+end = struct
+  type 'a t = (K.t, 'a) Bucket.t array
+
+  let create size = Array.init size (fun _ -> Bucket.create 10)
+
+  let get_bucket t k =
+    let pos = (K.hash k) mod (Array.length t) in
+    Array.unsafe_get t pos
+    
+  let add t k v =
+    let bucket = get_bucket t k in
+    Bucket.add bucket k v
+
+  let find t k =
+    let bucket = get_bucket t k in
+    Bucket.find bucket (fun k' _ -> K.equal k k')
+
+  let findq t k =
+    let bucket = get_bucket t k in
+    match Bucket.find bucket (fun k' _ -> k == k') with
+    | Some (_,v) -> Some v
+    | None -> None 
+
+  let mem t k = find t k <> None
+  let memq t k = findq t k <> None
+
+  let remove t k =
+    let bucket = get_bucket t k in
+    Bucket.remove bucket (fun k' _ -> K.equal k k')
+    
+  let removeq t k =
+    let bucket = get_bucket t k in
+    Bucket.removeq bucket k
+
+  (* CR jfuruse: O(n) where n is the size of buckets *)      
+  let length t = Array.fold_left (fun st b -> st + Bucket.length b) 0 t
+    
+end
+
+module O = Make(struct
+  type t = Obj.t
+  let hash = Hashtbl.hash
+  let equal = (=)
+end)
+
+module Poly : sig
+  type ('a, 'b) t
+  val create : int -> ('a, 'b) t
+  val add : ('a, 'b) t-> 'a -> 'b -> unit
+  val find : ('a, 'b) t-> 'a -> ('a * 'b) option
+  val findq : ('a, 'b) t-> 'a -> 'b option
+  val remove : ('a, 'b) t-> 'a -> ('a * 'b) option
+  val removeq : ('a, 'b) t-> 'a -> 'b option
+  val length : ('a, 'b) t -> int
+end = struct
+  type ('a, 'b) t = 'b O.t
+  let coerce_opt = function
+    | None -> None
+    | Some (k,v) -> Some (Obj.obj k, v)
+  let create = O.create
+  let add t k v = O.add t (Obj.repr k) v
+  let find t k = coerce_opt (O.find t (Obj.repr k))
+  let findq t k = O.findq t (Obj.repr k)
+  let remove t k = coerce_opt (O.remove t (Obj.repr k))
+  let removeq t k = O.removeq t (Obj.repr k)
+  let length = O.length
+end
+
+include Poly
+open Format
+
+type t = formatter
+
+let stdout = std_formatter
+let stderr = err_formatter
+
+let rec list sep f ppf = function
+  | [] -> ()
+  | [x] -> f ppf x
+  | x::xs ->
+      fprintf ppf "%a%t%a"
+        f x
+        sep
+        (list sep f) xs
+open Format
+
+type t = formatter
+
+val stdout : t
+val stderr : t
+
+val list : (t -> unit) -> (t -> 'a -> unit) -> t -> 'a list -> unit
+let replace_list tbl kvs = 
+  List.iter (fun (k,v) ->
+    Hashtbl.replace tbl k v) kvs
+
+let of_list size kvs =
+  let tbl = Hashtbl.create size in
+  List.iter (fun (k,v) ->
+    Hashtbl.replace tbl k v) kvs;
+  tbl
+  
+val replace_list : ('a, 'b) Hashtbl.t -> ('a * 'b) list -> unit
+val of_list : int -> ('a * 'b) list -> ('a, 'b) Hashtbl.t
+open List
+
+let iteri f l =
+  let rec iter n = function
+    | [] -> ()
+    | x::xs -> f n x; iter (n+1) xs
+  in
+  iter 0 l
+
+let mapi f l = 
+  let rec map n = function
+    | [] -> []
+    | x::xs -> f n x :: map (n+1) xs
+  in
+  map 0 l
+
+let from_to f t =
+  let rec from_to st f t =
+    if f > t then rev st
+    else from_to (f::st) (f+1) t
+  in
+  from_to [] f t
+val iteri : (int -> 'a -> 'b) -> 'a list -> unit
+val mapi : (int -> 'a -> 'b) -> 'a list -> 'b list
+
+val from_to : int -> int -> int list
+  (** [from_to f t = [f..t]] *)
+let is_prefix ?from:(pos=0) ~prefix:sub str =
+  let str_len = String.length str in
+  let sub_len = String.length sub in
+  if pos + sub_len > str_len then false
+  else 
+    let rec iter i = 
+      if str.[pos + i] <> sub.[i] then false
+      else 
+        let i' = i + 1 in
+        if i' = sub_len then true
+        else iter i'
+    in
+    iter 0
+
+let index_string_from str pos sub =
+  let sub_len = String.length sub in
+  if sub_len = 0 then pos 
+  else 
+    let limit = String.length str - sub_len in
+    let rec iter i = 
+      if i > limit then raise Not_found
+      else if is_prefix str ~from:i ~prefix:sub then i
+      else iter (i+1)
+    in
+    iter pos
+
+let is_postfix ~postfix:sub str =
+  is_prefix ~from:(String.length str - String.length sub) ~prefix: sub str
+val is_prefix : ?from:int -> prefix:string -> string -> bool
+val is_postfix : postfix:string -> string -> bool
+val index_string_from : string -> int -> string -> int (* may raise Not_found *)

monad.ml

-open Monad_intf
-
-module Make(M:S) : T with type 'a t = 'a M.t = struct
-  include M
-
-  let map ~f t = bind t (fun x -> return (f x))
-
-  module Open_ = struct
-    let bind = M.bind
-    let (>>=) = M.bind
-    let (>>|) t f = map ~f t
-    let return = return
-
-    (* Applicative style *)
-    let ( ^<$> ) f t = map ~f t 
-    let ( /<*> ) : ('a -> 'b) t -> 'a t -> 'b t = fun f a ->
-      f >>= fun f -> 
-      a >>= fun a ->
-      return (f a)
-  end
-  include Open_
-  module Open = struct
-    type 'a t = 'a M.t
-    include Open_
-  end
-
-  let ignore a = a >>= fun _ -> return ()
-  let void = ignore
-
-  let rec seq = function
-    | [] -> return []
-    | x::xs -> 
-        x >>= fun x -> 
-        seq xs >>= fun xs ->
-        return (x::xs)
-
-  let rec seq_ = function
-    | [] -> return ()
-    | x::xs -> x >>= fun () -> seq_ xs
-
-  let mapM f ls = seq (List.map f ls)
-
-  let rec for_ i to_ f =
-    if i > to_ then return ()
-    else f i >>= fun () -> for_ (i+1) to_ f
-    
-  let iteri f ls = seq_ (Xlist.mapi f ls)
-
-end
-
-module Make2(M:S2) : T2 with type ('a, 'z) t = ('a, 'z) M.t = struct
-  include M
-
-  let map ~f t = bind t (fun x -> return (f x))
-
-  module Open_ = struct
-    let bind = M.bind
-    let (>>=) = M.bind
-    let (>>|) t f = map ~f t
-    let return = return
-
-    (* Applicative style *)
-    let ( ^<$> ) f t = map ~f t 
-    let ( /<*> ) = fun f a ->
-      f >>= fun f -> 
-      a >>= fun a ->
-      return (f a)
-  end
-  include Open_
-  module Open = struct
-    type ('a, 'z) t = ('a, 'z) M.t
-    include Open_
-  end
-
-  let ignore a = a >>= fun _ -> return ()
-  let void = ignore
-
-  let rec seq = function
-    | [] -> return []
-    | x::xs -> 
-        x >>= fun x -> 
-        seq xs >>= fun xs ->
-        return (x::xs)
-
-  let rec seq_unit = function
-    | [] -> return ()
-    | x::xs -> x >>= fun () -> seq_unit xs
-
-  let mapM f ls = seq (List.map f ls)
-
-  let rec for_ i to_ f =
-    if i > to_ then return ()
-    else f i >>= fun () -> for_ (i+1) to_ f
-    
-  let iteri f ls = seq_unit (Xlist.mapi f ls)
-
-end
-

monad.mli

-open Monad_intf
-module Make(M : S) : T with type 'a t = 'a M.t
-module Make2(M : S2) : T2 with type ('a, 'z) t = ('a, 'z) M.t

monad_intf.ml

-(** Minimum monad interface *)
-module type S = sig
-  type +'a t
-  val return : 'a -> 'a t
-  val bind : 'a t -> ('a -> 'b t) -> 'b t
-end
-
-module type Open = sig
-  type +'a t
-  val bind : 'a t -> ('a -> 'b t) -> 'b t
-  val ( >>= ) : 'a t -> ('a -> 'b t) -> 'b t
-  val ( >>| ) : 'a t -> ('a -> 'b) -> 'b t
-  val return : 'a -> 'a t
-    
-    (** Applicative style binops *)
-    
-  val (^<$>) : ('a -> 'b) -> 'a t -> 'b t
-    (** same as map, <$> in Haskell *)
-    
-  val (/<*>) : ('a -> 'b) t -> 'a t -> 'b t
-  (** <*> in Haskell *)
-end
-
-module type T = sig
-  include Open
-  module Open : Open with type 'a t = 'a t
-
-  val map : f:('a -> 'b) -> 'a t -> 'b t
-  (** fmap in Haskell *)
-
-  val ignore : 'a t -> unit t (* CR jfuruse: ignore is confusing with Pervasives.ignore. Probably it should be superceded by void *)
-  val void : 'a t -> unit t
-
-  val seq : 'a t list -> 'a list t
-    (** sequence in Haskell. Not tail recursive. *)
-  val seq_ : unit t list -> unit t
-    (** sequence_ in Haskell. Tail recursive. *)
-  val mapM : ('a -> 'b t) -> 'a list -> 'b list t
-    (** Not tail recursive *)
-  val iteri : (int -> 'a -> unit t) -> 'a list -> unit t
-  val for_ : int -> int -> (int -> unit t) -> unit t
-end
-
-module type S2 = sig
-  type ('a, 'z) t
-  val return : 'a -> ('a, 'z) t
-  val bind : ('a, 'z) t -> ('a -> ('b, 'z) t) -> ('b, 'z) t
-end
-
-module type Open2 = sig
-  type ('a, 'z) t
-  val bind : ('a, 'z) t -> ('a -> ('b, 'z) t) -> ('b, 'z) t
-  val ( >>= ) : ('a, 'z) t -> ('a -> ('b, 'z) t) -> ('b, 'z) t
-  val ( >>| ) : ('a, 'z) t -> ('a -> 'b) -> ('b, 'z) t
-  val return : 'a -> ('a, 'z) t
-    
-    (** Applicative style binops *)
-    
-  val (^<$>) : ('a -> 'b) -> ('a, 'z) t -> ('b, 'z) t
-    (** same as map, <$> in Haskell *)
-    
-  val (/<*>) : ('a -> 'b, 'z) t -> ('a, 'z) t -> ('b, 'z) t
-  (** <*> in Haskell *)
-end
-
-module type T2 = sig
-  include Open2
-  module Open : Open2 with type ('a, 'z) t = ('a, 'z) t
-
-  val map : f:('a -> 'b) -> ('a, 'z) t -> ('b, 'z) t
-    (** fmap in Haskell *)
-
-  val ignore : ('a, 'z) t -> (unit, 'z) t  (* CR jfuruse: ignore is confusing with Pervasives.ignore. Probably it should be superceded by void *)
-  val void : ('a, 'z) t -> (unit, 'z) t
-
-  val seq : ('a, 'z) t list -> ('a list, 'z) t
-    (** sequence in Haskell. Not tail recursive. *)
-  val seq_unit : (unit, 'z) t list -> (unit, 'z) t
-    (** sequence_ in Haskell. Tail recursive. *)
-  val mapM : ('a -> ('b, 'z) t) -> 'a list -> ('b list, 'z) t
-    (** Not tail recursive *)
-  val iteri : (int -> 'a -> (unit, 'z) t) -> 'a list -> (unit, 'z) t
-  val for_ : int -> int -> (int -> (unit, 'z) t) -> (unit, 'z) t
-end

option.ml

-include Monad.Make(struct
-  type 'a t = 'a option
-
-  let return v = Some v
-
-  let bind t f = match t with
-    | Some v -> f v
-    | None -> None
-end)

option.mli

-include Monad_intf.T with type 'a t = 'a option

phantom_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
-
-let map f x = f x
-let combine x y = (x,y)
-
-type ('phantom, 'content) ts = 'content list
-

phantom_head.mli

-(**
-   Opening this module like Spotlib.Spot.Phantom is NOT recommended. 
-   Instead, open Spotlib.Spot.Phantom.Open. Using a module alias is also helpful:
-   
-   module P = Spotlib.Spot.Phantom
-   open P.Open
-*)
-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. *)
-
-val map : ('cont -> 'cont2) -> ('a, 'cont) t -> ('a, 'cont2) t
-val combine : 'tag -> ('a, 'cont) t -> ('a, 'tag * 'cont) t
-
-type ('phantom, 'cont) ts
-(** phantom heterogeneous 'cont list *)
-
-module List : sig
-  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
-  val map : ('cont -> 'cont2) -> ('a, 'cont) ts -> ('a, 'cont2) ts
-  val combine : 'tag list -> ('a, 'cont) ts -> ('a, ('tag * 'cont)) ts
-
-  type ('phantom, 'cont) t = ('phantom, 'cont) ts
-end
-
-(* This encoding is correct only if the parameter cannot be the unit or a tuple *)

phantom_tail.ml

-module List = struct
-  let unsafe_list 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 map = List.map
-  let combine = List.combine
-
-  type ('phantom, 'content) t = ('phantom, 'content) ts
-end
-
+(* setup.ml generated for the first time by OASIS v0.2.0 *)
+
+(* OASIS_START *)
+(* DO NOT EDIT (digest: 97f19e872795051b87427013133c1740) *)
+(*
+   Regenerated by OASIS v0.2.0
+   Visit http://oasis.forge.ocamlcore.org for more information and
+   documentation about functions used in this file.
+*)
+module OASISGettext = struct
+# 21 "/home/gildor/programmation/oasis/src/oasis/OASISGettext.ml"
+  
+  let ns_ str = 
+    str
+  
+  let s_ str = 
+    str
+  
+  let f_ (str : ('a, 'b, 'c, 'd) format4) =
+    str
+  
+  let fn_ fmt1 fmt2 n =
+    if n = 1 then
+      fmt1^^""
+    else
+      fmt2^^""
+  
+  let init = 
+    []
+  
+end
+
+module OASISContext = struct
+# 21 "/home/gildor/programmation/oasis/src/oasis/OASISContext.ml"
+  
+  open OASISGettext 
+  
+  type level =
+    [ `Debug
+    | `Info 
+    | `Warning
+    | `Error]
+  
+  type t =
+    {
+      verbose:        bool;
+      debug:          bool;
+      ignore_plugins: bool;
+      printf:         level -> string -> unit; 
+    }
+  
+  let printf lvl str = 
+    let beg = 
+      match lvl with 
+        | `Error -> s_ "E: "
+        | `Warning -> s_ "W: "
+        | `Info  -> s_ "I: "
+        | `Debug -> s_ "D: "
+    in
+      match lvl with 
+        | `Error ->
+            prerr_endline (beg^str)
+        | _ ->
+            print_endline (beg^str)
+  
+  let default =
+    ref 
+      {
+        verbose        = true;
+        debug          = false;
+        ignore_plugins = false;
+        printf         = printf;
+      }
+  
+  let quiet = 
+    {!default with 
+         verbose = false;
+         debug   = false;
+    }
+  
+  
+  let args () =
+    ["-quiet",
+     Arg.Unit (fun () -> default := {!default with verbose = false}),
+     (s_ " Run quietly");
+  
+     "-debug",
+     Arg.Unit (fun () -> default := {!default with debug = true}),
+     (s_ " Output debug message")]
+end
+
+module OASISUtils = struct
+# 21 "/home/gildor/programmation/oasis/src/oasis/OASISUtils.ml"
+  
+  module MapString = Map.Make(String)
+  
+  let map_string_of_assoc assoc =
+    List.fold_left
+      (fun acc (k, v) -> MapString.add k v acc)
+      MapString.empty
+      assoc
+  
+  module SetString = Set.Make(String)
+  
+  let set_string_add_list st lst =
+    List.fold_left 
+      (fun acc e -> SetString.add e acc)
+      st
+      lst
+  
+  let set_string_of_list =
+    set_string_add_list
+      SetString.empty
+  
+  
+  let compare_csl s1 s2 = 
+    String.compare (String.lowercase s1) (String.lowercase s2)
+  
+  module HashStringCsl = 
+    Hashtbl.Make
+      (struct
+         type t = string
+  
+         let equal s1 s2 = 
+             (String.lowercase s1) = (String.lowercase s2)
+  
+         let hash s =
+           Hashtbl.hash (String.lowercase s)
+       end)
+  
+  let split sep str =
+    let str_len =
+      String.length str
+    in
+    let rec split_aux acc pos =
+      if pos < str_len then
+        (
+          let pos_sep = 
+            try
+              String.index_from str pos sep
+            with Not_found ->
+              str_len
+          in
+          let part = 
+            String.sub str pos (pos_sep - pos) 
+          in
+          let acc = 
+            part :: acc
+          in
+            if pos_sep >= str_len then
+              (
+                (* Nothing more in the string *)
+                List.rev acc
+              )
+            else if pos_sep = (str_len - 1) then
+              (
+                (* String end with a separator *)
+                List.rev ("" :: acc)
+              )
+            else
+              (
+                split_aux acc (pos_sep + 1)
+              )
+        )
+      else
+        (
+          List.rev acc
+        )
+    in
+      split_aux [] 0
+  
+  
+  let varname_of_string ?(hyphen='_') s = 
+    if String.length s = 0 then
+      begin
+        invalid_arg "varname_of_string" 
+      end
+    else
+      begin
+        let buff = 
+          Buffer.create (String.length s)
+        in
+          (* Start with a _ if digit *)
+          if '0' <= s.[0] && s.[0] <= '9' then
+            Buffer.add_char buff hyphen;
+  
+          String.iter
+            (fun c ->
+               if ('a' <= c && c <= 'z') 
+                 || 
+                  ('A' <= c && c <= 'Z') 
+                 || 
+                  ('0' <= c && c <= '9') then
+                 Buffer.add_char buff c
+               else
+                 Buffer.add_char buff hyphen)
+            s;
+  
+          String.lowercase (Buffer.contents buff)
+      end
+  
+  let varname_concat ?(hyphen='_') p s = 
+    let p = 
+      let p_len =
+        String.length p
+      in
+        if p_len > 0 && p.[p_len - 1] = hyphen then
+          String.sub p 0 (p_len - 1)
+        else
+          p
+    in
+    let s = 
+      let s_len =
+        String.length s
+      in
+        if s_len > 0 && s.[0] = hyphen then
+          String.sub s 1 (s_len - 1)
+        else
+          s
+    in
+      Printf.sprintf "%s%c%s" p hyphen s
+  
+  
+  let is_varname str = 
+    str = varname_of_string str
+  
+  let failwithf1 fmt a =
+    failwith (Printf.sprintf fmt a)
+  
+  let failwithf2 fmt a b =
+    failwith (Printf.sprintf fmt a b)
+  
+  let failwithf3 fmt a b c =
+    failwith (Printf.sprintf fmt a b c)
+  
+  let failwithf4 fmt a b c d =
+    failwith (Printf.sprintf fmt a b c d)
+  
+  let failwithf5 fmt a b c d e =
+    failwith (Printf.sprintf fmt a b c d e)
+  
+end
+
+module PropList = struct
+# 21 "/home/gildor/programmation/oasis/src/oasis/PropList.ml"
+  
+  open OASISGettext
+  
+  type name = string
+  
+  exception Not_set of name * string option 
+  exception No_printer of name
+  exception Unknown_field of name * name
+  
+  let string_of_exception =
+    function
+      | Not_set (nm, Some rsn) ->
+          Printf.sprintf (f_ "Field '%s' is not set: %s") nm rsn
+      | Not_set (nm, None) ->
+          Printf.sprintf (f_ "Field '%s' is not set") nm
+      | No_printer nm ->
+          Printf.sprintf (f_ "No default printer for value %s") nm
+      | Unknown_field (nm, schm) ->
+          Printf.sprintf (f_ "Field %s is not defined in schema %s") nm schm
+      | e ->
+          raise e
+  
+  module Data =
+  struct
+  
+    type t = 
+        (name, unit -> unit) Hashtbl.t
+  
+    let create () =
+      Hashtbl.create 13
+  
+    let clear t =
+      Hashtbl.clear t
+  
+# 59 "/home/gildor/programmation/oasis/src/oasis/PropList.ml"
+  end
+  
+  module Schema = 
+  struct
+  
+    type ('ctxt, 'extra) value =
+        {
+          get:   Data.t -> string;
+          set:   Data.t -> ?context:'ctxt -> string -> unit;
+          help:  (unit -> string) option;
+          extra: 'extra;
+        }
+  
+    type ('ctxt, 'extra) t =
+        {
+          name:      name;
+          fields:    (name, ('ctxt, 'extra) value) Hashtbl.t;
+          order:     name Queue.t;
+          name_norm: string -> string;
+        }
+  
+    let create ?(case_insensitive=false) nm = 
+      {
+        name      = nm;
+        fields    = Hashtbl.create 13;
+        order     = Queue.create ();
+        name_norm = 
+          (if case_insensitive then 
+             String.lowercase
+           else
+             fun s -> s);
+      }
+  
+    let add t nm set get extra help = 
+      let key = 
+        t.name_norm nm
+      in
+  
+        if Hashtbl.mem t.fields key then
+          failwith
+            (Printf.sprintf 
+               (f_ "Field '%s' is already defined in schema '%s'")
+               nm t.name);
+        Hashtbl.add 
+          t.fields 
+          key 
+          {
+            set   = set; 
+            get   = get; 
+            help  = help;
+            extra = extra;
+          };
+        Queue.add nm t.order 
+  
+    let mem t nm =
+      Hashtbl.mem t.fields nm 
+  
+    let find t nm = 
+      try
+        Hashtbl.find t.fields (t.name_norm nm)
+      with Not_found ->
+        raise (Unknown_field (nm, t.name))
+  
+    let get t data nm =
+      (find t nm).get data
+  
+    let set t data nm ?context x =
+      (find t nm).set 
+        data 
+        ?context 
+        x
+  
+    let fold f acc t =
+      Queue.fold 
+        (fun acc k ->
+           let v =
+             find t k
+           in
+             f acc k v.extra v.help)
+        acc 
+        t.order
+  
+    let iter f t =
+      fold 
+        (fun () -> f)
+        ()
+        t
+  
+    let name t = 
+      t.name
+  end
+  
+  module Field =
+  struct
+  
+    type ('ctxt, 'value, 'extra) t =
+        {
+          set:    Data.t -> ?context:'ctxt -> 'value -> unit;
+          get:    Data.t -> 'value;
+          sets:   Data.t -> ?context:'ctxt -> string -> unit;
+          gets:   Data.t -> string;
+          help:   (unit -> string) option;
+          extra:  'extra;
+        }
+  
+    let new_id = 
+      let last_id =
+        ref 0
+      in
+        fun () -> incr last_id; !last_id
+  
+    let create ?schema ?name ?parse ?print ?default ?update ?help extra =
+      (* Default value container *)
+      let v = 
+        ref None 
+      in
+  
+      (* If name is not given, create unique one *)
+      let nm = 
+        match name with 
+          | Some s -> s
+          | None -> Printf.sprintf "_anon_%d" (new_id ())
+      in
+  
+      (* Last chance to get a value: the default *)
+      let default () = 
+        match default with 
+          | Some d -> d
+          | None -> raise (Not_set (nm, Some (s_ "no default value")))
+      in
+  
+      (* Get data *)
+      let get data =
+        (* Get value *)
+        try 
+          (Hashtbl.find data nm) ();
+          match !v with 
+            | Some x -> x 
+            | None -> default ()
+        with Not_found ->
+          default ()
+      in
+  
+      (* Set data *)
+      let set data ?context x = 
+        let x = 
+          match update with 
+            | Some f ->
+                begin
+                  try 
+                    f ?context (get data) x
+                  with Not_set _ ->
+                    x
+                end
+            | None ->
+                x
+        in
+          Hashtbl.replace 
+            data 
+            nm 
+            (fun () -> v := Some x) 
+      in
+  
+      (* Parse string value, if possible *)
+      let parse =
+        match parse with 
+          | Some f -> 
+              f
+          | None ->
+              fun ?context s ->
+                failwith 
+                  (Printf.sprintf 
+                     (f_ "Cannot parse field '%s' when setting value %S")
+                     nm
+                     s)
+      in
+  
+      (* Set data, from string *)
+      let sets data ?context s =
+        set ?context data (parse ?context s)
+      in
+  
+      (* Output value as string, if possible *)
+      let print =
+        match print with
+          | Some f ->
+              f
+          | None ->
+              fun _ -> raise (No_printer nm)
+      in
+  
+      (* Get data, as a string *)
+      let gets data =
+        print (get data)
+      in
+  
+        begin 
+          match schema with 
+            | Some t ->
+                Schema.add t nm sets gets extra help
+            | None ->
+                ()
+        end;
+  
+        {
+          set   = set;
+          get   = get;
+          sets  = sets;
+          gets  = gets;
+          help  = help;
+          extra = extra;
+        }
+  
+    let fset data t ?context x = 
+      t.set data ?context x
+  
+    let fget data t =
+      t.get data
+  
+    let fsets data t ?context s =
+      t.sets data ?context s
+  
+    let fgets data t =
+      t.gets data 
+  
+  end
+  
+  module FieldRO =
+  struct
+  
+    let create ?schema ?name ?parse ?print ?default ?update ?help extra =
+      let fld = 
+        Field.create ?schema ?name ?parse ?print ?default ?update ?help extra
+      in
+        fun data -> Field.fget data fld
+  
+  end
+end
+
+module OASISMessage = struct
+# 21 "/home/gildor/programmation/oasis/src/oasis/OASISMessage.ml"
+  
+  
+  open OASISGettext
+  open OASISContext
+  
+  let generic_message ~ctxt lvl fmt =
+    let cond = 
+      match lvl with 
+        | `Debug -> ctxt.debug
+        | _ -> ctxt.verbose
+    in
+      Printf.ksprintf 
+        (fun str -> 
+           if cond then
+             begin