diff --git a/human.ml b/human.ml index b4b3e3c..a386137 100644 --- a/human.ml +++ b/human.ml @@ -1295,6 +1295,9 @@ module Panel = struct let node (t : t) = set_parent_on_children {parent= None; t; n= node_n ()} + let atom (a : atom) = node (`Atom a) + let attr (a : attr) (child : node) = node (`Attr (a, child)) + let join (d : dir) (a : node) (b : node) = node (`Join (d, a, b)) let empty_image = (Image.empty, V2.zero) let empty_node () = node (`Atom `Empty) let style (s : Style.t) (n : node) = node (`Attr (`Style s, n)) @@ -1448,13 +1451,9 @@ module Panel = struct | `Attr (_, n) -> n | `Join (_, a, _) -> a - let join_ d (a : node) (b : node) = - set_parent_on_children - {parent= a.parent; t= `Join (d, a, b); n= node_n ()} - - let join_x = join_ `X - let join_y = join_ `Y - let join_z = join_ `Z + let join_x = join `X + let join_y = join `Y + let join_z = join `Z let pack_x : node Lwd_utils.monoid = (empty_node (), join_x) let pack_y : node Lwd_utils.monoid = (empty_node (), join_y) let pack_z : node Lwd_utils.monoid = (empty_node (), join_z) @@ -1463,8 +1462,7 @@ module Panel = struct let ( ^*^ ) = join_z let append_ d (l : node -> node) (a : node) : node -> node = - F.epr "append_%a@." pp_dir d ; - fun n -> l (join_ d a n) + fun n -> l (join d a n) let empty_append = Fun.id let append_x = append_ `X @@ -1480,82 +1478,49 @@ module Panel = struct *) module Text = struct - 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 r = segment `Await (ly, lx) in - F.epr "@." ; r + let rec decode dec (l : 'a) : + 'a * [< `Await | `End | `Uchar of Uchar.t] = + match Uutf.decode dec with + | `Malformed b -> + F.epr "Text.dec (Uutf.decode uudec)=`Malformed \"%s\"@." + (String.escaped b) ; + decode dec (append_x l (of_string (String.escaped b))) + | (`Await | `End | `Uchar _) as s -> (l, s) + + and _of_string dec l = + match decode dec l with + | l, `End -> l (atom (`Boundary `Text)) + | l, `Uchar c -> _of_string dec (append_x l (atom (`Uchar c))) + | l, _ -> _of_string dec l 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))) + _of_string + (Uutf.decoder + ~nln:(`Readline (Uchar.of_int 0x000A)) + (`String str) ) + empty_append - 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))) + and _lines u d ly (lx, s) = + match Uuseg.add u s with + | `Boundary when Uuseg.mandatory u -> + _lines u d + (append_y ly (lx (atom (`Boundary `Line)))) + (empty_append, `Await) + | `Boundary -> + _lines u d ly (append_x lx (atom (`Hint `Line)), `Await) + | `End -> ly (lx (atom (`Boundary `Text))) + | `Await -> _lines u d ly (decode d lx) + | `Uchar c -> + _lines u d ly (append_x lx (atom (`Uchar c)), `Await) + + let lines str = + _lines + (Uuseg.create `Line_break) + (Uutf.decoder + ~nln:(`Readline (Uchar.of_int 0x000A)) + (`String str) ) + empty_append + (empty_append, `Await) end let text = Text.lines @@ -1856,19 +1821,15 @@ module Panel = struct match Key.Bind.resolve_events bind [e] with | x :: _ -> c.sel <- remove_attr c.sel ; - F.epr - "textedit_handler c.root=@.@[%a@]@.c.sel=%a@." - pp_node_structure c.root pp_node c.sel ; + (*F.epr + "textedit_handler c.sel.n=%d@ c.root=@ @[%a@]@." + pp_node_n c.sel pp_node_structure c.root ; *) ( match perform_action x c with | Some _ -> - F.epr - "textedit_handler perform_action @[%a@] \ - success@." + F.epr "textedit action @[%a@] Success@." Action.pp_t x | None -> - F.epr - "textedit_handler perform_action @[%a@] \ - FAILURE@." + F.epr "textedit action @[%a@] Failure@." Action.pp_t x ) ; c.sel <- insert_attr cursor_attr c.sel ; Lwt.return_none @@ -1913,17 +1874,16 @@ module Panel = struct (Lwd.pure (textedit_handler (style Style.dark - (* (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 *) ) ) ) + (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") ) ) ) ) end end