1. camlspotter
  2. treeprint

Commits

"Jun...@gmail.com>"  committed bb1f270

added printer with attributes

  • Participants
  • Parent commits 521954a
  • Branches default

Comments (0)

Files changed (3)

File lib/OMakefile

View file
 
 LIBFILES[] =
    printer
+   aprinter
 
 LIB = treeprint
 

File lib/aprinter.ml

View file
+open Spotlib.Spot
+open Ocaml_conv
+
+module Make(A : sig
+  type t with conv(ocaml_of)
+  val format : (Format.t -> unit) (** printer for the internal *)
+               -> Format.t -> t -> unit
+  val buffer : (Buffer.t -> unit) (** buffer output for the internal *)
+               -> Buffer.t -> t -> unit
+end) = struct
+
+  (** Display machine with Format like capability *)
+  
+  module Token = struct
+    type t = 
+      | String of string
+      | Box of int * t  (** "@[<n>...@]" *)
+      | VBox of int * t (** "@[<vn>...@]" *)
+      | Cut             (** "@," (known also as Good Break) *)
+      | Space           (** "@ " *)
+      | Flush           (** "@." *)
+      | Seq of t list
+      | NOP
+      | Attr of A.t * t
+    with conv(ocaml_of)
+
+    let dump = Ocaml.format_with ocaml_of_t
+  
+    open Format
+    let rec format ppf = function
+      | String s -> string ppf s
+      | Box (n, tk) -> 
+          box ppf n; format ppf tk; close_box ppf ()
+      | VBox (n ,tk) -> 
+          vbox ppf n; format ppf tk; close_box ppf ()
+      | Cut -> cut ppf
+      | Space -> space ppf 
+      | Flush -> flush ppf; newline ppf
+      | Seq tks -> List.iter (format ppf) tks
+      | NOP -> ()
+      | Attr (a, t) -> A.format (fun ppf -> format ppf t) ppf a
+    
+    open Buffer
+    let rec buffer buf = function
+      | String s -> add_string buf s
+      | Box (_, tk) | VBox (_ ,tk) -> buffer buf tk
+      | Seq tks -> List.iter (buffer buf) tks
+      | Cut | NOP -> ()
+      | Space -> add_char buf ' '
+      | Flush -> add_char buf '\n' (* CR jfuruse: probably add too many? *)
+      | Attr (a, t) -> A.buffer (fun buf -> buffer buf t) buf a
+    
+    let show token = 
+      let buf = Buffer.create 100 in 
+      buffer buf token; 
+      Buffer.contents buf
+  end
+  
+  type token = Token.t
+  open Token
+  
+  (** Primitive operators *)
+  
+  type assoc = Left | Right | Noassoc
+  type level = float
+  type 'a m = assoc -> level -> 'a (* monadic *)
+  
+  module Monad = struct
+    module M = struct 
+      type 'a t = 'a m
+      let bind at f = fun a l -> f (at a l) a l
+      let return a = fun _ _ -> a
+    end
+    include M
+    include Monad.Make(M)
+  end
+
+  open Monad
+
+  type t = token m
+  
+  let box : int -> t -> t = 
+    fun offset t a l -> Box (offset, t a l)
+  
+  let vbox : int -> t -> t = 
+    fun offset t a l -> VBox (offset, t a l)
+  
+  let do_Seq xs =
+    Seq (List.concat_map (function 
+      | Seq ys -> ys
+      | y -> [y]) xs)
+  
+  let (++) : t -> t -> t = 
+    fun p1 p2 a l -> do_Seq [p1 a l; p2 a l]
+  
+  let cut : t = 
+    fun _out_ops _out_lev -> Cut
+  
+  let space : t = 
+    fun _out_pos _out_lev -> Space
+  
+  let flush : t =
+    fun _out_pos _out_lev -> Flush
+  
+  let seq : t list -> t
+    = fun ps a l -> do_Seq (List.map (fun p -> p a l) ps)
+  
+  let string : string -> t
+    = fun s _out_pos _out_lev -> String s
+  
+  let nop : t = fun _out_pos _out_lev -> NOP
+  
+  let attr a t : t = fun assoc level ->
+    Attr (a, t assoc level)
+
+  let left    : 'a m -> 'a m          = fun p _a l -> p Left    l
+  let right   : 'a m -> 'a m          = fun p _a l -> p Right   l
+  let noassoc : 'a m -> 'a m          = fun p _a l -> p Noassoc l
+  let level : level -> 'a m -> 'a m = fun l p a _l -> p a l
+  let reset   : 'a m -> 'a m = fun t -> noassoc (level 0.0 t)
+  
+  let check_against_current_level : level -> [`Weaker | `Stronger | `Same] m = fun lev _out_pos out_lev ->
+    match compare out_lev lev with
+    | 1 -> `Weaker
+    | -1 -> `Stronger
+    | 0 -> `Same
+    | _ -> assert false
+  
+  let need_paren : assoc -> level -> bool m = fun assoc lev out_pos out_lev ->
+    match compare out_lev lev with
+    | 1 -> true
+    | -1 -> false
+    | 0 ->
+        begin match out_pos, assoc with
+        | Left, Left -> false
+        | Right, Right -> false
+        | _ -> true
+        end
+    | _ -> assert false
+  
+  
+  let parenbox : assoc -> level -> t -> t = fun assoc lev t ->
+    need_paren assoc lev >>= function
+      | true  -> box 1 & string "(" ++ reset t ++ string ")" 
+      | false -> t
+  
+  (** Common utilities *)
+  
+  let binop : assoc -> level -> op:t -> t -> t -> t =
+    fun assoc lev ~op:sep l r ->
+      parenbox assoc lev (level lev (left l ++ sep ++ right r))
+  
+  let list : level -> t -> t list -> t = 
+    fun lev sep f_elems ->
+      parenbox Noassoc lev (level lev (seq (List.intersperse sep f_elems)))
+  
+  let prefix : level -> op:t -> t -> t =
+    fun lev ~op:pref t -> 
+      let t = parenbox Right lev (pref ++ level lev (right t)) in
+      (* [uminus (uminus 1)] should not be printed out neither "- - 1" or "--1",
+         but "- -1" *)    
+      check_against_current_level lev >>= function
+        | `Same -> space ++ t 
+        | `Weaker | `Stronger -> t
+  
+  let postfix : level -> op:t -> t -> t =
+    fun lev ~op:postf t -> 
+      let t = parenbox Left lev (level lev (left t) ++ postf) in
+      (* [uminus (uminus 1)] should not be printed out neither "- - 1" or "--1",
+         but "- -1" *)    
+      check_against_current_level lev >>= function
+        | `Same -> t ++ space
+        | `Weaker | `Stronger -> t
+  
+  let parens left right ppr = string left ++ level (-1.0) ppr ++ string right
+  
+  module OCaml = struct
+    let mbinop assoc lev sep = binop assoc lev ~op:(space ++ string sep ++ space)
+  
+    (*
+    %nonassoc IN
+    %nonassoc below_SEMI
+    %nonassoc SEMI                          /* below EQUAL ({lbl=...; lbl=...}) */
+    *)
+  
+    let sequence = list 0.25 (string ";" ++ space)
+  
+    (*
+    %nonassoc LET                           /* above SEMI ( ...; let ... in ...) */
+    %nonassoc below_WITH
+    %nonassoc FUNCTION WITH                 /* below BAR  (match ... with ...) */
+    %nonassoc AND             /* above WITH (module rec A: SIG with ... and ...) */
+    %nonassoc THEN                          /* below ELSE (if ... then ...) */
+    %nonassoc ELSE                          /* (if ... then ... else ...) */
+    *)
+  
+    let if_then_else e1 e2 e3 = list 0.5 space [string "if"; reset e1; string "then"; e2; string "else"; e3]
+    let if_then e1 e2 = list 0.5 space [string "if"; reset e1; string "then"; e2]
+  
+    (*
+    %nonassoc LESSMINUS                     /* below COLONEQUAL (lbl <- x := e) */
+    %right    COLONEQUAL                    /* expr (e := e := e) */
+    %nonassoc AS
+    *)
+  
+    let ty_as = mbinop Noassoc 0.6 "as"
+  
+    (*
+    %left     BAR                           /* pattern (p|p|p) */
+    %nonassoc below_COMMA
+    %left     COMMA                         /* expr/expr_comma_list (e,e,e) */
+    *)
+  
+    let tuple = list 0.8 (string "," ++ space (* CR jfuruse: should be break *))
+  
+    (*
+    %right    MINUSGREATER                  /* core_type2 (t -> t -> t) */
+    *)
+  
+    let ( ^-> ) = mbinop Right 0.9 "->"
+  
+    (*
+    %right    OR BARBAR                     /* expr (e || e || e) */
+    %right    AMPERSAND AMPERAMPER          /* expr (e && e && e) */
+    %nonassoc below_EQUAL
+    %left     INFIXOP0 EQUAL LESS GREATER   /* expr (e OP e OP e) */
+    %right    INFIXOP1                      /* expr (e OP e OP e) */
+    %right    COLONCOLON                    /* expr (e :: e :: e) */
+    %left     INFIXOP2 PLUS PLUSDOT MINUS MINUSDOT  /* expr (e OP e OP e) */
+    %left     INFIXOP3 STAR                 /* expr (e OP e OP e) */
+    %right    INFIXOP4                      /* expr (e OP e OP e) */
+    *)
+  
+    let (+) = mbinop Left 1.0 "+"
+    let (-) = mbinop Left 1.0 "-"
+    let ( * ) = mbinop Left 2.0 "*"
+  
+    let ty_tuple = list 2.0 (space ++ string "* ")
+    (*
+    %nonassoc prec_unary_minus prec_unary_plus /* unary - */
+    *)
+  
+    let mprefix lev op = prefix lev ~op:(string op)
+    let uminus = mprefix 5.0 "-"
+    
+    (*
+    %nonassoc prec_constant_constructor     /* cf. simple_expr (C versus C x) */
+    %nonassoc prec_constr_appl              /* above AS BAR COLONCOLON COMMA */
+    %nonassoc below_SHARP
+    %nonassoc SHARP                         /* simple_expr/toplevel_directive */
+    %nonassoc below_DOT
+    %nonassoc DOT
+    /* Finally, the first tokens of simple_expr are above everything else. */
+    %nonassoc BACKQUOTE BANG BEGIN CHAR FALSE FLOAT INT INT32 INT64
+              LBRACE LBRACELESS LBRACKET LBRACKETBAR LIDENT LPAREN
+              NEW NATIVEINT PREFIXOP STRING TRUE UIDENT
+    *)
+  
+    let app = binop Left 100.0 ~op:space (* CR jfuruse: contiguous spaces must be contracted *)
+    
+  end
+  
+  (** Drivers *)
+  let format ?(assoc=Noassoc) ?(level=0.0) ppr ppf v = Token.format ppf (ppr v assoc level)
+  let buffer ppr buf ?(assoc=Noassoc) ?(level=0.0) v = Token.buffer buf (ppr v assoc level)
+  let show ppr ?(assoc=Noassoc) ?(level=0.0) v = Token.show (ppr v assoc level)
+  
+  module MakeDrivers(M : sig 
+    type t
+    val ppr : t -> token m (* = t *)
+  end) = struct
+    open M
+    let format ppf v = Token.format ppf (ppr v Noassoc 0.0)
+    let dump ppf v = Token.dump ppf (ppr v Noassoc 0.0)
+    let buffer buf ?(assoc=Noassoc) ?(level=0.0) v = Token.buffer buf (ppr v assoc level)
+    let show ?(assoc=Noassoc) ?(level=0.0) v = Token.show (ppr v assoc level)
+  end
+  
+  open OCaml
+  
+  module Test = struct
+    let num z = string (string_of_int z)
+    let id x = string x
+    let int = id "int"
+    let alpha = id "'a"
+  
+    let test t answer = 
+      let str = Token.show (t Noassoc 0.0) in
+      Format.eprintf "%s =?= %s@." str answer;
+      if str <> answer then failwith "FAILED";
+      Format.eprintf "%a@.@." Token.format  (t Noassoc 0.0);
+      Format.eprintf "%a@.@." Token.dump  (t Noassoc 0.0)
+  
+    let test () =
+      test (num 0) "0";
+      test (num 0 + num 0) "0 + 0";
+      test (num 0 + num 0 * num 0) "0 + 0 * 0";
+      test (num 0 * (num 0 + num 0)) "0 * (0 + 0)";
+      test ((num 1 + num 2) * num 3) "(1 + 2) * 3";
+      test (num 1 + (num 2 + num 3)) "1 + (2 + 3)"; (* It is as same as 1 + 2 + 3 but just semantically *)
+      test (num 1 - (num 2 - num 3)) "1 - (2 - 3)";
+      test (num 1 - num 2 - num 3) "1 - 2 - 3";
+      test (uminus (num 1)) "-1";
+      test (uminus (num 1 + num 2 + num 3))   "-(1 + 2 + 3)";
+      test (num 1 + uminus (num 1)) "1 + -1";
+      test (uminus (uminus (num 1))) "- -1";
+      test (int ^-> int ^-> int) "int -> int -> int";
+      test ((int ^-> int) ^-> int) "(int -> int) -> int";
+      test (ty_as (int ^-> int ^-> int) alpha) "int -> int -> int as 'a";
+      test ((ty_as (int ^-> int) alpha) ^-> int) "(int -> int as 'a) -> int";
+      test (tuple [num 1; num 2; num 3]) "1, 2, 3";
+      test (tuple [num 1; tuple [num 2; num 3]; num 4]) "1, (2, 3), 4";
+      test (app (app (id "x") (id "y")) (id "z")) "x y z";
+      test (app (id "x") (app (id "y") (id "z"))) "x (y z)";
+      test (app (id "x") (num 1 * num 2)) "x (1 * 2)";
+      test (sequence [ num 1 + num 2; num 1 + num 2; num 1 + num 2 ]) "1 + 2; 1 + 2; 1 + 2";
+      test (if_then_else (num 1 + num 2) (num 1 + num 2) (num 1 + num 2)) "if 1 + 2 then 1 + 2 else 1 + 2";
+      test (if_then_else (num 1 + num 2) (num 1 + num 2) (num 1) + num 2) "(if 1 + 2 then 1 + 2 else 1) + 2";
+      test (app (if_then_else (num 1 + num 2) (num 1 + num 2) (num 1)) (num 2)) "(if 1 + 2 then 1 + 2 else 1) 2";
+      test (app (id "f") (if_then_else (num 1 + num 2) (num 1 + num 2) (num 1 + num 2))) "f (if 1 + 2 then 1 + 2 else 1 + 2)";
+      test (if_then_else 
+              (sequence [ num 1 + num 2; num 1 + num 2 ])
+              (sequence [ num 1 + num 2; num 1 + num 2 ])
+              (sequence [ num 1 + num 2; num 1 + num 2 ])) "if 1 + 2; 1 + 2 then (1 + 2; 1 + 2) else (1 + 2; 1 + 2)";
+      test (sequence [if_then_else
+                   (sequence [ num 1 + num 2; num 1 + num 2 ])
+                   (sequence [ num 1 + num 2; num 1 + num 2 ])
+                   (sequence [ num 1 + num 2; num 1 + num 2 ]);
+                 num 1 + num 2 ]) "if 1 + 2; 1 + 2 then (1 + 2; 1 + 2) else (1 + 2; 1 + 2); 1 + 2";
+      test (if_then
+              (sequence [ num 1 + num 2; num 1 + num 2 ])
+              (sequence [ num 1 + num 2; num 1 + num 2 ])) "if 1 + 2; 1 + 2 then (1 + 2; 1 + 2)";
+      test (sequence [if_then 
+                   (sequence [ num 1 + num 2; num 1 + num 2 ])
+                   (sequence [ num 1 + num 2; num 1 + num 2 ]);
+                 num 1 + num 2 ]) "if 1 + 2; 1 + 2 then (1 + 2; 1 + 2); 1 + 2";
+      prerr_endline "done"
+  
+  end
+end
+

File lib/aprinter.mli

View file
+open Spotlib.Spot
+
+(** {6 Display machine with Format like capability } *)
+       
+module Make(A : sig
+  type t with conv(ocaml_of)
+  val format : (Format.t -> unit) (** printer for the internal *)
+               -> Format.t -> t -> unit 
+  val buffer : (Buffer.t -> unit) (** buffer output for the internal *)
+               -> Buffer.t -> t -> unit
+end) : sig
+
+  module Token : sig
+    type t =
+      | String of string
+      | Box of int * t  (** "@[<n>...@]" *)
+      | VBox of int * t (** "@[<vn>...@]" *)
+      | Cut             (** "@," (known also as Good Break) *)
+      | Space           (** "@ " *)
+      | Flush           (** "@." *)
+      | Seq of t list
+      | NOP
+      | Attr of A.t * t (** ignored by [format], [dump], [buffer] and [show] *) 
+
+    (** {6 Printer to strings } 
+
+     They simply ignore attributes.
+     *)
+                        
+    val format : Format.t -> t -> unit
+    val dump   : Format.t -> t -> unit
+    val buffer : Buffer.t -> t -> unit
+    val show   : t -> string
+  end
+  
+  type token = Token.t
+
+  (** Primitives *)
+  type assoc = Left | Right | Noassoc
+  type level = float
+  
+  type 'a m = assoc -> level -> 'a
+  module Monad : Monad_intf.T with type 'a t = 'a m
+  
+  type t = token m
+  
+  val box    : int -> t -> t
+  val vbox   : int -> t -> t
+  val ( ++ ) : t -> t -> t
+  val cut    : t
+  val space  : t
+  val flush  : t
+  val seq    : t list -> t
+  val string : string -> t
+  val nop    : t
+  val attr : A.t -> t -> t
+  
+  (** {6 Level and environments} *)
+  
+  val left    : 'a m -> 'a m           
+  (** Put the arg in the "left" environment *)
+  val right   : 'a m -> 'a m          
+  (** Put the arg in the "right" environment *)
+  val noassoc : 'a m -> 'a m        
+  (** Put the arg in the "noassoc" environment *)
+  val level   : level -> 'a m -> 'a m 
+  (** Put the arg in the specified level *)
+  val reset   : 'a m -> 'a m          
+  (** Put the arg in "noassoc" env and 0.0 level *)
+  (* CR jfuruse: Should be -1.0 ? *)
+  
+  val check_against_current_level : level -> [ `Same | `Stronger | `Weaker ] m
+  (** Compare the argument against the current level:
+      `Same     : the same as the current level
+      `Stronger : the argument is stronger than the current
+      `Weak     : the argument is weaker than the current
+  *)
+  
+  val need_paren : assoc -> level -> bool m
+  (** Check the printer object of the level [level] requires parenthesis wrapping or not *)
+  
+  (** Utilities 
+      These implements common printing with auto parenthesis wrapping.
+      Note: They may not suit with your own taste.
+  *)
+
+  val parenbox : assoc -> level -> t -> t
+  val binop    : assoc -> level -> op:t -> t -> t -> t
+  val list     : level -> t -> t list -> t
+  (** [list lev sep ts] is to create a list without a box *)
+  
+  val prefix   : level -> op:t -> t -> t
+  val postfix  : level -> op:t -> t -> t
+  
+  val parens : string -> string -> t -> t
+  (** Surround the given t with the left and right strings.
+      The level for the internal t is reset to -1.0 to prevent from having auto parens for it *)
+  
+  (** OCaml like printers *)
+  module OCaml : sig
+    val sequence     : t list -> t
+    val if_then_else : t -> t -> t -> t
+    val if_then      : t -> t -> t
+    val ty_as         : t -> t -> t (** for [t as 'a] *)
+    val tuple        : t list -> t
+    val ( ^-> )      : t -> t -> t
+    val ( + )        : t -> t -> t
+    val ( - )        : t -> t -> t
+    val ( * )        : t -> t -> t
+    val ty_tuple     : t list -> t
+    val uminus       : t -> t
+    val app          : t -> t -> t
+  end
+  
+  (** Drivers *)
+  val buffer : ('a -> t) -> Buffer.t -> ?assoc:assoc -> ?level:level -> 'a -> unit
+  val show : ('a -> t) -> ?assoc:assoc -> ?level:level -> 'a -> string
+  val format : ?assoc:assoc -> ?level:level -> ('a -> t) -> Format.t -> 'a -> unit
+  (** [format] has a different type than [buffer] and [show], 
+      so that it could be used smoothly in [Format.fprintf]'s functional setting.
+  *)
+  
+  module MakeDrivers(M : sig type t val ppr : t -> token m end) : sig
+    open M
+    val format : Format.t -> t -> unit
+    val dump   : Format.t -> t -> unit
+    val buffer : Buffer.t -> ?assoc:assoc -> ?level:level -> t -> unit
+    val show   : ?assoc:assoc -> ?level:level -> t -> string
+  end
+  
+  module Test :sig 
+    val test : unit -> unit
+  end
+end