Commits

camlspotter committed fde7c27

planck

Comments (0)

Files changed (9)

+.PHONY: all install clean
+
+USE_OCAMLFIND = true
+
+# OCAMLPACKS[] =
+#    pack1
+#    pack2
+#
+# if $(not $(OCAMLFIND_EXISTS))
+#    eprintln(This project requires ocamlfind, but is was not found.)
+#    eprintln(You need to install ocamlfind and run "omake --configure".)
+#    exit 1
+
+OCAMLINCLUDES +=
+
+NATIVE_ENABLED = $(OCAMLOPT_EXISTS)
+BYTE_ENABLED = $(not $(OCAMLOPT_EXISTS))
+
+
+OCAMLFLAGS    += -annot
+OCAMLCFLAGS   +=
+OCAMLOPTFLAGS +=
+OCAML_LINK_FLAGS +=
+OCAML_BYTE_LINK_FLAGS +=
+OCAML_NATIVE_LINK_FLAGS +=
+
+# OCamlGeneratedFiles(parser.ml lexer.ml)
+
+LIBFILES[] =
+   utils
+   stream
+   planck
+   pstring
+
+LIB = plancklib
+
+.DEFAULT: $(OCamlLibrary $(LIB), $(LIBFILES))
+
+PROGFILES[] = $(LIBFILES)
+
+PROGRAM = planck 
+
+OCAML_LIBS +=
+OCAML_CLIBS +=
+OCAML_OTHER_LIBS +=
+OCAML_LIB_FLAGS +=
+
+.DEFAULT: $(OCamlProgram $(PROGRAM), $(PROGFILES))
+
+
+clean:
+	rm -f *.o *.a *.cm* *.spit *spot *.annot *.opt *.byt
+########################################################################
+# Permission is hereby granted, free of charge, to any person
+# obtaining a copy of this file, to deal in the File without
+# restriction, including without limitation the rights to use,
+# copy, modify, merge, publish, distribute, sublicense, and/or
+# sell copies of the File, and to permit persons to whom the
+# File is furnished to do so, subject to the following condition:
+#
+# THE FILE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+# EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
+# OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
+# IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM,
+# DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR
+# OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE FILE OR
+# THE USE OR OTHER DEALINGS IN THE FILE.
+
+########################################################################
+# The standard OMakeroot file.
+# You will not normally need to modify this file.
+# By default, your changes should be placed in the
+# OMakefile in this directory.
+#
+# If you decide to modify this file, note that it uses exactly
+# the same syntax as the OMakefile.
+#
+
+#
+# Include the standard installed configuration files.
+# Any of these can be deleted if you are not using them,
+# but you probably want to keep the Common file.
+#
+open build/C
+open build/OCaml
+open build/LaTeX
+
+#
+# The command-line variables are defined *after* the
+# standard configuration has been loaded.
+#
+DefineCommandVars()
+
+#
+# Include the OMakefile in this directory.
+#
+.SUBDIRS: .
+open Utils
+
+module Make(S : Stream.S) = struct
+
+  type 'a result = ('a * S.t) option
+  
+  include Monad.Make(struct
+    type 'a t = S.t -> 'a result
+  
+    let return v = fun st -> Some (v, st)
+  
+    let bind t f = fun st ->
+      match t st with
+      | Some (r, st') -> f r st' 
+      | None -> None
+  
+  end)
+
+  open Infix
+
+  let eos : unit t = fun s ->
+    match S.take s with
+    | Some _ -> None
+    | None -> Some ((), s)
+  
+  let filter_map : ('a -> 'b option) -> 'b t = fun p s ->
+    Option.bind (S.take s) (fun (char, s') ->
+      match p char with
+      | None -> None
+      | Some v -> Some (v, s'))
+  
+  let token : ('a -> bool) -> 'a t = fun p ->
+    filter_map (fun x -> if p x then Some x else None)
+  
+  let rec seq : 'a list -> 'a list t = 
+    let rec aux = function
+      | [] -> return ()
+      | x::xs -> token (fun c -> c = x) >>= fun _ -> aux xs
+    in
+    fun str -> aux str >>= fun () -> return str
+  
+  let star : 'a t -> 'a list t = fun com ->
+    let rec aux st = fun s ->
+      match com s with
+      | None -> return (List.rev st) s
+      | Some (v, s') -> aux (v :: st) s'
+    in
+    aux []
+  
+  let plus : 'a t -> 'a list t = fun com ->
+    com >>= fun v -> 
+      star com >>= fun vs -> 
+        return (v :: vs)
+  
+  let surrounded left right content =
+    left >>= fun _ ->
+      content >>= fun res ->
+        right >>= fun _ ->
+  	return res
+  
+  let (<|>) : 'a t -> 'a t -> 'a t = fun c1 c2 -> 
+    fun st ->
+      match c1 st with
+      | (Some _ as res) -> res
+      | None -> c2 st
+end
+module Make (S : Stream.S) : sig
+  type 'a t = S.t -> ('a * S.t) option
+  include Utils.Monad.T with type 'a t := 'a t
+  val eos : unit t
+  val filter_map : (S.elem -> 'a option) -> 'a t
+  val token : (S.elem -> bool) -> S.elem t
+  val seq : S.elem list -> S.elem list t
+  val star : 'a t -> 'a list t
+  val plus : 'a t -> 'a list t
+  val surrounded : 'a t -> 'b t -> 'c t -> 'c t
+  val ( <|> ) : 'a t -> 'a t -> 'a t
+end
+dule Lang = struct
+
+let digit_char =
+  String.charp (function
+    | '0' .. '9' -> true
+    | _ -> false)
+
+let digit =
+  filter_map (function
+    | ('0' .. '9' as c) -> Some (Char.code c - Char.code '0')
+    | _ -> None)
+
+let oct_char =
+  String.charp (function
+    | '0' .. '7' -> true
+    | _ -> false)
+
+let oct =
+  filter_map (function
+    | ('0' .. '7' as c) -> Some (Char.code c - Char.code '0')
+    | _ -> None)
+
+let hex_char =
+  String.charp (function
+    | '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' -> true
+    | _ -> false)
+
+let hex =
+  filter_map (function
+    | ('0' .. '9' as c) -> Some (Char.code c - Char.code '0')
+    | ('a' .. 'f' as c) -> Some (Char.code c - Char.code 'a' + 10)
+    | ('A' .. 'F' as c) -> Some (Char.code c - Char.code 'A' + 10)
+    | _ -> None)
+
+let char = 
+  let normal = String.charp (function
+    | '\'' | '\\' -> false
+    | _ -> true)
+  in
+  let backslashed = 
+    String.char '\\' >>= fun _ ->
+	filter_map (function
+	  | 'b' -> Some '\b'
+	  | 't' -> Some '\t'
+	  | 'n' -> Some '\n'
+	  | 'f' -> Some '\012'
+	  | 'r' -> Some '\r'
+	  | 'e' -> Some '\027'
+	  | '\'' -> Some '\''
+	  | _ -> None)
+  in
+  let hex =
+    String.string "\\x" >>= fun _ ->
+	hex >>= fun c1 ->
+	  hex >>= fun c2 ->
+	    return (char_of_int (c1 * 16 + c2))
+  in
+  let oct =
+    String.string "\\o" >>= fun _ ->
+	oct >>= fun c1 ->
+	  oct >>= fun c2 ->
+	    oct >>= fun c3 ->
+	      return (char_of_int (c1 * 64 + c2 * 8 + c3))
+  in
+  let digit = 
+    String.string "\\" >>= fun _ ->
+	digit >>= fun c1 ->
+	  digit >>= fun c2 ->
+	    digit >>= fun c3 ->
+	      return (char_of_int (c1 * 100 + c2 * 10 + c3))
+  in
+  let quote = String.char '\'' in
+  surrounded quote quote (normal <|> backslashed <|> hex <|> oct <|> digit)
+
+let string = 
+  let normal = String.charp (function
+    | '"' | '\\' -> false
+    | _ -> true)
+  in
+  let backslashed = 
+    String.char '\\' >>= fun _ ->
+	filter_map (function
+	  | 'b' -> Some '\b'
+	  | 't' -> Some '\t'
+	  | 'n' -> Some '\n'
+	  | 'f' -> Some '\012'
+	  | 'r' -> Some '\r'
+	  | 'e' -> Some '\027'
+	  | '\'' -> Some '\''
+	  | _ -> None)
+  in
+  let hex =
+    String.string "\\x" >>= fun _ ->
+	hex >>= fun c1 ->
+	  hex >>= fun c2 ->
+	    return (char_of_int (c1 * 16 + c2))
+  in
+  let oct =
+    String.string "\\o" >>= fun _ ->
+	oct >>= fun c1 ->
+	  oct >>= fun c2 ->
+	    oct >>= fun c3 ->
+	      return (char_of_int (c1 * 64 + c2 * 8 + c3))
+  in
+  let digit = 
+    String.string "\\" >>= fun _ ->
+	digit >>= fun c1 ->
+	  digit >>= fun c2 ->
+	    digit >>= fun c3 ->
+	      return (char_of_int (c1 * 100 + c2 * 10 + c3))
+  in
+  let dquote = String.char '\"' in
+  surrounded dquote dquote (normal <|> backslashed <|> hex <|> oct <|> digit)
+
+let _ = 
+  assert (test char "'x'" = Some 'x');
+  assert (test char "'xx'" = None);
+  assert (test char "'\n'" = Some '\n');
+  assert (test char "'\\''" = Some '\'');
+  assert (test char "'\\x41'" = Some 'A');
+  assert (test char "'\\o101'" = Some 'A');
+  assert (test char "'\\065'" = Some 'A');
+
+
+open Utils
+
+module P = Plank.Make(Stream.Char)
+
+include P
+
+let test str (cmb : 'a t) : 'a option =
+  Option.map ~f:fst (cmb (Stream.Char.from_string str)) 
+
+let charp : (char -> bool) -> char t = token
+let char c = charp (fun c' -> c = c')
+
+let _ = 
+  assert (test "xyz" (char 'x') = Some 'x');
+  assert (test "zxy" (charp (fun c -> c = 'x')) = None)
+;;
+
+let string : string -> string t = fun str ->
+  let len = String.length str in
+  let rec aux n =
+    if n = len then return str
+    else char str.[n] >>= fun _ -> aux (n+1)
+  in
+  aux 0 
+
+let _ = 
+  assert (test "hello world" (string "hello") = Some "hello");
+  assert (test "bye world" (string "hello") = None);
+  assert (test "hello world" begin
+    string "hello" >>= fun _ -> 
+      char ' ' >>= fun _ ->
+	string "world" >>= fun _ -> 
+	  eos
+  end = Some ())
+;;
+
+let _ = 
+  assert (test "xxxzzz" begin 
+    star (char 'x') >>= fun xs ->
+      star (char 'y') >>= fun ys ->
+	star (char 'z') >>= fun zs ->
+	  Format.eprintf "xs=%d ys=%d zs=%d@." 
+	    (List.length xs)
+	    (List.length ys)
+	    (List.length zs);
+	  eos
+  end <> None)
+      
+let _ = 
+  assert (test "xxxzzz" begin 
+    plus (char 'x') >>= fun xs ->
+      star (char 'y') >>= fun ys ->
+	plus (char 'z') >>= fun zs ->
+	  Format.eprintf "xs=%d ys=%d zs=%d@." 
+	    (List.length xs)
+	    (List.length ys)
+	    (List.length zs);
+	  eos
+  end <> None);
+  assert (test "xxxzzz" begin 
+    plus (char 'x') >>= fun xs ->
+      plus (char 'y') >>= fun ys ->
+	plus (char 'z') >>= fun zs ->
+	  Format.eprintf "xs=%d ys=%d zs=%d@." 
+	    (List.length xs)
+	    (List.length ys)
+	    (List.length zs);
+	    eos
+  end = None)
+;;
+
+let buffer : 'a t -> Buffer.t t = fun com ->
+  com >>= fun v -> 
+
+let star_gen : Buffer.t -> char t -> Buffer.t t = fun buf com s -> 
+  let rec aux s =
+    match com s with
+    | None -> return buf s
+    | Some (v, s') -> Buffer.add_char buf v; aux s'
+  in
+  aux s
+
+let star : char t -> Buffer.t t = fun com s -> 
+  star_gen (Buffer.create 32) com s
+
+let plus : char t -> Buffer.t t = fun com s ->
+  let buf = Buffer.create 32 in
+  com >>= fun v -> 
+    Buffer.add_char buf v;
+    star_gen buf com s
+
+open Utils
+
+module type S0 = sig
+  type elem
+  type t
+
+  val empty : t
+  (* One of bad things in OCaml: the following is impossible. *)
+  (* type gen = unit -> (elem * gen) option *)
+  type gen = unit -> [ `Some of elem * gen | `None ] (* must be pure *)
+  val create : gen -> t
+
+  val take : t -> (elem * t) option
+end
+
+module type S = sig
+  include S0
+  val peek : t -> elem option
+  val is_empty : t -> bool
+end
+
+module Make(S0 : S0) = struct
+  include S0
+    
+  let peek t = Option.map (take t) ~f:fst
+  let is_empty t = peek t = None
+end
+
+module Simple(E : sig type t end) = Make(struct
+  type elem = E.t
+  type gen = unit -> [ `Some of elem * gen | `None ] 
+
+  type t = desc ref
+  and desc = 
+    | Lazy of gen
+    | Cons of elem * t
+    | Null
+
+  let empty = ref Null
+  let create gen = ref (Lazy gen)
+
+  let take t = match !t with
+    | Null -> None
+    | Cons (e, t) -> Some (e, t)
+    | Lazy gen ->
+	match gen () with
+	| `None -> t := Null; None
+	| `Some (e, gen) -> 
+	    let t' = create gen in
+	    t := Cons (e, t'); 
+	    Some (e, t')
+end)
+
+module Simple_char = struct
+  include Simple(struct type t = char end)
+  let from_string ?(from=0) s = 
+    let len = String.length s in
+    let rec f pos () = 
+      if pos >= len then `None
+      else `Some (s.[pos], f (pos+1))
+    in
+    create (f from)
+end
+module type S0 = sig
+  type elem
+  type t
+  val empty : t
+  type gen = unit -> [ `None | `Some of elem * gen ]
+  val create : gen -> t
+  val take : t -> (elem * t) option
+end
+
+module type S = sig
+  include S0
+  val peek : t -> elem option
+  val is_empty : t -> bool
+end
+
+module Make(S0 : S0) : S with type elem = S0.elem
+
+module Simple(E : sig type t end) : S with type elem = E.t
+
+module Simple_char : sig
+  include S with type elem = char
+  val from_string : ?from:int -> string -> t
+end
+
+    
+module Monad = struct
+  module type S = sig
+    type 'a t
+    val return : 'a -> 'a t
+    val bind : 'a t -> ('a -> 'b t) -> 'b t
+  end
+
+  module type T = sig
+    include S
+    val map : f:('a -> 'b) -> 'a t -> 'b t
+    module Infix : sig
+      val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
+      val (>>|) : 'a t -> ('a -> 'b) -> 'b t
+    end
+    val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
+    val (>>|) : 'a t -> ('a -> 'b) -> 'b t
+  end
+
+  module Make(M:S) : T with type 'a t = 'a M.t = struct
+    include M
+    let map ~f t = bind t (fun x -> return (f x))
+    module Infix = struct
+      let (>>=) = M.bind
+      let (>>|) t f = map ~f t
+    end
+    include Infix
+  end
+end
+
+module Option = Monad.Make(struct
+  type 'a t = 'a option
+
+  let return v = Some v
+
+  let bind t f = match t with
+    | Some v -> f v
+    | None -> None
+end)