ui node tree pretty-printer
This commit is contained in:
cqc
173
human.ml
173
human.ml
@ -1,5 +1,7 @@
|
||||
(*
|
||||
|
||||
ALWAYS BREAK UP THE PROBLEM INTO SMALLER CHUNKS BITCH!!
|
||||
|
||||
a computation console
|
||||
|
||||
- irmin store provides a tree of data objects
|
||||
@ -1254,7 +1256,9 @@ module Panel = struct
|
||||
and atom =
|
||||
[ `Image of image
|
||||
| `Uchar of Uchar.t
|
||||
| `Boundary of [`Word | `Line | `Sentance | `Hint] ]
|
||||
| `Boundary of [`Word | `Line | `Sentance]
|
||||
| `Hint of [`Line | `Other]
|
||||
| `Empty ]
|
||||
|
||||
and attr =
|
||||
[ `Style of style
|
||||
@ -1280,7 +1284,7 @@ module Panel = struct
|
||||
|
||||
let node (t : t) = set_parent_on_children {parent= None; t}
|
||||
let empty_image = (Image.empty, V2.zero)
|
||||
let empty_node = node (`Atom (`Image empty_image))
|
||||
let empty_node = node (`Atom `Empty)
|
||||
let style (s : Style.t) (n : node) = node (`Attr (`Style s, n))
|
||||
|
||||
let rec traverse_nodes ~(f : node -> node option) (n : node) :
|
||||
@ -1341,70 +1345,110 @@ module Panel = struct
|
||||
let ( ^^ ) = join_x
|
||||
let ( ^/^ ) = join_y
|
||||
|
||||
let rec pp_ui : node F.t =
|
||||
fun ppf v ->
|
||||
let atom a =
|
||||
F.pf ppf "`Atom " ;
|
||||
match a with
|
||||
| `Image _ -> F.pf ppf "`Image"
|
||||
| `Uchar c ->
|
||||
F.pf ppf "`Uchar " ;
|
||||
if Uchar.is_char c then F.pf ppf "%c" (Uchar.to_char c)
|
||||
else F.pf ppf "0x%x" (Uchar.to_int c)
|
||||
| `Boundary b ->
|
||||
F.pf ppf "`Boundary " ;
|
||||
F.pf ppf
|
||||
( match b with
|
||||
| `Word -> "`Word"
|
||||
| `Line -> "`Line"
|
||||
| `Sentance -> "`Sentance"
|
||||
| `Hint -> "`Hint" ) in
|
||||
let attr a =
|
||||
F.pf ppf "`Attr " ;
|
||||
F.pf ppf
|
||||
( match a with
|
||||
| `Style _ -> "`Style ..., "
|
||||
| `Pad _ -> "`Pad ..., "
|
||||
| `Shift _ -> "`Shift ..., "
|
||||
| `Cursor -> "`Cursor "
|
||||
| `Handler _ -> "`Handler ..., " ) in
|
||||
let join (d, a, b) =
|
||||
F.pf ppf "`Join " ;
|
||||
( match d with
|
||||
| `X -> F.pf ppf "`X "
|
||||
| `Y -> F.pf ppf "`Y "
|
||||
| `Z -> F.pf ppf "`Z " ) ;
|
||||
F.parens pp_ui ppf b ; F.parens pp_ui ppf a in
|
||||
match v.t with
|
||||
| `Join x -> join x
|
||||
| `Attr (x, n) -> attr x ; F.parens pp_ui ppf n
|
||||
| `Atom x -> atom x
|
||||
let pp_uchar ppf v =
|
||||
if Uchar.is_char v then Fmt.pf ppf "'%c'" (Uchar.to_char v)
|
||||
else Fmt.Dump.uchar ppf v
|
||||
|
||||
let pp_atom ppf v =
|
||||
let open Fmt in
|
||||
( match v with
|
||||
| `Image _ -> any "`Image"
|
||||
| `Uchar c -> any "`Uchar " ++ const pp_uchar c
|
||||
| `Boundary b -> (
|
||||
any "`Boundary "
|
||||
++
|
||||
match b with
|
||||
| `Word -> any "`Word"
|
||||
| `Line -> any "`Line"
|
||||
| `Sentance -> any "`Sentance" )
|
||||
| `Hint h ->
|
||||
any "`Hint "
|
||||
++ any (match h with `Line -> "`Line" | `Other -> "`Other")
|
||||
| `Empty -> any "`Empty" )
|
||||
ppf ()
|
||||
|
||||
let tess v = F.epr "%a" pp_atom v
|
||||
|
||||
let pp_attr ppf v =
|
||||
let open Fmt in
|
||||
(any
|
||||
( match v with
|
||||
| `Style _ -> "`Style ..."
|
||||
| `Pad _ -> "`Pad ..."
|
||||
| `Shift _ -> "`Shift ..."
|
||||
| `Cursor -> "`Cursor"
|
||||
| `Handler _ -> "`Handler ..." ) )
|
||||
ppf ()
|
||||
|
||||
let pp_dir ppf v =
|
||||
F.pf ppf "%s"
|
||||
(match v with `X -> "`X" | `Y -> "`Y" | `Z -> "`Z")
|
||||
|
||||
let rec pp_node ppf v =
|
||||
let open Fmt in
|
||||
pf ppf "@[<hov>%a@]" pp_t v.t
|
||||
|
||||
and pp_t ppf v =
|
||||
let open Fmt in
|
||||
match v with
|
||||
| `Join (d, a, b) ->
|
||||
pf ppf "`Join %a"
|
||||
(parens
|
||||
( const pp_dir d ++ comma ++ const pp_node a ++ comma
|
||||
++ const pp_node b ) )
|
||||
()
|
||||
| `Attr (a, n) ->
|
||||
pf ppf "`Attr %a"
|
||||
(parens (const pp_attr a ++ comma ++ const pp_node n))
|
||||
()
|
||||
| `Atom x -> pf ppf "`Atom %a" pp_atom x
|
||||
|
||||
(* there's no difference between a node element and a node list what, tho an element is kinda like a node.t,
|
||||
so i guess we'll use that to kinda emulate append (vs. concat which is what join is)
|
||||
ugh maybe using types to build this double-linked binary-tree data structure is not a good idea.
|
||||
I'm STONED, so i'm not making sense, but i'm gonna carry on anyway and see what happens.
|
||||
So i think what is really happening is that i'm defining the `list` for this node type that allows `append`.
|
||||
The main problem with this thought is that you can't do anything but append with the datastructure.
|
||||
*)
|
||||
let new_append () = empty_node
|
||||
|
||||
let append (d : dir) (l : unit -> node) (n : node) : unit -> node
|
||||
=
|
||||
fun () ->
|
||||
set_parent_on_children {parent= None; t= `Join (d, l (), n)}
|
||||
|
||||
module Text = struct
|
||||
let rec insert_string (n : node) (str : string) : node =
|
||||
let rec _of_string (la : unit -> node) (str : string) :
|
||||
unit -> node =
|
||||
let uudec = Uutf.decoder (`String str) in
|
||||
let rec dec (n' : node) : 'a * node =
|
||||
let rec dec (lx : unit -> node) : 'a * (unit -> node) =
|
||||
match Uutf.decode uudec with
|
||||
| `Malformed b -> dec (insert_string n' (String.escaped b))
|
||||
| (`Await | `Uchar _ | `End) as x -> (x, n') in
|
||||
| `Malformed b -> dec (_of_string lx (String.escaped b))
|
||||
| (`Await | `Uchar _ | `End) as x -> (x, lx) in
|
||||
let uuline = Uuseg.create `Line_break in
|
||||
let rec line (n' : node) : node =
|
||||
let rec char (x, t) (line : node) =
|
||||
let rec new_line la' : unit -> node =
|
||||
let rec char (x, lx) (ly : unit -> node) =
|
||||
match Uuseg.add uuline x with
|
||||
| `End as x -> (line, x)
|
||||
| `Boundary as x when Uuseg.mandatory uuline -> (line, x)
|
||||
| `Await -> char (dec t) line
|
||||
| `End as x -> (ly, x)
|
||||
| `Boundary as x when Uuseg.mandatory uuline -> (ly, x)
|
||||
| `Await -> char (dec lx) ly
|
||||
| `Boundary ->
|
||||
char
|
||||
(`Await, t)
|
||||
(line ^^ node (`Atom (`Boundary `Hint)))
|
||||
(`Await, append `X lx (node (`Atom (`Hint `Line))))
|
||||
ly
|
||||
| `Uchar c ->
|
||||
char (`Await, t) (line ^^ node (`Atom (`Uchar c)))
|
||||
in
|
||||
match char (`Await, n') n' with
|
||||
| l, `Boundary -> line (l ^/^ node (`Atom (`Boundary `Line)))
|
||||
char
|
||||
(`Await, append `X lx (node (`Atom (`Uchar c))))
|
||||
ly in
|
||||
match char (`Await, la') la' with
|
||||
| l, `Boundary ->
|
||||
new_line
|
||||
(append `Y la'
|
||||
((append `X l (node (`Atom (`Boundary `Line)))) ()) )
|
||||
| l, `End -> l in
|
||||
line n
|
||||
new_line la
|
||||
|
||||
let of_string str = _of_string new_append str ()
|
||||
|
||||
(* let segment ?(boundary = `Word) ?(label = `Word) (node : node) :
|
||||
node =
|
||||
@ -1444,7 +1488,7 @@ module Panel = struct
|
||||
let text str : node = insert_string str |> sentances |> words *)
|
||||
end
|
||||
|
||||
let text = Text.insert_string
|
||||
let text = Text.of_string
|
||||
|
||||
module Draw = struct
|
||||
type d = [`X | `Y | `Z]
|
||||
@ -1519,6 +1563,8 @@ module Panel = struct
|
||||
| `Image i -> i
|
||||
| `Uchar uc -> uchar style uc
|
||||
| `Boundary _ -> empty_image
|
||||
| `Hint _ -> empty_image
|
||||
| `Empty -> empty_image
|
||||
|
||||
and attr ?(style = Style.empty) (attr, node) : image =
|
||||
match attr with
|
||||
@ -1639,7 +1685,14 @@ module Panel = struct
|
||||
let bind = Key.Bind.init bindings in
|
||||
let n' = insert_attr `Cursor n in
|
||||
let c = ref n in
|
||||
F.epr "%a@." pp_ui n' ;
|
||||
Format.(
|
||||
F.epr
|
||||
"@[<hv> F.stderr margin: %d, max_indent: %d, max_boxes: %d \
|
||||
@]@."
|
||||
(pp_get_margin F.stderr ())
|
||||
(pp_get_max_indent F.stderr ())
|
||||
(pp_get_max_boxes F.stderr ())) ;
|
||||
F.epr "@[<v>%a@]@." pp_node n' ;
|
||||
node
|
||||
(`Attr
|
||||
( `Handler
|
||||
@ -1649,7 +1702,7 @@ module Panel = struct
|
||||
c :=
|
||||
insert_attr `Cursor
|
||||
(perform_action x (remove_attr !c)) ;
|
||||
F.epr "%a@." pp_ui !c ;
|
||||
F.epr "%a@." pp_node !c ;
|
||||
Lwt.return_none
|
||||
| [] -> Lwt.return_some e )
|
||||
, n ) )
|
||||
@ -1700,7 +1753,7 @@ module Panel = struct
|
||||
(Text.insert_string empty_node "hello bitch")
|
||||
(Text.insert_string empty_node
|
||||
"!\n sup daddy" ) ) )*)
|
||||
(Text.insert_string empty_node "test 1 2 3") ) ) )
|
||||
(Text.of_string "test 1 2 3") ) ) )
|
||||
(* ) *)
|
||||
end
|
||||
end
|
||||
|
||||
Reference in New Issue
Block a user