1. Sébastien Ferré
  2. ocaml-lib

Source

ocaml-lib / syndesc / syndesc.ml

Sébastien Ferré 9262056 







Sébastien Ferré bd642c3 
Sébastien Ferré 9262056 

Sébastien Ferré bd642c3 
Sébastien Ferré 9262056 
Sébastien Ferré bd642c3 
Sébastien Ferré 9262056 


Sébastien Ferré bd642c3 
Sébastien Ferré 9262056 















Sébastien Ferré bd642c3 
Sébastien Ferré 9262056 
Sébastien Ferré bd642c3 
Sébastien Ferré 9262056 

Sébastien Ferré bd642c3 
Sébastien Ferré 9262056 



Sébastien Ferré bd642c3 
Sébastien Ferré 9262056 


Sébastien Ferré bd642c3 
Sébastien Ferré 9262056 
Sébastien Ferré bd642c3 
Sébastien Ferré 9262056 

Sébastien Ferré bd642c3 

Sébastien Ferré 9262056 

Sébastien Ferré bd642c3 

Sébastien Ferré 9262056 



Sébastien Ferré bd642c3 
Sébastien Ferré 9262056 
Sébastien Ferré bd642c3 
Sébastien Ferré 9262056 

Sébastien Ferré bd642c3 
Sébastien Ferré 9262056 
Sébastien Ferré bd642c3 
Sébastien Ferré 9262056 


Sébastien Ferré bd642c3 
Sébastien Ferré 9262056 
Sébastien Ferré bd642c3 
Sébastien Ferré 9262056 






Sébastien Ferré bd642c3 

Sébastien Ferré 9262056 








Sébastien Ferré bd642c3 
Sébastien Ferré 9262056 









Sébastien Ferré bd642c3 

Sébastien Ferré 9262056 
Sébastien Ferré bd642c3 

Sébastien Ferré 9262056 
Sébastien Ferré bd642c3 



Sébastien Ferré 9262056 



Sébastien Ferré bd642c3 


Sébastien Ferré 9262056 
Sébastien Ferré bd642c3 


Sébastien Ferré 9262056 

Sébastien Ferré bd642c3 

Sébastien Ferré 9262056 
Sébastien Ferré bd642c3 
Sébastien Ferré 9262056 
Sébastien Ferré bd642c3 
Sébastien Ferré 9262056 
Sébastien Ferré bd642c3 
Sébastien Ferré 9262056 

Sébastien Ferré bd642c3 
Sébastien Ferré 9262056 
Sébastien Ferré bd642c3 
Sébastien Ferré 9262056 
Sébastien Ferré bd642c3 
Sébastien Ferré 9262056 
Sébastien Ferré bd642c3 
Sébastien Ferré 9262056 
Sébastien Ferré bd642c3 
Sébastien Ferré 9262056 
Sébastien Ferré bd642c3 
Sébastien Ferré 9262056 
Sébastien Ferré bd642c3 
Sébastien Ferré 9262056 
Sébastien Ferré bd642c3 
Sébastien Ferré 9262056 
Sébastien Ferré bd642c3 
Sébastien Ferré 9262056 
Sébastien Ferré bd642c3 


Sébastien Ferré 9262056 
Sébastien Ferré bd642c3 
Sébastien Ferré 9262056 
Sébastien Ferré bd642c3 
Sébastien Ferré 9262056 
Sébastien Ferré bd642c3 
Sébastien Ferré 9262056 









Sébastien Ferré bd642c3 
Sébastien Ferré 9262056 












Sébastien Ferré bd642c3 
Sébastien Ferré 9262056 



































Sébastien Ferré bd642c3 

























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