Commits

camlspotter  committed 2b4a708

curry and uncurry

  • Participants
  • Parent commits 8da10a2

Comments (0)

Files changed (5)

File gen_phantom.ml

 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 tpl_exp last ppf n = 
+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 tpl ppf = function
+let exp_tpl ppf = function
   | 0 -> fprintf ppf "tpl0"
   | 1 -> fprintf ppf "'a0 tpl1"
   | n -> 
            (fun ppf i -> fprintf ppf "'a%d" i)) (from_to 0 (n-1))
         n
 
-let tpl_def ppf = function
+let def_tpl ppf = function
   | 0 -> fprintf ppf "type tpl0 = unit@."
-  | 1 -> fprintf ppf "type %a = %a@." tpl 1 (tpl_exp "unit") 1
+  | 1 -> fprintf ppf "type %a = %a@." exp_tpl 1 (type_tpl "unit") 1
   | n -> 
       fprintf ppf "type %a = %a@."
-        tpl n
-        (tpl_exp "unit") n
+        exp_tpl n
+        (type_tpl "unit") n
 
-let sig_ ppf n =
-  fprintf ppf "val c%d : %a(%a,'cont) ts@."
+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,'cont) t -> " i)) (from_to 0 (n-1))
-    tpl n
+       (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,'cont) ts -> %a@."
+  fprintf ppf "val d%d : (%a,'c) ts -> %a@."
     n
-    tpl n
+    exp_tpl n
     (list (fun ppf -> fprintf ppf " * ")
-       (fun ppf i -> fprintf ppf "('a%d, 'cont) t" i)) (from_to 0 (n-1))
+       (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, 'cont) ts -> ('a%d, 'cont) t@."
+  fprintf ppf "val get%d : (%a,'c) ts -> ('a%d,'c) t@."
     (n - 1)
-    (tpl_exp "_") n
+    (type_tpl "_") n
     (n - 1)
- 
+
+let sig_uncurry ppf 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 sig_curry ppf n =
+  fprintf ppf "val curry%d : (%a -> '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_uncurry ppf 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 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 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 =
         printf "(* This is an autogenerated file. Do not edit. *)@.@.";
         cat "phantom_head.ml";
         for i = 0 to max do
-          tpl_def stdout i
+          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 = 2 to max do
+          def_uncurry stdout i
+        done;
+        fprintf stdout "@.";
+        for i = 2 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
-          tpl_def stdout i
+          def_tpl stdout i
         done;
+        fprintf stdout "@.";
         for i = 0 to max do
-          sig_ stdout i
+          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 = 2 to max do
+          sig_uncurry stdout i
+        done;
+        fprintf stdout "@.";
+        for i = 2 to max do
+          sig_curry stdout i
+        done;
     | _ -> failwith "give ml or mli")
     "gen_phantom [ml|mli]"
 
     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
 

File monad_intf.ml

-(* Minimum monad interfaec *)
+(** Minimum monad interface *)
 module type S = sig
   type 'a t
   val return : 'a -> 'a 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
+
+  (** Exposing operators in Open in this level too. *)
   val ( >>= ) : 'a t -> ('a -> 'b t) -> 'b t
   val ( >>| ) : 'a t -> ('a -> 'b) -> 'b t
+  val ( ^<$> ) : ('a -> 'b) -> 'a t -> 'b t
+  val ( /<*> ) : ('a -> 'b) t -> 'a t -> 'b t
+
   val map : f:('a -> 'b) -> 'a t -> 'b t
+    (** fmap in Haskell *)
   val ignore : 'a t -> unit t
   val seq : 'a t list -> 'a list t
   val seq_unit : unit t list -> unit t

File phantom_head.ml

 
 type ('phantom, 'content) ts = 'content list
 
-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 get0 l = List.nth l 0
-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
-
-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
-

File 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
+