Commits

Sébastien Ferré  committed 9262056

Initial revision

  • Participants
  • Parent commits 7514e8a

Comments (0)

Files changed (1)

File syndesc/syndesc.ml

+
+open Monad
+
+class type ['a] t =
+  object
+    method parse : string -> ('a * string) MList.t
+    method print : 'a -> string MOption.t
+  end
+
+class ['a] close (p : 'a t) =
+  object
+    method parse s =
+      MList.bind (p#parse s) (function (x,"") -> MList.one x | _ -> MList.zero)
+    method print x =
+      p#print x
+  end
+let close p = new close p
+
+exception Undefined
+
+let undef : 'a t =
+  object
+    method parse s = raise Undefined
+    method print x = raise Undefined
+  end
+
+class ['a] delegate =
+  object
+    val mutable del : 'a t = undef
+    method set (p : 'a t) = del <- p
+    method parse = del#parse
+    method print = del#print
+  end
+let delegate () = new delegate
+
+class ['a,'b] map (p : 'a t) (f : ('a,'b) Iso.t) : ['b] t =
+  object
+    method parse s =
+      MList.bind (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
+  end
+let map p f = new map p f
+let (<$>) = map
+
+class ['a,'b] seq (p : 'a t) (q : 'b 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.one ((x,y),s'')))
+    method print (x,y) =
+      MOption.bind (p#print x) (fun s ->
+	MOption.bind (q#print y) (fun s' ->
+	  MOption.some (s ^ s')))
+  end
+let seq p q = new seq p q
+let (<*>) = seq
+
+class ['a] alt (p : 'a t) (q : 'a t) : ['a] t =
+  object
+    method parse s =
+      (p#parse s) @ (q#parse s)
+    method print x =
+      MOption.plus (p#print x) (q#print x)
+  end
+let alt p q = new alt p q
+let (<|>) = alt
+
+let empty : 'a t =
+  object
+    method parse s =
+      MList.zero
+    method print (x : 'a) =
+      MOption.none
+  end
+
+class ['a] pure (e : 'a) : ['a] t =
+  object
+    method parse s =
+      MList.one (e,s)
+    method print x =
+      if x = e then MOption.some "" else MOption.none
+  end
+let pure e = new pure e
+
+(*
+let eof : unit t =
+  object
+    method parse s =
+      if s = "" then MList.one () else MList.zero
+    method print () = MOption.some ""
+  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
+
+let fixpoint (f : 'a t -> 'a t) : 'a t =
+  let p0 = delegate () in
+  let p1 = f (p0 :> 'a t) in
+  p0#set p1;
+  p1
+
+let many (p : 'a t) : 'a list t =
+  fixpoint (fun self ->
+    map (either (pure ()) (seq p self)) Iso.list_cases)
+
+let some (p : 'a t) : 'a list t =
+  map
+    (seq p (many p))
+    Iso.cons
+
+(* for left-associative chain of operators *)
+let chainl1 (arg : 'a t) (op : 'b t) (f : ('a * ('b * 'a), 'a) Iso.t) : 'a t =
+  map
+    (seq arg (many (seq op arg)))
+    (Iso.fold_left f)
+
+
+let prefix (pre : unit t) (p : 'a t) : 'a t =
+  map
+    (seq pre p)
+    (Iso.seq Iso.comm (Iso.inverse Iso.unit))
+
+let suffix (p : 'a t) (suf : unit t) : 'a t =
+  map
+    (seq p suf)
+    (Iso.inverse Iso.unit)
+
+let between (pre : unit t) (p : 'a t) (suf : unit t) : 'a t =
+  prefix pre (suffix p suf)
+
+let list1 (sep : unit t) (p : 'a t) : 'a list t =
+  map
+    (seq p (many (prefix sep p)))
+    Iso.cons
+
+
+let token : char t =
+  object
+    method parse s =
+      if s = ""
+      then MList.zero
+      else MList.one (s.[0], String.sub s 1 (String.length s - 1))
+    method print c =
+      MOption.some (String.make 1 c)
+  end
+
+class text (w : string) : [unit] t =
+  object
+    method parse s =
+      let n = String.length w in
+      let m = String.length s in
+      if n <= m && String.sub s 0 n = w
+      then MList.one ((), String.sub s n (m-n))
+      else MList.zero
+    method print () =
+      MOption.some w
+  end
+let text w = new text w
+
+let skip_space : unit t =
+  object
+    method parse s =
+      let m = String.length s in
+      let i = ref 0 in
+      while !i < m && s.[!i] = ' ' do incr i done;
+      MList.one ((), String.sub s !i (m - !i))
+    method print () =
+      MOption.some ""
+  end
+
+let opt_space : unit t =
+  object
+    method parse s =
+      let m = String.length s in
+      let i = ref 0 in
+      while !i < m && s.[!i] = ' ' do incr i done;
+      MList.one ((), String.sub s !i (m - !i))
+    method print () =
+      MOption.some " "
+  end
+
+let sep_space : unit t =
+  object
+    method parse s =
+      let m = String.length s in
+      let i = ref 0 in
+      while !i < m && s.[!i] = ' ' do incr i done;
+      if !i = 0
+      then MList.zero
+      else MList.one ((), String.sub s !i (m - !i))
+    method print () =
+      MOption.some " "
+  end
+