what have i done
This commit is contained in:
cqc
371
human.ml
371
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 "@[<hov>%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 =
|
||||
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 "@[<hov>%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
|
||||
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 ->
|
||||
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))))
|
||||
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 )
|
||||
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)))
|
||||
|
||||
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
|
||||
| `End | `Await -> (t, c)
|
||||
| `Uchar ch ->
|
||||
seg
|
||||
( Trope.put_right t c
|
||||
{parent; child= `Atom (`Uchar ch)}
|
||||
, c )
|
||||
| `Boundary ->
|
||||
line_seg u
|
||||
(ly, append_x lx (node (`Atom (`Hint `Line))))
|
||||
`Await in
|
||||
let r', c' = seg (r.t, c) (`Uchar uc) in
|
||||
({r with t= r'}, c')
|
||||
| _ -> (r, c) )
|
||||
node
|
||||
|
||||
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 *)
|
||||
(_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
|
||||
"@[<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 ())) ;
|
||||
(*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
|
||||
(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") ) ) ) )
|
||||
( ( 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
|
||||
|
||||
|
||||
Reference in New Issue
Block a user