Something went wrong. Try again.
ocaml
Something went wrong. Try again.
4.6 kB · 125 lines
OCaml
at pp-ast
123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126open Code
module Fmt = struct include Fmt
let list ~sep pp = Fmt.list ~sep ppend
let is_ws = String.for_all (function ' ' | '\t' | '\n' -> true | _ -> false)
let trie = Fmt.(list ~sep:(Fmt.any "/") string)
let break ignore_ws ppf () = if ignore_ws then Fmt.pf ppf "@;" else Fmt.nop ppf ()
let rec node ~ignore_ws ppf c = match c with | Text s -> if ignore_ws && is_ws s then Fmt.nop ppf () else Fmt.string ppf s | Verbatim s -> Fmt.pf ppf "\\verb<<|%s<<" s | Group (Squares, t) -> Fmt.pf ppf "[%a]" (code ~ignore_ws:false) t | Group (Braces, t) -> Fmt.pf ppf "{%a}" (code ~ignore_ws:false) t | Group (Parens, t) -> Fmt.pf ppf "(%a)" (code ~ignore_ws:false) t (* A little breathing space for toplevel stuff *) | Ident path -> Fmt.pf ppf "%a\\%a" (break ignore_ws) () trie path | Subtree (name, t) -> Fmt.pf ppf "%a%a" (break ignore_ws) () subtree (name, t) | Xml_ident (None, t) -> Fmt.pf ppf "\\<%s>" t | Xml_ident (Some v, t) -> Fmt.pf ppf "\\<%s:%s>" v t | Decl_xmlns (s, u) -> Fmt.pf ppf "\\xmlns:%s{%s}" s u | Put (path, t) -> Fmt.pf ppf "\\put\\%a{%a}@;" (located trie) path (code ~ignore_ws:false) t | Default (path, t) -> Fmt.pf ppf "\\default\\%a{%a}@;" (located trie) path (code ~ignore_ws:false) t | Math (Display, t) -> Fmt.pf ppf "##{%a}" (code ~ignore_ws:false) t | Math (Inline, t) -> Fmt.pf ppf "#{%a}" (code ~ignore_ws:false) t | Hash_ident s -> Fmt.pf ppf "#%s" s | Dx_query (s, ns, ps) -> Fmt.pf ppf "\\datalog{ ?%s -: {%a} %a}" s (Fmt.list ~sep:(Fmt.any " ") (code ~ignore_ws:false)) ns (Fmt.list ~sep:(Fmt.any " ") (code ~ignore_ws:false)) ps | Dx_prop (c, cs) -> Fmt.pf ppf "%a %a" (code ~ignore_ws:false) c Fmt.(list ~sep:(Fmt.any " ") (code ~ignore_ws:false)) cs | Dx_var s -> Fmt.pf ppf "?%s" s | Dx_const_content c -> Fmt.pf ppf "'{%a}" (code ~ignore_ws:false) c | Dx_sequent (c, cs) -> Fmt.pf ppf "%a -: %a" (code ~ignore_ws:false) c Fmt.(list ~sep:Fmt.nop (code ~ignore_ws:false)) cs | Dx_const_uri uri -> assert false | Open path -> Fmt.pf ppf "\\open%a@;" trie path | Scope t -> Fmt.pf ppf "\\scope%a@;" (code ~ignore_ws:true) t | Object o -> object_ ppf o | Def (path, bindings, t) -> def ppf (path, bindings, t) | Patch p -> patch ppf p | Import (visibility, s) -> import ppf (visibility, s) | Namespace (p, c) -> Fmt.pf ppf "\\namespace\\%a{%a}@;" trie p (code ~ignore_ws:true) c | Let (name, bindings, code) -> let_ ppf (name, bindings, code) | Get p -> Fmt.pf ppf "\\get\\%a" (located trie) p | Fun (bindings, code) -> fun_ ppf (bindings, code) | Comment c -> Fmt.pf ppf "%%%s@;" c | Alloc p -> Fmt.pf ppf "\\alloc\\%a@;" trie p | Call (c, args) -> Fmt.pf ppf "\\call{%a}{%s}" (code ~ignore_ws:false) c args | Error s -> Fmt.invalid_arg "Error: %s" s
and subtree ppf (name, t) = match name with | None -> Fmt.pf ppf "@[<v 2>\\subtree{@;%a@]@;}" (code ~ignore_ws:true) t | Some name -> Fmt.pf ppf "@[<v 2>\\subtree[%a]{%a@]@;}" (located Fmt.string) name (code ~ignore_ws:true) t
and self_ ppf = function | None -> Fmt.nop ppf () | Some name -> Fmt.pf ppf "[%s]" name
and method_ ppf (method_name, method_code) = Fmt.pf ppf "@[<v 2>[%s]{%a}@]" method_name (code ~ignore_ws:false) method_code
and object_ ppf ({self = s; methods} : t _object) = Fmt.pf ppf "@[<v 2>\\object%a{%a}" self_ s Fmt.(list ~sep:Fmt.cut method_) methods
and import ppf (v, b) = match v with | Base.Public -> Fmt.pf ppf "\\export{%a}@;" (located Fmt.string) b | Base.Private -> Fmt.pf ppf "\\import{%a}@;" (located Fmt.string) b
and binding ppf ((strict, s) : string Base.binding) = match strict with | Base.Strict -> Fmt.pf ppf "[%s]" s | Base.Lazy -> Fmt.pf ppf "[~%s]" s
and def ppf (path, bindings, t) = Fmt.pf ppf "\\def\\%a%a{%a}@;" trie path Fmt.(list ~sep:Fmt.nop binding) bindings (code ~ignore_ws:false) t
and patch ppf ({obj; self = s; super = _; methods} : t patch) = Fmt.pf ppf "\\patch{%a}%a{%a}@;" (code ~ignore_ws:false) obj self_ s Fmt.(list ~sep:Fmt.cut method_) methods
and let_ ppf (name, bindings, c) = Fmt.pf ppf "\\let\\%a%a{%a}" trie name Fmt.(list ~sep:Fmt.nop binding) bindings (code ~ignore_ws:false) c
and fun_ ppf (bindings, c) = Fmt.pf ppf "\\fun%a{%a}@;" Fmt.(list ~sep:Fmt.nop binding) bindings (code ~ignore_ws:false) c
and located : 'a. 'a Fmt.t -> 'a Range.located Fmt.t = fun pp ppf t -> pp ppf t.Range.value
and code ?(ignore_ws = true) ppf = Fmt.list ~sep:Fmt.nop (located (node ~ignore_ws)) ppf
let code = Fmt.vbox (code ~ignore_ws:true)