diff --git a/human.ml b/human.ml index 34809eb..b4b3e3c 100644 --- a/human.ml +++ b/human.ml @@ -1260,7 +1260,7 @@ module Panel = struct and atom = [ `Image of image | `Uchar of Uchar.t - | `Boundary of [`Word | `Line | `Sentance] + | `Boundary of boundary | `Hint of [`Line | `Other] | `Empty ] @@ -1273,6 +1273,7 @@ module Panel = struct and dir = [`X | `Y | `Z] and dim = Size2.t and image = Wall.image * dim + and boundary = [`Char | `Word | `Phrase | `Line | `Page | `Text] and style = Style.t and handler = node -> Event.t -> Event.t option Lwt.t @@ -1298,6 +1299,109 @@ module Panel = struct let empty_node () = node (`Atom `Empty) let style (s : Style.t) (n : node) = node (`Attr (`Style s, n)) + module Pp = struct + 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_boundary ppf v = + F.any + ( match v with + | `Char -> "`Char" + | `Word -> "`Word" + | `Phrase -> "`Phrase" + | `Line -> "`Line" + | `Page -> "`Page" + | `Text -> + "`Text" + (* text is like a file (unicode calls it End Of Text) *) + ) + ppf () + + 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 " ++ const pp_boundary b + | `Hint h -> + any "`Hint " + ++ any + (match h with `Line -> "`Line" | `Other -> "`Other") + | `Empty -> any "`Empty" ) + ppf () + + 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 pp_node_n ppf v = F.(pf ppf "%a" int v.n) + + let rec _pp_t child ppf v = + let open Fmt in + match v with + | `Atom x -> pf ppf "`Atom %a" pp_atom x + | `Attr (a, n) -> + pf ppf "`Attr %a" + (parens (const pp_attr a ++ comma ++ const child n)) + () + | `Join (d, a, b) -> + pf ppf "`Join %a" + (parens + ( const pp_dir d ++ comma ++ const child a ++ comma + ++ const child b ) ) + () + + and _pp_node child ppf v = + let open Fmt in + pf ppf "@[%a@]" + (braces + (record + [ field "n" (fun v -> v.n) int + ; field "t" (fun v -> v.t) (_pp_t child) + ; field "parent" + (fun v -> v.parent) + (option pp_node_n) ] ) ) + v + + and pp_node_n_record = + F.( + braces + (record ~sep:semi [field "n" Fun.id pp_node_n; any "..."])) + + and pp_node ppf = _pp_node pp_node_n_record ppf + and pp_dump_node ppf = _pp_node pp_dump_node ppf + + let pp_t = _pp_t pp_node_n_record + + let rec pp_node_structure ppf v = + F.( + const int v.n + ++ parens + (concat ~sep:comma + ( match v.t with + | `Atom a -> [const pp_atom a] + | `Attr (a, n) -> + [const pp_attr a; const pp_node_structure n] + | `Join (d, l, r) -> + [ const pp_dir d; const pp_node_structure l + ; const pp_node_structure r ] ) )) + ppf () + end + + open Pp + let rec traverse_nodes ~(f : node -> node option) (n : node) : unit = match f n with @@ -1359,87 +1463,14 @@ module Panel = struct let ( ^*^ ) = join_z let append_ d (l : node -> node) (a : node) : node -> node = - fun n -> l (join_ d a n) + F.epr "append_%a@." pp_dir d ; + fun n -> l (join_ d a n) + let empty_append = Fun.id let append_x = append_ `X let append_y = append_ `Y let append_z = append_ `Z - 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 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 pp_node_n ppf v = - F.( - pf ppf "%a" - (record [field "n" (fun v -> v.n) int; any "..."]) - v) - - let rec _pp_t child ppf v = - let open Fmt in - match v with - | `Atom x -> pf ppf "`Atom %a" pp_atom x - | `Attr (a, n) -> - pf ppf "`Attr %a" - (parens (const pp_attr a ++ comma ++ const child n)) - () - | `Join (d, a, b) -> - pf ppf "`Join %a" - (parens - ( const pp_dir d ++ comma ++ const child a ++ comma - ++ const child b ) ) - () - - and _pp_node child ppf v = - let open Fmt in - pf ppf "@[%a@]" - (braces - (record - [ field "n" (fun v -> v.n) int - ; field "t" (fun v -> v.t) (_pp_t child) - ; field "parent" - (fun v -> v.parent) - (option (fun ppf v -> pf ppf "%a" int v.n)) ] ) ) - v - - and pp_node ppf v = _pp_node pp_node_n ppf v - and pp_dump_node ppf v = _pp_node pp_dump_node ppf v - - let pp_t = _pp_t pp_node_n - (* 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. @@ -1449,71 +1480,85 @@ module Panel = struct *) module Text = struct - let rec of_string (str : string) : node = - let uudec = Uutf.decoder (`String str) in - let rec dec (lx : node -> node) : 'a * (node -> node) = - match Uutf.decode uudec with - | `Malformed b -> - dec (append_x lx (of_string (String.escaped b))) - | (`Await | `Uchar _ | `End) as x -> (x, lx) in - let uuline = Uuseg.create `Line_break in - let rec char (x, (l : node -> node)) = - match Uuseg.add uuline x with - | `End as x -> (l, x) - | `Await -> char (dec l) - | `Boundary as x when Uuseg.mandatory uuline -> (l, x) - | `Boundary -> - char (`Await, append_x l (node (`Atom (`Hint `Line)))) - | `Uchar c -> - char (`Await, append_x l (node (`Atom (`Uchar c)))) + let rec _of_string + (segmenter : + 'a + -> [`Uchar of Uchar.t | `Await | `End] + -> 'a * [`Uchar of Uchar.t | `Await | `End] ) dec (ly, lx) + = + F.epr "_of_string@." ; + let rec segment aa ll = + F.epr "segment %s -> " + ( match aa with + | `Await -> "`Await" + | `End -> "`End" + | `Uchar c -> F.str "`Uchar U+%x" (Uchar.to_int c) ) ; + match segmenter ll aa with + | (ly', lx'), `Await -> ( + F.epr "`Await -> decode@." ; + match Uutf.decode dec with + | `Malformed b -> + F.epr + "Text.dec (Uutf.decode uudec)=`Malformed \"%s\"@." + (String.escaped b) ; + _of_string segmenter dec + (ly', append_x lx' (of_string (String.escaped b))) + | (`End | `Await | `Uchar _) as a -> segment a (lx', ly') + ) + | (ly', lx'), `Uchar c -> + F.epr "`Uchar U+%04x -> `Await@." (Uchar.to_int c) ; + segment `Await + (ly', append_x lx' (node (`Atom (`Uchar c)))) + | (ly', lx'), `End -> + F.epr "`End ;@." ; + append_y ly' (lx' (node (`Atom (`Boundary `Text)))) in - let rec new_line la : node -> node = - match char (`Await, la) with - | l, `Boundary -> - new_line - (append_y la (l (node (`Atom (`Boundary `Line))))) - | l, `End -> l in - (new_line (fun n -> n)) (empty_node ()) + let r = segment `Await (ly, lx) in + F.epr "@." ; r - (* let segment ?(boundary = `Word) ?(label = `Word) (node : node) : - node = - let uuseg = Uuseg.create boundary in - traverse_regions - ~node:(fun node -> node) - ~region:(fun ~parent (r, c) ~child -> - match child.child with - | `Atom (`Uchar uc) -> - let rec seg ((t : node Trope.t), (c : Region.cursor)) - e' = - match Uuseg.add uuseg e' with - | `Boundary -> - seg - ( Trope.put_right t c - {parent; child= `Atom (`Boundary label)} - , Trope.cursor_after c ) - `Await - | `End | `Await -> (t, c) - | `Uchar ch -> - seg - ( Trope.put_right t c - {parent; child= `Atom (`Uchar ch)} - , c ) - `Await in - let r', c' = seg (r.t, c) (`Uchar uc) in - ({r with t= r'}, c') - | _ -> (r, c) ) - node + and of_string str = + (_of_string + (fun l s -> + F.epr "segmenter[of_string] %s -> " + ( match s with + | `Await -> "`Await" + | `End -> "`End" + | `Uchar c -> F.str "`Uchar U+%x" (Uchar.to_int c) ) ; + (l, s) ) + (Uutf.decoder + ~nln:(`Readline (Uchar.of_int 0x000A)) + (`String str) ) + (empty_append, empty_append) ) + (node (`Atom (`Boundary `Text))) - let words node : node = - segment ~boundary:`Word ~label:`Word node - - let sentances node : node = - segment ~boundary:`Sentence ~label:`Sentance node - - let text str : node = insert_string str |> sentances |> words *) + and lines str = + let rec line_seg u (ly, lx) s = + F.epr "line_seg %s -> " + ( match s with + | `Await -> "`Await" + | `End -> "`End" + | `Uchar c -> F.str "`Uchar U+%x" (Uchar.to_int c) ) ; + match Uuseg.add u s with + | (`End | `Await | `Uchar _) as s' -> ((lx, ly), s') + | `Boundary when Uuseg.mandatory u -> + line_seg u + ( append_y ly (lx (node (`Atom (`Boundary `Line)))) + , empty_append ) + `Await + | `Boundary -> + line_seg u + (ly, append_x lx (node (`Atom (`Hint `Line)))) + `Await in + (_of_string + (line_seg (Uuseg.create `Line_break)) + (Uutf.decoder + ~nln:(`Readline (Uchar.of_int 0x000A)) + (`String str) ) + (empty_append, empty_append) ) + (node (`Atom (`Boundary `Text))) end - let text = Text.of_string + let text = Text.lines module Draw = struct type d = [`X | `Y | `Z] @@ -1609,14 +1654,11 @@ module Panel = struct end module Action = struct - type segment_type = - [`Char | `Word | `Phrase | `Line | `Page | `Region] - - and segment = - [ `Beginning of segment_type - | `Forward of segment_type - | `Backward of segment_type - | `End of segment_type ] + type segment = + [ `Beginning of boundary + | `Forward of boundary + | `Backward of boundary + | `End of boundary ] and t = [ `Move of segment @@ -1655,23 +1697,12 @@ module Panel = struct | `Out -> "`Out" ) ppf () - let pp_segment_type ppf v = - any - ( match v with - | `Char -> "`Char" - | `Word -> "`Word" - | `Phrase -> "`Phrase" - | `Line -> "`Line" - | `Page -> "`Page" - | `Region -> "`Region" ) - ppf () - let pp_segment ppf v = ( match v with - | `Beginning s -> any "`Beginning " ++ const pp_segment_type s - | `Forward s -> any "`Forward " ++ const pp_segment_type s - | `Backward s -> any "`Backward " ++ const pp_segment_type s - | `End s -> any "`End " ++ const pp_segment_type s ) + | `Beginning s -> any "`Beginning " ++ const pp_boundary s + | `Forward s -> any "`Forward " ++ const pp_boundary s + | `Backward s -> any "`Backward " ++ const pp_boundary s + | `End s -> any "`End " ++ const pp_boundary s ) ppf () let pp_t ppf v = @@ -1816,14 +1847,8 @@ module Panel = struct | Some n -> n | None -> n ) } in Format.pp_set_max_boxes F.stderr 64 ; - Format.pp_set_margin F.stderr 120 ; - Format.( - F.epr - "@[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 ())) ; + (*full screen fynn *) + Format.pp_safe_set_geometry F.stderr ~max_indent:150 ~margin:230 ; node (`Attr ( `Handler @@ -1833,7 +1858,7 @@ module Panel = struct c.sel <- remove_attr c.sel ; F.epr "textedit_handler c.root=@.@[%a@]@.c.sel=%a@." - pp_dump_node c.root pp_node c.sel ; + pp_node_structure c.root pp_node c.sel ; ( match perform_action x c with | Some _ -> F.epr @@ -1888,15 +1913,17 @@ module Panel = struct (Lwd.pure (textedit_handler (style Style.dark - (join_y - (* (join_y - (Text.of_string - "-- welcome to my land of idiocy ---" ) - (join_x *) - (Text.of_string "hello bitch") - (* - (Text.of_string "!\n sup daddy") ) ) *) - (Text.of_string "123") ) ) ) ) + (* (join_y + (join_y + (Text.of_string + "-- welcome to my land of idiocy ---" ) + ( ( Text.of_string "hello bitch" + ^^ Text.of_string "!\n sup daddy" ) + ^/^ (text "hello bitch" ^^ text "!\n sup daddy") + ^/^ text "hello bitch" ^/^ text "!\n sup daddy" + ) ) *) + (Text.of_string "123") + (* )p *) ) ) ) end end