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) =
  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
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.