Source

ocaml-lib / syndesc / syndesc.ml

Diff from to

File syndesc/syndesc.ml

     method parse : string -> ('a * string) MList.t
     method print : 'a -> string MOption.t
   end
-
-class ['a] close (p : 'a t) =
+class ['a] close (p : 'a t Lazy.t) =
   object
     method parse s =
-      MList.bind (p#parse s) (function (x,"") -> MList.one x | _ -> MList.zero)
+      MList.bind ((Lazy.force p)#parse s) (function (x,"") -> MList.one x | _ -> MList.zero)
     method print x =
-      p#print x
+      (Lazy.force p)#print x
   end
 let close p = new close p
 
+(*
 exception Undefined
 
 let undef : 'a t =
     method print = del#print
   end
 let delegate () = new delegate
+*)
 
-class ['a,'b] map (p : 'a t) (f : ('a,'b) Iso.t) : ['b] t =
+class ['a,'b] map (p : 'a t Lazy.t) (f : ('a,'b) Iso.t) : ['b] t =
   object
     method parse s =
-      MList.bind (p#parse s) (fun (x,s') ->
+      MList.bind ((Lazy.force p)#parse s) (fun (x,s') ->
 	match f#apply x with
 	| Some y -> MList.one (y,s')
 	| None -> MList.zero)
     method print y =
-      MOption.bind (f#unapply y) p#print
+      MOption.bind (f#unapply y) (Lazy.force p)#print
   end
 let map p f = new map p f
 let (<$>) = map
+(* p -> f *)
 
-class ['a,'b] seq (p : 'a t) (q : 'b t) : ['a * 'b] t =
+class ['a,'b] seq (p : 'a t Lazy.t) (q : 'b t Lazy.t) : ['a * 'b] t =
   object
     method parse s =
-      MList.bind (p#parse s) (fun (x,s') ->
-	MList.bind (q#parse s') (fun (y,s'') ->
+      MList.bind ((Lazy.force p)#parse s) (fun (x,s') ->
+	MList.bind ((Lazy.force q)#parse s') (fun (y,s'') ->
 	  MList.one ((x,y),s'')))
     method print (x,y) =
-      MOption.bind (p#print x) (fun s ->
-	MOption.bind (q#print y) (fun s' ->
+      MOption.bind ((Lazy.force p)#print x) (fun s ->
+	MOption.bind ((Lazy.force q)#print y) (fun s' ->
 	  MOption.some (s ^ s')))
   end
 let seq p q = new seq p q
 let (<*>) = seq
+(* p; q *)
 
-class ['a] alt (p : 'a t) (q : 'a t) : ['a] t =
+class ['a] alt (p : 'a t Lazy.t) (q : 'a t Lazy.t) : ['a] t =
   object
     method parse s =
-      (p#parse s) @ (q#parse s)
+      ((Lazy.force p)#parse s) @ ((Lazy.force q)#parse s)
     method print x =
-      MOption.plus (p#print x) (q#print x)
+      MOption.plus ((Lazy.force p)#print x) (fun () -> (Lazy.force q)#print x)
   end
 let alt p q = new alt p q
 let (<|>) = alt
+(* p | q *)
 
+(*
 let empty : 'a t =
   object
     method parse s =
     method print (x : 'a) =
       MOption.none
   end
+(* <vide> *)
+*)
 
 class ['a] pure (e : 'a) : ['a] t =
   object
       if x = e then MOption.some "" else MOption.none
   end
 let pure e = new pure e
+(* -> e *)
 
 (*
 let eof : unit t =
   end
 *)
 
-let either (p : 'a t) (q : 'b t) : ('a,'b) Iso.either t =
-  alt (map p Iso.left) (map q Iso.right)
+let either (p : 'a t Lazy.t) (q : 'b t Lazy.t) : ('a,'b) Iso.either t =
+  alt (lazy (map p Iso.left)) (lazy (map q Iso.right))
 let (<+>) = either
+(* p -> left | q -> right *)
+(* p else q *)
 
-let fixpoint (f : 'a t -> 'a t) : 'a t =
+(*
+let rec fixpoint (f : 'a t Lazy.t -> 'a t Lazy.t) : 'a t Lazy.t =
+  lazy (Lazy.force (f (fixpoint f)))
+(*
   let p0 = delegate () in
   let p1 = f (p0 :> 'a t) in
   p0#set p1;
   p1
+*)
+(* FIXPOINT x -> f x *)
+*)
 
-let many (p : 'a t) : 'a list t =
+let rec many (p : 'a t Lazy.t) : 'a list t =
+  map (lazy (either (lazy (pure ())) (lazy (seq p (lazy (many p)))))) Iso.list_cases
+(*
   fixpoint (fun self ->
     map (either (pure ()) (seq p self)) Iso.list_cases)
+*)
+(* MANY p *)
 
-let some (p : 'a t) : 'a list t =
+let some (p : 'a t Lazy.t) : 'a list t =
   map
-    (seq p (many p))
+    (lazy (seq p (lazy (many p))))
     Iso.cons
+(* SOME p *)
 
 (* for left-associative chain of operators *)
-let chainl1 (arg : 'a t) (op : 'b t) (f : ('a * ('b * 'a), 'a) Iso.t) : 'a t =
+let chainl1 (arg : 'a t Lazy.t) (op : 'b t Lazy.t) (f : ('a * ('b * 'a), 'a) Iso.t) : 'a t =
   map
-    (seq arg (many (seq op arg)))
+    (lazy (seq arg (lazy (many (lazy (seq op arg))))))
     (Iso.fold_left f)
+(* CHAIN1 arg SEP op -> f *)
 
-
-let prefix (pre : unit t) (p : 'a t) : 'a t =
+let prefix (pre : unit t Lazy.t) (p : 'a t Lazy.t) : 'a t =
   map
-    (seq pre p)
+    (lazy (seq pre p))
     (Iso.seq Iso.comm (Iso.inverse Iso.unit))
+(* 'pre; p *)
 
-let suffix (p : 'a t) (suf : unit t) : 'a t =
+let suffix (p : 'a t Lazy.t) (suf : unit t Lazy.t) : 'a t =
   map
-    (seq p suf)
+    (lazy (seq p suf))
     (Iso.inverse Iso.unit)
+(* p; 'suf *)
 
-let between (pre : unit t) (p : 'a t) (suf : unit t) : 'a t =
-  prefix pre (suffix p suf)
+let between (pre : unit t Lazy.t) (p : 'a t Lazy.t) (suf : unit t Lazy.t) : 'a t =
+  prefix pre (lazy (suffix p suf))
+(* 'pre; p; 'suf *)
 
-let list1 (sep : unit t) (p : 'a t) : 'a list t =
+let list1 (sep : unit t Lazy.t) (p : 'a t Lazy.t) : 'a list t =
   map
-    (seq p (many (prefix sep p)))
+    (lazy (seq p (lazy (many (lazy (prefix sep p))))))
     Iso.cons
-
+(* LIST1 p SEP sep *)
 
 let token : char t =
   object
     method print c =
       MOption.some (String.make 1 c)
   end
+(* token *)
 
 class text (w : string) : [unit] t =
   object
       MOption.some w
   end
 let text w = new text w
+(* "w" *)
 
 let skip_space : unit t =
   object
       MOption.some " "
   end
 
+
+type 'a lazy_t = 'a t Lazy.t
+
+module Lazy =
+  struct
+    type 'a t = 'a lazy_t
+
+    let close p = lazy (close p)
+    let map p f = lazy (map p f)
+    let seq p q = lazy (seq p q)
+    let alt p q = lazy (alt p q)
+    let pure e = lazy (pure e)
+    let either p q = lazy (either p q)
+    let many p = lazy (many p)
+    let some p = lazy (some p)
+    let chainl1 arg op f = lazy (chainl1 arg op f)
+    let prefix pre p = lazy (prefix pre p)
+    let suffix p suf = lazy (suffix p suf)
+    let between pre p suf = lazy (between pre p suf)
+    let list1 sep p = lazy (list1 sep p)
+    let token = Lazy.lazy_from_val token
+    let text w = lazy (text w)
+    let skip_space = Lazy.lazy_from_val skip_space
+    let opt_space = Lazy.lazy_from_val opt_space
+    let sep_space = Lazy.lazy_from_val sep_space
+  end