Source

ocaml-lib / 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 Lazy.t) =
  object
    method parse s =
      MList.bind ((Lazy.force p)#parse s) (function (x,"") -> MList.one x | _ -> MList.zero)
    method print x =
      (Lazy.force 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 Lazy.t) (f : ('a,'b) Iso.t) : ['b] t =
  object
    method parse 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) (Lazy.force p)#print
  end
let map p f = new map p f
let (<$>) = map
(* p -> f *)

class ['a,'b] seq (p : 'a t Lazy.t) (q : 'b t Lazy.t) : ['a * 'b] t =
  object
    method parse 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 ((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 Lazy.t) (q : 'a t Lazy.t) : ['a] t =
  object
    method parse s =
      ((Lazy.force p)#parse s) @ ((Lazy.force q)#parse s)
    method 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 =
      MList.zero
    method print (x : 'a) =
      MOption.none
  end
(* <vide> *)
*)

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
(* -> 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 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 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 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 Lazy.t) : 'a list t =
  map
    (lazy (seq p (lazy (many p))))
    Iso.cons
(* SOME p *)

(* for left-associative chain of operators *)
let chainl1 (arg : 'a t Lazy.t) (op : 'b t Lazy.t) (f : ('a * ('b * 'a), 'a) Iso.t) : 'a t =
  map
    (lazy (seq arg (lazy (many (lazy (seq op arg))))))
    (Iso.fold_left f)
(* CHAIN1 arg SEP op -> f *)

let prefix (pre : unit t Lazy.t) (p : 'a t Lazy.t) : 'a t =
  map
    (lazy (seq pre p))
    (Iso.seq Iso.comm (Iso.inverse Iso.unit))
(* 'pre; p *)

let suffix (p : 'a t Lazy.t) (suf : unit t Lazy.t) : 'a t =
  map
    (lazy (seq p suf))
    (Iso.inverse Iso.unit)
(* 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 Lazy.t) (p : 'a t Lazy.t) : 'a list t =
  map
    (lazy (seq p (lazy (many (lazy (prefix sep p))))))
    Iso.cons
(* LIST1 p SEP sep *)

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
(* token *)

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
(* "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


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