+10 -7

dune-project

reviewed

··· 20 20 (synopsis "A short synopsis") 21 21 (description "A longer description") 22 22 (depends 23 23 - ocaml 23 23 + lwd 24 24 + ocaml 24 25 dune 25 25 - stdio 26 26 - lwd base eio_main angstrom ppx_expect ppx_jane 27 27 - lwd 28 28 - eio-process 26 26 + stdio 27 27 + nottui 28 28 + base 29 29 + eio_main 30 30 + angstrom 31 31 + ppx_expect 32 32 + ppx_jane 33 33 + eio-process 29 34 30 35 ;;for notty 31 36 uutf 32 32 - 33 33 - 34 37 ) 35 38 (tags 36 39 (topics "to describe" your project)))

+64 -3

flake.nix

reviewed

··· 20 20 perSystem = { config, self', inputs', pkgs, system, ... }: 21 21 let 22 22 jj_tui = pkgs: ocamlPackages: profile: 23 23 - 24 23 let 25 25 - notty = ocamlPackages.notty.overrideAttrs 24 24 + notty-mine = ocamlPackages.notty.overrideAttrs 26 25 (old: { src = ./forks/notty/.; }); 27 26 eio-process = ocamlPackages.buildDunePackage { 28 27 pname = "eio-process"; ··· 38 37 }; 39 38 40 39 buildInputs = with ocamlPackages; [ 41 41 - notty 42 40 base 43 41 eio 44 42 parsexp ··· 53 51 54 52 strictDeps = true; 55 53 }; 54 54 + lwd = ocamlPackages.buildDunePackage { 55 55 + pname = "lwd"; 56 56 + version = "0.1.0"; 57 57 + duneVersion = "3"; 58 58 + src = pkgs.fetchFromGitHub { 59 59 + 60 60 + owner = "faldor20"; 61 61 + repo = "lwd"; 62 62 + rev = "c19bc2fd55c2de977cdd283458ce06402b08febe"; 63 63 + sha256 = 64 64 + "sha256-8QwDzRgffA4wnE9vWLpLfy9MdQ5Yc8wBF5jgRamGMfA="; 65 65 + }; 66 66 + 67 67 + buildInputs = with ocamlPackages; [ 68 68 + seq 69 69 + ]; 70 70 + 71 71 + strictDeps = true; 72 72 + }; 73 73 + nottui = 74 74 + let pname="nottui"; in 75 75 + ocamlPackages.buildDunePackage { 76 76 + pname = "nottui"; 77 77 + version = "dev"; 78 78 + duneVersion = "3"; 79 79 + src = pkgs.fetchFromGitHub { 80 80 + 81 81 + owner = "faldor20"; 82 82 + repo = "nottui"; 83 83 + rev = "e8d64738c00b22b85d1867414c02c61062fbfc1e"; 84 84 + sha256 = 85 85 + "sha256-GgC0KX2LbCEqI3NC26J6e56QO27AFc2cv9Pz/9nQkEc="; 86 86 + }; 87 87 + 88 88 + buildInputs = with ocamlPackages; [ 89 89 + lwd 90 90 + notty-mine 91 91 + seq 92 92 + ]; 93 93 + buildPhase = '' 94 94 + runHook preBuild 95 95 + rm -rf ./tutorial 96 96 + dune build -p ${pname} ''${enableParallelBuilding:+-j $NIX_BUILD_CORES} 97 97 + runHook postBuild 98 98 + ''; 99 99 + checkPhase = '' 100 100 + runHook preCheck 101 101 + dune runtest -p ${pname}''${enableParallelBuilding:+-j $NIX_BUILD_CORES} 102 102 + runHook postCheck 103 103 + ''; 104 104 + installPhase = '' 105 105 + runHook preInstall 106 106 + dune install --prefix $out --libdir $OCAMLFIND_DESTDIR ${pname} 107 107 + runHook postInstall 108 108 + ''; 109 109 + 110 110 + strictDeps = true; 111 111 + }; 56 112 jj_tui_build_pkgs = 57 113 58 114 [ 115 115 + lwd 116 116 + notty-mine 117 117 + nottui 59 118 eio-process 60 119 ocamlPackages.parsexp 61 120 ocamlPackages.eio_main ··· 79 138 80 139 buildPhase = '' 81 140 runHook preBuild 141 141 + rm -rf ./forks 82 142 dune build -p ${pname} --profile ${profile} ''${enableParallelBuilding:+-j $NIX_BUILD_CORES} 83 143 runHook postBuild 84 144 ''; ··· 92 152 dune install --profile ${profile} --prefix $out --libdir $OCAMLFIND_DESTDIR ${pname} 93 153 runHook postInstall 94 154 ''; 155 155 + strictDeps = true; 95 156 96 157 }; 97 158 in {

forks/lwd/.github/workflows/main.yml forks/nottui/.github/workflows/main.yml

reviewed

forks/lwd/.gitignore forks/nottui/.gitignore

reviewed

forks/lwd/.ocamlformat forks/nottui/.ocamlformat

reviewed

forks/lwd/CHANGES forks/nottui/CHANGES

reviewed

forks/lwd/LICENSE forks/nottui/LICENSE

reviewed

-5

forks/lwd/Makefile forks/nottui/Makefile

reviewed

··· 5 5 dune clean 6 6 7 7 TESTS=minimal misc reranger stress pretty \ 8 8 - cbor/cbor_of_fs cbor/cbor_explorer 9 8 RUN_TESTS_BC=$(patsubst %, run-%, $(TESTS)) 10 9 RUN_TESTS_EXE=$(patsubst %, run-%.exe, $(TESTS)) 11 10 ··· 21 20 $(RUN_TESTS_EXE): 22 21 dune exec examples/$(patsubst run-%,%,$@) 23 22 24 24 - run-cbor-explorer.exe: 25 25 - rm curdir.cbor || true 26 26 - dune exec examples/cbor/cbor_of_fs.exe -- -o curdir.cbor ./ 27 27 - dune exec examples/cbor/cbor_explorer.exe -- curdir.cbor 28 23 29 24 .PHONY: all clean examples $(RUN_TESTS_BC) $(RUN_TESTS_EXE)

-222

forks/lwd/README.md

reviewed

··· 1 1 - # Lwd: a "lightweight document" library 2 2 - 3 3 - `Lwd` is a library that lets you build values that changes over time. It is a simple form of incremental computation, in the like of [Incremental](https://github.com/janestreet/incremental) and [React](https://github.com/dbuenzli/react). 4 4 - 5 5 - It is only about interactivity. A bunch of companion libraries make it usable in different settings: 6 6 - 7 7 - - [Nottui](lib/nottui) renders user interface in the terminal 8 8 - - [Nottui-lwt](lib/nottui-lwt) add support for concurrent/asynchronous UI to Nottui 9 9 - - [Nottui-pretty](lib/nottui-pretty) is an interactive pretty-printer (based on [Pprint](https://github.com/fpottier/pprint)) 10 10 - - [Tyxml-lwd](lib/tyxml-lwd) is a Js_of_ocaml library for making interactive applications, using Lwd for updating the DOM and [Tyxml](https://github.com/ocsigen/tyxml) for writing typesafe HTML Document. 11 11 - 12 12 - ```shell 13 13 - $ opam pin add tyxml https://github.com/ocsigen/tyxml.git#wraps 14 14 - ``` 15 15 - 16 16 - [TOC] 17 17 - 18 18 - ## Documents? 19 19 - 20 20 - `Lwd` shines when constructing a single value, which we call a document, by aggregating many sub-documents. These sub-documents might be updated independently and we want to keep a consistent view on the aggregated document: when we observe it, it should be the aggregate of the sub-documents in their current version. 21 21 - 22 22 - We will illustrate that with some examples. First we need to define the syntax for the final document: 23 23 - 24 24 - ```ocaml 25 25 - type hypertext = 26 26 - | Text of string 27 27 - | Link of (unit -> unit) * hypertext 28 28 - | List of hypertext list 29 29 - ``` 30 30 - 31 31 - A value of type `hypertext` will be interpreted by a backend. The interpretation is roughly as follows: 32 32 - 33 33 - - `Text str` simply displays the string `str` to the user (for instance on a terminal) 34 34 - - `Link (callback, hypertext')` displays the document `hypertext'`. 35 35 - If the backend determines that the user is interacting with the content in this sub-document, `callback` is called. 36 36 - - `List (doc1 :: doc2 :: ...)` displays `doc1` followed by `doc2` followed by `...`. 37 37 - 38 38 - To keep the example simple, we didn't say anything about styling nor how interactions are determined. For instance, the backend could display plain text in a default color, switch to another color for text below a `Link _` constructor, and keep track of _focus_ by cycling between links when `<TAB>` is pressed and choosing a different color for the focused link. 39 39 - 40 40 - A navigation menu could look like: 41 41 - 42 42 - ```ocaml 43 43 - let newline = Text "\n" in 44 44 - List [ 45 45 - Text "Welcome to my cafe"; newline; 46 46 - Link (display_drink, Text "See drink options"); newline; 47 47 - Link (display_food, Text "See food options"); newline; 48 48 - ] 49 49 - ``` 50 50 - 51 51 - We don't yet know how to implement the `display_drink` and `display_food` function but we have enough infrastructure to receive user intent. To complete the task, we will look at the idea of implementing a function that "changes its mind": it returned a value but, because of some circumstances, decide that another value should have been returned. 52 52 - 53 53 - ### Counting clicks 54 54 - 55 55 - Let's imagine we want to make a button that counts the number of times it has been clicked: at first it displays 0, when triggered the 0 switch to 1, etc. 56 56 - 57 57 - ```ocaml 58 58 - let counter = ref 0 59 59 - let on_click () = counter := !counter + 1 60 60 - 61 61 - let button clicks = 62 62 - Link (on_click, Text ("Clicked " ^ string_of_int clicks ^ " times")) 63 63 - 64 64 - let document = button !counter 65 65 - ``` 66 66 - 67 67 - We now have a counter that is incremented when the button is clicked. However the content of the button is not updated. 68 68 - 69 69 - This is where `Lwd` comes into play: the `Lwd.var` type behaves almost like a reference but also tracks data dependencies. Let's update the example: 70 70 - 71 71 - ```ocaml 72 72 - let counter = Lwd.var 0 73 73 - let on_click () = Lwd.set counter (Lwd.peek counter + 1) 74 74 - 75 75 - let button clicks = 76 76 - Link (on_click, Text ("Clicked " ^ string_of_int clicks ^ " times")) 77 77 - 78 78 - let document = Lwd.map ~f:button (Lwd.get counter) 79 79 - ``` 80 80 - 81 81 - We make use of the following `Lwd` functions: 82 82 - 83 83 - ```ocaml 84 84 - (* Variable manipulation function *) 85 85 - val Lwd.var : 'a -> 'a Lwd.var 86 86 - val Lwd.set : 'a Lwd.var -> 'a -> unit 87 87 - val Lwd.peek : 'a Lwd.var -> 'a 88 88 - ``` 89 89 - 90 90 - `var`, `set` and `peek` behave like `ref`, `:=` and `!`. They allocate a mutable cell, change its value and read the value at current time. 91 91 - 92 92 - ```ocaml 93 93 - val Lwd.get : 'a Lwd.var -> 'a Lwd.t 94 94 - ``` 95 95 - 96 96 - `Lwd.get` reads a mutable cell, but while `Lwd.peek` returns the value immediately, `Lwd.get` lets you access the value wrapped in the `Lwd.t` type. 97 97 - 98 98 - `Lwd` lets you build graph of computations with mutable inputs. The inputs or sources of the graph are made of `Lwd.var` while the inner nodes are built using combinators. 99 99 - 100 100 - Here `Lwd.map : ~f:('a -> 'b) -> 'a Lwd.t -> 'b Lwd.t` apply a transformation to a varying value. That value might depend on arbitrary inputs, and if one of these input changes, the transformation will be recomputed too. 101 101 - 102 102 - When the `Link` is triggered, the counter is incremented. Because `document` depends on the value of the counter it is invalidated. 103 103 - 104 104 - ### Building computation graph 105 105 - 106 106 - `Lwd.t` implements a few abstractions that should be familiar to seasoned functional programmers: 107 107 - 108 108 - - it is a _functor_. With `Lwd.map : ~f:('a -> 'b) -> 'a Lwd.t -> 'b Lwd.t` you can transform values and chain the transformations 109 109 - - it is an _applicative functor_. With `Lwd.map2 : ~f:('a -> 'b -> 'c) -> 'a Lwd.t -> 'b Lwd.t > 'c Lwd.t` you can connect two different chains (making the computation tree shaped, actually with sharing it will form a DAG) 110 110 - - and, although this should in general be avoided, a _monad_. With `Lwd.join : 'a Lwd.t Lwd.t -> 'a Lwd.t` you can have a first pipeline that computes another pipeline and inject the inner one. 111 111 - 112 112 - ### Consuming computation graph 113 113 - 114 114 - So far we described how to build values of type `a Lwd.t` but we don't have a way to get access to those `a` outside of the _Lwd_ graph. 115 115 - 116 116 - That's what `Lwd.root`s are for: 117 117 - 118 118 - ```ocaml 119 119 - type 'a Lwd.root 120 120 - val Lwd.observe : ?on_invalidate:('a -> unit) -> 'a t -> 'a root 121 121 - val Lwd.set_on_invalidate : 'a root -> ('a -> unit) -> unit 122 122 - 123 123 - val Lwd.sample : 'a root -> 'a 124 124 - val Lwd.is_damaged : 'a root -> bool 125 125 - val Lwd.release : 'a root -> unit 126 126 - ``` 127 127 - 128 128 - When you are interested in accessing the content of an `a Lwd.t` value, you create a root by `observe`-ing it. 129 129 - 130 130 - `Lwd.sample` lets you access the value at the current time. 131 131 - 132 132 - After calling `Lwd.sample`, the `on_invalidate` callback might be invoked if the value is invalidated: some input changed, the value you sampled is out of date. 133 133 - 134 134 - When you are done with the `root` and are no longer interested in observing the value, you should call `release`. This call to `release` is very important: the `root` maintain the whole graph alive, so forgetting to `release` leads to memory leaks. After releasing, the on_invalidate callback will not be invoked. 135 135 - 136 136 - A root can be in three possible states: 137 137 - 138 138 - - released 139 139 - - damaged 140 140 - - sampled 141 141 - 142 142 - When created, the root is in the `released` state: it does not maintain the graph alive. 143 143 - 144 144 - Calling `sample` switches the root from the `released` to the `sampled` state. 145 145 - 146 146 - ```mermaid 147 147 - graph TD; 148 148 - R[Released] 149 149 - S[Sampled] 150 150 - D[Damaged] 151 151 - s{"call to sample"} 152 152 - i{"graph input change,<br/>call <tt>on_invalidate</tt>"} 153 153 - r{"call to release"} 154 154 - R-->s 155 155 - s-->S 156 156 - D-->s 157 157 - S-->i 158 158 - i-->D 159 159 - S-->r 160 160 - D-->r 161 161 - r-->R 162 162 - ``` 163 163 - 164 164 - ## Relation to HTML, DOM, and reactive UI libraries 165 165 - 166 166 - **Syntax, data description and HTML.** To introduce our first example, we had to build a syntax using the simple `hypertext` algebraic data type. This type serves as an interface between the application and the interactive system: values of this type are produced by the front-end, like our example codes, and consumed by a back-end. 167 167 - 168 168 - In the case of a web browser, the surface syntax is `HTML` which is much richer and more expressive than `hypertext` but ultimately is just data: a static description of some pieces of information. 169 169 - 170 170 - **Adding programming languages.** Because static description are too limited for modern websites, Web browsers support the Javascript programming language. Pieces of javascript code can be put in the middle of the HTML syntax. 171 171 - 172 172 - Similarly the `unit -> unit` parameter of the `Link` constructor allows to inject arbitrary OCaml code in the middle of an `hypertext` document. 173 173 - 174 174 - **Making things interactive.** Being able to execute arbitrary piece of codes is not enough to make a document interactive: to make things dynamic the code needs to change the contents of the document in return. 175 175 - 176 176 - Ultimately, interaction comes from this mutual dependency between document and code: 177 177 - 178 178 - - the document contains codes that are executed in certain circumstances (determined by the meaning of elements of the document). 179 179 - - when executed, a code can change the document, producing new elements associated to new codes. 180 180 - - this updated document can then execute new pieces of code, that may update the document, and so on... 181 181 - 182 182 - **The DOM.** Web browser's solution to allowing document update is the Document Object Model abstraction. The idea is to derive mutable data structures from the syntactic specification: each syntactic construction has a corresponding "DOM class" that can store the same information in mutable fields. Applied to our hypertext example: 183 183 - 184 184 - ```ocaml 185 185 - type hypertext_dom = 186 186 - | Text of { mutable text: string } 187 187 - | Link of { mutable callback: (unit -> unit) 188 188 - ; mutable child: hypertext_dom } 189 189 - | List of { mutable children: hypertext_dom list } 190 190 - ``` 191 191 - 192 192 - While this might be a natural derivation in imperative languages, it proved difficult and error-prone to manipulate. Thousands of Javascript libraries were proposed to ease DOM manipulation. 193 193 - 194 194 - Some successful ones drew inspiration from functional programming, in the sense that they discouraged side-effects, producing new documents rather than modifying existing ones. 195 195 - 196 196 - _Lwd_ rethinks this scaffolding: rather than starting from a static description, deriving mutable data structures to bring dynamism, and then restricting the mutations to make it manageable, we propose to keep the syntax as it is, lift the document in an `Lwd.t` computation graph and use variables nodes to express parts that can changes. 197 197 - 198 198 - **Reactive UI.** It is difficult to make a fair comparison with these libraries as the term is loosely defined and there many competing approaches. Furthermore Lwd can be presented as an alternative to the DOM so it is effective at a lower-level than what common reactive libraries target. 199 199 - 200 200 - That being said, we will try to address the following questions: 201 201 - 202 202 - - can reactive libraries, to a reasonable extent, be reimplemented on top of _Lwd_ rather than _DOM_? 203 203 - - can _Lwd_ be conveniently used without such layer? 204 204 - 205 205 - The first question can be answered positively with a naive encoding: put `Lwd.var` everywhere, essentially keeping enough "degrees of freedom" to change things as needed later. No static structure is enforced this way. 206 206 - 207 207 - To answer the second question, it is interesting to observe that there is no concept of "diffing" here. _Lwd_ does not try to see if things have changed in order to update them. Rather, if an input change, the whole branch that depends on it is recomputed. 208 208 - 209 209 - So it is not VDOM/Diffing that could make Lwd convenient. Instead, it is the fact that most of the time, dependencies are made explicit. 210 210 - Let's consider a component that changes its color when it is focused. With `Lwd` (and `Nottui`), this could be expressed as: 211 211 - 212 212 - ```ocaml 213 213 - let focus = Focus.make () in 214 214 - let color status = 215 215 - if Focus.has_focus status then blue else black 216 216 - in 217 217 - button ~focus ~color:(Lwd.map ~f:color (Focus.status focus))) 218 218 - ``` 219 219 - 220 220 - The color of the button is defined declaratively: it cannot be changed elsewhere, no other part of the code can mutate it. It is this explicit declaration of dependencies that make it possible to reason about the code, to enforce invariants and to encapsulate behaviors. 221 221 - 222 222 - `Lwd.var` is the escape hatch one can use to recover imperative code. But rather than being the default, it has to be opted in and can be exposed to a limited scope only.

-19

forks/lwd/TODO.md

reviewed

··· 1 1 - - Document implementation 2 2 - - Switch to labelled interface 3 3 - - Make "window manager" a core Nottui concept: 4 4 - - applications start by creating a window manager 5 5 - - main loop runs a window manager and not a ui Lwd.t 6 6 - - main loop quit when there is no window scheduled 7 7 - - Benchmark "compact" trace representation: 8 8 - It should consume a bit less memory (that should be observable in misc 9 9 - example with a million edit fields) and should not affect runtime 10 10 - performance... However it seems to do so (in misc and stress), 11 11 - especially in bytecode, maybe because of the additional recursive functions. 12 12 - - Add a standard mainloop / update scheduler to Tyxml-lwd: 13 13 - - it should take into account different roots 14 14 - (multiple sub-trees of the DOM that are maintained by lwd) 15 15 - - it should support "unstable" documents (those that need more than one 16 16 - update cycle): 17 17 - - provide different levels of logging for profiling unstable parts? 18 18 - - maybe split update cycles in different chunks, so that we can still 19 19 - produce a frame within time budget when a fixpoint cannot be reached

-32

forks/lwd/brr-lwd.opam

reviewed

··· 1 1 - # This file is generated by dune, edit dune-project instead 2 2 - opam-version: "2.0" 3 3 - synopsis: "Make reactive webpages in Js_of_ocaml using Brr and Lwd" 4 4 - maintainer: ["fred@tarides.com"] 5 5 - authors: ["Frédéric Bour"] 6 6 - license: "MIT" 7 7 - homepage: "https://github.com/let-def/lwd" 8 8 - doc: "https://let-def.github.io/lwd/doc" 9 9 - bug-reports: "https://github.com/let-def/lwd/issues" 10 10 - depends: [ 11 11 - "dune" {>= "3.5"} 12 12 - "lwd" {= version} 13 13 - "brr" {>= "0.0.4"} 14 14 - "js_of_ocaml" 15 15 - "js_of_ocaml-lwt" {with-test} 16 16 - "odoc" {with-doc} 17 17 - ] 18 18 - build: [ 19 19 - ["dune" "subst"] {dev} 20 20 - [ 21 21 - "dune" 22 22 - "build" 23 23 - "-p" 24 24 - name 25 25 - "-j" 26 26 - jobs 27 27 - "@install" 28 28 - "@runtest" {with-test} 29 29 - "@doc" {with-doc} 30 30 - ] 31 31 - ] 32 32 - dev-repo: "git+https://github.com/let-def/lwd.git"

-50

forks/lwd/dune-project

reviewed

··· 1 1 - (lang dune 3.5) 2 2 - (generate_opam_files true) 3 3 - (formatting (enabled_for dune)) 4 4 - 5 5 - (name lwd) 6 6 - (source (github let-def/lwd)) 7 7 - (license MIT) 8 8 - (authors "Frédéric Bour") 9 9 - (maintainers "fred@tarides.com") 10 10 - 11 11 - (package 12 12 - (name lwd) 13 13 - (synopsis "Lightweight reactive documents") 14 14 - (documentation "https://let-def.github.io/lwd/doc") 15 15 - (depends dune seq (ocaml (>= "4.03")) 16 16 - (qtest :with-test) 17 17 - (qcheck :with-test))) 18 18 - 19 19 - (package 20 20 - (name nottui) 21 21 - (synopsis "UI toolkit for the terminal built on top of Notty and Lwd") 22 22 - (documentation "https://let-def.github.io/lwd/doc") 23 23 - (depends (lwd (= :version)) (notty (>= 0.2)) 24 24 - (cbor :with-test) ; for the examples 25 25 - (containers :with-test))) ; for the examples 26 26 - 27 27 - (package 28 28 - (name tyxml-lwd) 29 29 - (synopsis "Make reactive webpages in Js_of_ocaml using Tyxml and Lwd") 30 30 - (documentation "https://let-def.github.io/lwd/doc") 31 31 - (depends (lwd (= :version)) (tyxml (>= 4.5.0)) js_of_ocaml js_of_ocaml-ppx)) 32 32 - 33 33 - (package 34 34 - (name brr-lwd) 35 35 - (synopsis "Make reactive webpages in Js_of_ocaml using Brr and Lwd") 36 36 - (documentation "https://let-def.github.io/lwd/doc") 37 37 - (depends (lwd (= :version)) (brr (>= 0.0.4)) js_of_ocaml 38 38 - (js_of_ocaml-lwt :with-test))) ; for the examples 39 39 - 40 40 - (package 41 41 - (name nottui-pretty) 42 42 - (synopsis "A pretty-printer based on PPrint rendering UIs") 43 43 - (documentation "https://let-def.github.io/lwd/doc") 44 44 - (depends (nottui (= :version)) (notty (>= 0.2)))) 45 45 - 46 46 - (package 47 47 - (name nottui-lwt) 48 48 - (synopsis "Run Nottui UIs in Lwt") 49 49 - (documentation "https://let-def.github.io/lwd/doc") 50 50 - (depends lwt (nottui (= :version)) (notty (>= 0.2))))

-78

forks/lwd/examples/cbor/cbor_explorer.ml

reviewed

··· 1 1 - module Ui = Nottui 2 2 - module W = Nottui_widgets 3 3 - module C = CBOR.Simple 4 4 - module A = Notty.A 5 5 - 6 6 - let body = Lwd.var W.empty_lwd 7 7 - 8 8 - let wm = Nottui_widgets.window_manager (Lwd.join (Lwd.get body)) 9 9 - 10 10 - let ui_of_cbor (c:C.t) = 11 11 - let quit = Lwd.var false in 12 12 - let w_q = W.main_menu_item wm "[quit]" 13 13 - (fun () -> Lwd.set quit true; W.empty_lwd) 14 14 - in 15 15 - let rec traverse ?(fold=false) (c:C.t) : Ui.ui Lwd.t = 16 16 - match c with 17 17 - | `Bool b -> Lwd.return (W.printf ~attr:A.(fg blue) "%B" b) 18 18 - | `Bytes s -> Lwd.return (W.printf ~attr:A.(fg @@ gray 14) "<bytes(%d)>" (String.length s)) 19 19 - | `Text s -> Lwd.return (W.string s) 20 20 - | `Int i -> Lwd.return @@ W.printf "%d" i 21 21 - | `Float f -> Lwd.return @@ W.printf "%f" f 22 22 - | `Null -> Lwd.return (W.string "null") 23 23 - | `Undefined -> Lwd.return (W.string "undefined") 24 24 - | `Simple i -> Lwd.return (W.printf "simple(%d)" i) 25 25 - | `Array [] -> Lwd.return (W.string "[]") 26 26 - | `Array l -> 27 27 - if fold then ( 28 28 - let summary = 29 29 - Lwd.return @@ W.printf ~attr:A.(fg yellow) "<array(%d)>" (List.length l) in 30 30 - W.unfoldable summary 31 31 - (fun () -> 32 32 - let l = List.map (traverse ~fold:true) l in 33 33 - Lwd_utils.pack Ui.Ui.pack_y l) 34 34 - ) else ( 35 35 - let l = List.map (traverse ~fold:true) l in 36 36 - Lwd_utils.pack Ui.Ui.pack_y l 37 37 - ) 38 38 - | `Map [] -> Lwd.return (W.string "{}") 39 39 - | `Map [x,y] -> mk_k_v x y 40 40 - | `Map l -> 41 41 - let summary = Lwd.return @@ W.printf ~attr:A.(fg yellow) "<map(%d)>" (List.length l) in 42 42 - W.unfoldable summary 43 43 - (fun () -> 44 44 - let tbl = Lwd_table.make () in 45 45 - List.iter (fun (x,y) -> 46 46 - let row = Lwd_table.append tbl in 47 47 - let kv = mk_k_v x y in 48 48 - Lwd_table.set row kv) 49 49 - l; 50 50 - Lwd.join @@ Lwd_table.reduce (Lwd_utils.lift_monoid Ui.Ui.pack_y) tbl) 51 51 - | `Tag (tag, payload) -> 52 52 - Lwd.map ~f:(Ui.Ui.join_y (W.printf "tag(%d)" tag)) (traverse payload) 53 53 - and mk_k_v x y = 54 54 - let tr_x = traverse x in 55 55 - let summary = match y with 56 56 - | `Array _ | `Map _ -> 57 57 - W.hbox [tr_x; Lwd.return (W.string ~attr:A.(bg @@ gray 15) "/")] 58 58 - | _ -> tr_x 59 59 - in 60 60 - W.unfoldable summary (fun () -> traverse ~fold:false y) 61 61 - in 62 62 - let w = Lwd.map2 ~f:Ui.Ui.join_y 63 63 - w_q (Nottui_widgets.scroll_area @@ traverse ~fold:true c) 64 64 - in 65 65 - quit, w 66 66 - 67 67 - let show_file f = 68 68 - let cbor = CCIO.with_in f (fun ic -> CCIO.read_all ic |> C.decode) in 69 69 - let quit, ui = ui_of_cbor cbor in 70 70 - Lwd.set body ui; 71 71 - Ui.Ui_loop.run ~quit ~tick_period:0.2 (W.window_manager_view wm) 72 72 - 73 73 - let () = 74 74 - let f = ref "" in 75 75 - Arg.parse (Arg.align [ 76 76 - ]) (fun x -> f := x) "cbor_explorer <file>"; 77 77 - if !f = "" then failwith "please provide a cbor file"; 78 78 - show_file !f

-40

forks/lwd/examples/cbor/cbor_of_fs.ml

reviewed

··· 1 1 - 2 2 - module C = CBOR.Simple 3 3 - 4 4 - let rec fs_to_cbor ~path (f:string) : C.t = 5 5 - let file = Filename.concat path f in 6 6 - if not @@ Sys.file_exists file then `Text "<not found>" 7 7 - else if Sys.is_directory file then ( 8 8 - try 9 9 - let dir = Sys.readdir file in 10 10 - `Map [ 11 11 - `Text f, 12 12 - `Array (Array.map (fs_to_cbor ~path:file) dir |> Array.to_list) 13 13 - ] 14 14 - with e -> 15 15 - `Text (Printf.sprintf "<exn for dir %S: %s>" f (Printexc.to_string e)) 16 16 - ) else ( 17 17 - let content = 18 18 - try 19 19 - let s = CCIO.with_in file CCIO.read_all in 20 20 - if CCUtf8_string.is_valid s then `Text s else `Bytes s 21 21 - with _e -> 22 22 - `Text "<read error>" 23 23 - in 24 24 - `Map [ `Text f, content ] 25 25 - ) 26 26 - 27 27 - let () = 28 28 - let out = ref "" in 29 29 - let dirs = ref [] in 30 30 - Arg.parse (Arg.align [ 31 31 - "-o", Arg.Set_string out, " output file"; 32 32 - ]) (fun x -> dirs := x :: !dirs) "cbor_of_fs -o <out> <dir>+"; 33 33 - if !out = "" then failwith "-o is required"; 34 34 - if !dirs = [] then failwith "please provide at least one directory to pack"; 35 35 - let cs = List.map (fs_to_cbor ~path:"") !dirs in 36 36 - let c = match cs with [x] -> x | _ -> `Array cs in 37 37 - Format.printf "write CBOR to %s@." (Filename.quote !out); 38 38 - CCIO.with_out !out 39 39 - (fun oc -> output_string oc @@ C.encode c) 40 40 -

-12

forks/lwd/examples/cbor/dune

reviewed

··· 1 1 - (executable 2 2 - (name cbor_explorer) 3 3 - (modules cbor_explorer) 4 4 - (modes byte exe) 5 5 - (flags :standard -warn-error -a) 6 6 - (libraries notty notty.unix nottui cbor containers)) 7 7 - 8 8 - (executable 9 9 - (name cbor_of_fs) 10 10 - (modules cbor_of_fs) 11 11 - (modes byte exe) 12 12 - (libraries containers cbor))

-9

forks/lwd/examples/cssclasstest-brr/Makefile

reviewed

··· 1 1 - ROOT=$(realpath $(PWD)/../..) 2 2 - NAME=$(subst $(ROOT)/,,$(realpath $(PWD))) 3 3 - 4 4 - all: 5 5 - dune build index.html main.js 6 6 - @echo "open $(ROOT)/_build/default/$(NAME)/index.html" 7 7 - 8 8 - clean: 9 9 - dune clean

-21

forks/lwd/examples/cssclasstest-brr/dune

reviewed

··· 1 1 - (executables 2 2 - (names main) 3 3 - (libraries js_of_ocaml brr lwd brr-lwd) 4 4 - (modes byte)) 5 5 - 6 6 - (rule 7 7 - (targets main.js) 8 8 - (action 9 9 - (run 10 10 - %{bin:js_of_ocaml} 11 11 - --noruntime 12 12 - %{lib:js_of_ocaml-compiler:runtime.js} 13 13 - --source-map 14 14 - %{dep:main.bc} 15 15 - -o 16 16 - %{targets} 17 17 - --pretty))) 18 18 - 19 19 - (alias 20 20 - (name default) 21 21 - (deps main.js index.html))

-27

forks/lwd/examples/cssclasstest-brr/index.html

reviewed

··· 1 1 - <?xml version="1.0" encoding="utf-8"?> 2 2 - <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1//EN" 3 3 - "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd"> 4 4 - <html xmlns="http://www.w3.org/1999/xhtml"> 5 5 - <head> 6 6 - <title>Minesweeper</title> 7 7 - <meta http-equiv="Content-Type" content="text/html; charset=utf-8" /> 8 8 - <script type="text/javascript" src="main.js"></script> 9 9 - <style> 10 10 - .square { 11 11 - width: 1px;; 12 12 - height: 1px; 13 13 - padding: 1px; 14 14 - border: solid 1px; 15 15 - } 16 16 - .square-on { 17 17 - background-color: yellow; 18 18 - } 19 19 - .square-off { 20 20 - background-color: blue; 21 21 - } 22 22 - </style> 23 23 - </head> 24 24 - <body> 25 25 - <div id="main"></div> 26 26 - </body> 27 27 - </html>

-57

forks/lwd/examples/cssclasstest-brr/main.ml

reviewed

··· 1 1 - open Brr 2 2 - open Brr_lwd 3 3 - 4 4 - type square = On | Off 5 5 - 6 6 - let flip = function On -> Off | Off -> On 7 7 - 8 8 - let class_of_state = 9 9 - function 10 10 - | On -> Jstr.v "square-on" 11 11 - | Off -> Jstr.v "square-off" 12 12 - 13 13 - let lwd_table_row_map ~f row = 14 14 - Lwd_table.get row |> Option.iter (fun v -> Lwd.set v (f (Lwd.peek v))) 15 15 - 16 16 - let ui = 17 17 - let squares = Lwd_table.make () in 18 18 - let add_square () = 19 19 - let row = Lwd_table.append squares in 20 20 - Lwd_table.set row (Lwd.var Off) 21 21 - in 22 22 - for _ = 1 to 20 * 25 do 23 23 - add_square () 24 24 - done; 25 25 - let board = 26 26 - Lwd_table.map_reduce 27 27 - (fun row state -> 28 28 - Lwd_seq.element @@ 29 29 - Elwd.div 30 30 - ~at:[ 31 31 - `P (At.class' (Jstr.v "square")); 32 32 - `R ((Lwd.map ~f:(fun x -> At.class' (class_of_state x)) (Lwd.get state))); 33 33 - ] 34 34 - ~ev:[ 35 35 - `P (Elwd.handler Ev.click 36 36 - (fun _ -> lwd_table_row_map row ~f:(fun state -> flip state))) 37 37 - ] 38 38 - [] 39 39 - ) 40 40 - Lwd_seq.monoid 41 41 - squares 42 42 - in 43 43 - Elwd.div ~at:[ `P (At.class' (Jstr.v "game-board")) ] [ 44 44 - `S (Lwd_seq.lift board) 45 45 - ] 46 46 - 47 47 - let () = 48 48 - let ui = Lwd.observe ui in 49 49 - let on_invalidate _ = 50 50 - ignore @@ G.request_animation_frame @@ fun _ -> 51 51 - ignore @@ Lwd.quick_sample ui 52 52 - in 53 53 - let on_load _ = 54 54 - El.append_children (Document.body G.document) [ Lwd.quick_sample ui ]; 55 55 - Lwd.set_on_invalidate ui on_invalidate 56 56 - in 57 57 - ignore @@ Ev.listen Ev.dom_content_loaded on_load (Window.as_target G.window)

forks/lwd/examples/dune forks/nottui/examples/dune

reviewed

-9

forks/lwd/examples/focustest-brr/Makefile

reviewed

··· 1 1 - ROOT=$(realpath $(PWD)/../..) 2 2 - NAME=$(subst $(ROOT)/,,$(realpath $(PWD))) 3 3 - 4 4 - all: 5 5 - dune build index.html main.js 6 6 - @echo "open $(ROOT)/_build/default/$(NAME)/index.html" 7 7 - 8 8 - clean: 9 9 - dune clean

-21

forks/lwd/examples/focustest-brr/dune

reviewed

··· 1 1 - (executables 2 2 - (names main) 3 3 - (libraries js_of_ocaml brr lwd brr-lwd) 4 4 - (modes byte)) 5 5 - 6 6 - (rule 7 7 - (targets main.js) 8 8 - (action 9 9 - (run 10 10 - %{bin:js_of_ocaml} 11 11 - --noruntime 12 12 - %{lib:js_of_ocaml-compiler:runtime.js} 13 13 - --source-map 14 14 - %{dep:main.bc} 15 15 - -o 16 16 - %{targets} 17 17 - --pretty))) 18 18 - 19 19 - (alias 20 20 - (name default) 21 21 - (deps main.js index.html))

-13

forks/lwd/examples/focustest-brr/index.html

reviewed

··· 1 1 - <?xml version="1.0" encoding="utf-8"?> 2 2 - <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1//EN" 3 3 - "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd"> 4 4 - <html xmlns="http://www.w3.org/1999/xhtml"> 5 5 - <head> 6 6 - <title>Minesweeper</title> 7 7 - <meta http-equiv="Content-Type" content="text/html; charset=utf-8" /> 8 8 - <script type="text/javascript" src="main.js"></script> 9 9 - </head> 10 10 - <body> 11 11 - <div id="main"></div> 12 12 - </body> 13 13 - </html>

-67

forks/lwd/examples/focustest-brr/main.ml

reviewed

··· 1 1 - open Brr 2 2 - open Brr_lwd 3 3 - 4 4 - let ui = 5 5 - let values = Lwd_table.make () in 6 6 - let items = Lwd.var Lwd_seq.empty in 7 7 - let shuffle () = 8 8 - let all = Lwd_seq.to_array (Lwd.peek items) in 9 9 - for i = Array.length all - 1 downto 1 do 10 10 - let i' = Random.int (i + 1) in 11 11 - let x = all.(i) in 12 12 - let x' = all.(i') in 13 13 - all.(i') <- x; 14 14 - all.(i) <- x'; 15 15 - done; 16 16 - Lwd.set items (Lwd_seq.of_array all) 17 17 - in 18 18 - let edit _ = 19 19 - let row = Lwd_table.append values in 20 20 - Lwd.map (Elwd.input ()) ~f:(fun el -> 21 21 - ignore ( 22 22 - Ev.listen Ev.input (fun _ -> 23 23 - let txt = Jstr.to_string (El.prop El.Prop.value el) in 24 24 - Console.log ["shuffle"; txt]; 25 25 - Lwd_table.set row txt; 26 26 - shuffle () 27 27 - ) (El.as_target el) 28 28 - ); 29 29 - el 30 30 - ) 31 31 - in 32 32 - Lwd.set items (Lwd_seq.of_array (Array.init 10 edit)); 33 33 - let values = 34 34 - Lwd_table.map_reduce 35 35 - (fun _row txt -> Lwd_seq.element (txt ^ "\n")) 36 36 - (Lwd_seq.monoid) 37 37 - values 38 38 - |> Lwd_seq.sort_uniq String.compare 39 39 - in 40 40 - Elwd.div [ 41 41 - `P (El.txt' "In this test, typing in one of the input field should \ 42 42 - shuffle them. The test succeeds if focus and selections are \ 43 43 - preserved after shuffling."); 44 44 - `P (El.br ()); 45 45 - `S (Lwd_seq.lift (Lwd.get items)); 46 46 - `S (Lwd_seq.map El.txt' values); 47 47 - ] 48 48 - 49 49 - let () = 50 50 - let ui = Lwd.observe ui in 51 51 - let on_invalidate _ = 52 52 - Console.(log [str "on invalidate"]); 53 53 - let _ : int = 54 54 - G.request_animation_frame @@ fun _ -> 55 55 - let _ui = Lwd.quick_sample ui in 56 56 - (*El.set_children (Document.body G.document) [ui]*) 57 57 - () 58 58 - in 59 59 - () 60 60 - in 61 61 - let on_load _ = 62 62 - Console.(log [str "onload"]); 63 63 - El.append_children (Document.body G.document) [Lwd.quick_sample ui]; 64 64 - Lwd.set_on_invalidate ui on_invalidate 65 65 - in 66 66 - ignore (Ev.listen Ev.dom_content_loaded on_load (Window.as_target G.window)); 67 67 - ()

-20

forks/lwd/examples/minesweeper-tyxml/LICENSE

reviewed

··· 1 1 - 2 2 - All files contained in this directory and its sub-directories are 3 3 - distributed under the terms of the DO WHAT THE FUCK YOU WANT TO PUBLIC 4 4 - LICENSE (included below). 5 5 - 6 6 - ------------------------------------------------------------------------ 7 7 - 8 8 - DO WHAT THE FUCK YOU WANT TO PUBLIC LICENSE 9 9 - Version 2, December 2004 10 10 - 11 11 - Copyright (C) 2004 Sam Hocevar 12 12 - 14 rue de Plaisance, 75014 Paris, France 13 13 - Everyone is permitted to copy and distribute verbatim or modified 14 14 - copies of this license document, and changing it is allowed as long 15 15 - as the name is changed. 16 16 - 17 17 - DO WHAT THE FUCK YOU WANT TO PUBLIC LICENSE 18 18 - TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 19 19 - 20 20 - 0. You just DO WHAT THE FUCK YOU WANT TO.

-4

forks/lwd/examples/minesweeper-tyxml/Makefile

reviewed

··· 1 1 - all: 2 2 - dune build 3 3 - 4 4 - .PHONY: all

-1

forks/lwd/examples/minesweeper-tyxml/README

reviewed

··· 1 1 - This is a port of the Minesweeper example from O'Browser.

-26

forks/lwd/examples/minesweeper-tyxml/dune

reviewed

··· 1 1 - (executables 2 2 - (names main) 3 3 - (libraries js_of_ocaml-lwt lwd tyxml_lwd) 4 4 - (modes byte) 5 5 - (preprocess 6 6 - (pps js_of_ocaml-ppx))) 7 7 - 8 8 - (rule 9 9 - (targets main.js) 10 10 - (action 11 11 - (run 12 12 - %{bin:js_of_ocaml} 13 13 - --noruntime 14 14 - %{lib:js_of_ocaml-compiler:runtime.js} 15 15 - --source-map 16 16 - %{dep:main.bc} 17 17 - -o 18 18 - %{targets} 19 19 - --pretty))) 20 20 - 21 21 - (alias 22 22 - (name default) 23 23 - (deps 24 24 - main.js 25 25 - index.html 26 26 - (glob_files sprites/*.{png,svg})))

-13

forks/lwd/examples/minesweeper-tyxml/index.html

reviewed

··· 1 1 - <?xml version="1.0" encoding="utf-8"?> 2 2 - <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1//EN" 3 3 - "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd"> 4 4 - <html xmlns="http://www.w3.org/1999/xhtml"> 5 5 - <head> 6 6 - <title>Minesweeper</title> 7 7 - <meta http-equiv="Content-Type" content="text/html; charset=utf-8" /> 8 8 - <script type="text/javascript" src="main.js"></script> 9 9 - </head> 10 10 - <body> 11 11 - <div id="main"></div> 12 12 - </body> 13 13 - </html>

-81

forks/lwd/examples/minesweeper-tyxml/main.ml

reviewed

··· 1 1 - (* Js_of_ocaml examples 2 2 - * http://www.ocsigen.org/js_of_ocaml/ 3 3 - * Copyright (C) 2008 Benjamin Canou 4 4 - * 5 5 - * DO WHAT THE FUCK YOU WANT TO PUBLIC LICENSE 6 6 - * TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 7 7 - * 8 8 - *) 9 9 - open Js_of_ocaml 10 10 - open Tyxml_lwd 11 11 - open Lwdom 12 12 - 13 13 - let js = Js.string 14 14 - 15 15 - let event_input event = 16 16 - let target = Js.Opt.bind event##.target Dom_html.CoerceTo.input in 17 17 - match Js.Opt.to_option target with 18 18 - | None -> None 19 19 - | Some target -> Some (Js.to_string target##.value) 20 20 - 21 21 - let int_input name value ~set_value = 22 22 - let value = Lwd.map ~f:string_of_int value in 23 23 - children [ 24 24 - Html.txt (Lwd.pure name); 25 25 - Html.input ~a:[ 26 26 - Html.a_input_type (Lwd.pure `Text); 27 27 - Html.a_value value; 28 28 - Html.a_onchange (attr (fun event -> 29 29 - begin match Option.bind (event_input event) int_of_string_opt with 30 30 - | None -> () 31 31 - | Some v -> set_value v 32 32 - end; 33 33 - true 34 34 - )); 35 35 - ] () 36 36 - ] 37 37 - 38 38 - let button name callback = 39 39 - Html.input ~a:[ 40 40 - Html.a_input_type (Lwd.pure `Submit); 41 41 - Html.a_value (Lwd.pure name); 42 42 - Html.a_onclick (Lwd.pure (Some callback)); 43 43 - ] () 44 44 - 45 45 - let onload _ = 46 46 - let main = 47 47 - Js.Opt.get (Dom_html.window##.document##getElementById (js "main")) 48 48 - (fun () -> assert false) 49 49 - in 50 50 - let nbr, nbc, nbm = Lwd.var 10, Lwd.var 12, Lwd.var 15 in 51 51 - let boards = Lwd_table.make () in 52 52 - let doc = Html.span [ 53 53 - int_input "Number of columns" 54 54 - ~set_value:(fun v -> Lwd.set nbr v; prerr_endline @@ "columns = " ^ string_of_int v) 55 55 - (Lwd.get nbr); 56 56 - children [Html.br ()]; 57 57 - int_input "Number of rows" ~set_value:(Lwd.set nbc) (Lwd.get nbc); 58 58 - children [Html.br ()]; 59 59 - int_input "Number of mines" ~set_value:(Lwd.set nbm) (Lwd.get nbm); 60 60 - children [ 61 61 - Html.br (); 62 62 - button "nouvelle partie" (fun _ -> 63 63 - Lwd_table.append' boards 64 64 - (Minesweeper.run (Lwd.peek nbc) (Lwd.peek nbr) (Lwd.peek nbm)); 65 65 - false 66 66 - ); 67 67 - ]; 68 68 - Lwd.join (Lwd_table.reduce Lwd_seq.lwd_monoid boards); 69 69 - ] 70 70 - in 71 71 - (*let root = Lwd.observe (Lwdom.to_fragment doc) in*) 72 72 - let root = Lwd.observe doc in 73 73 - Lwd.set_on_invalidate root (fun _ -> 74 74 - ignore (Dom_html.window##requestAnimationFrame 75 75 - (Js.wrap_callback (fun _ -> ignore (Lwd.quick_sample root))) 76 76 - )); 77 77 - List.iter (Dom.appendChild main) 78 78 - (Lwd_seq.to_list (Lwd.quick_sample root) : _ node list :> raw_node list); 79 79 - Js._false 80 80 - 81 81 - let _ = Dom_html.window##.onload := Dom_html.handler onload

-266

forks/lwd/examples/minesweeper-tyxml/minesweeper.ml

reviewed

··· 1 1 - (* Js_of_ocaml examples 2 2 - * http://www.ocsigen.org/js_of_ocaml/ 3 3 - * Copyright (C) 2008 Benjamin Canou 4 4 - * 5 5 - * DO WHAT THE FUCK YOU WANT TO PUBLIC LICENSE 6 6 - * TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 7 7 - * 8 8 - *) 9 9 - open Js_of_ocaml 10 10 - open Tyxml_lwd 11 11 - open Lwdom 12 12 - 13 13 - let js = Js.string 14 14 - 15 15 - type config = 16 16 - { nbcols : int 17 17 - ; nbrows : int 18 18 - ; nbmines : int 19 19 - } 20 20 - 21 21 - let default_config = { nbcols = 10; nbrows = 10; nbmines = 15 } 22 22 - 23 23 - type cell = 24 24 - { mined : bool 25 25 - ; seen : bool 26 26 - ; flag : bool 27 27 - ; nbm : int 28 28 - } 29 29 - 30 30 - type board = cell array array 31 31 - 32 32 - let iter_on_cell cf f = 33 33 - for i = 0 to cf.nbcols - 1 do 34 34 - for j = 0 to cf.nbrows - 1 do 35 35 - f (i, j) 36 36 - done 37 37 - done 38 38 - 39 39 - let random_list_mines lc m = 40 40 - let cell_list = ref [] in 41 41 - while List.length !cell_list < m do 42 42 - let n = Random.int lc in 43 43 - if not (List.mem n !cell_list) then cell_list := n :: !cell_list 44 44 - done; 45 45 - !cell_list 46 46 - 47 47 - let generate_seed () = 48 48 - let t = Sys.time () in 49 49 - let n = int_of_float (t *. 1000.0) in 50 50 - Random.init (n mod 100000) 51 51 - 52 52 - let valid cf (i, j) = i >= 0 && i < cf.nbcols && j >= 0 && j < cf.nbrows 53 53 - 54 54 - let neighbours cf (x, y) = 55 55 - let ngb = 56 56 - [ x - 1, y - 1 57 57 - ; x - 1, y 58 58 - ; x - 1, y + 1 59 59 - ; x, y - 1 60 60 - ; x, y + 1 61 61 - ; x + 1, y - 1 62 62 - ; x + 1, y 63 63 - ; x + 1, y + 1 64 64 - ] 65 65 - in 66 66 - List.filter (valid cf) ngb 67 67 - 68 68 - let update v f = Lwd.set v (f (Lwd.peek v)) 69 69 - 70 70 - let initialize_board cf = 71 71 - let initial = { mined = false; seen = false; flag = false; nbm = 0 } in 72 72 - let copy_cell_init b (i, j) = b.(i).(j) <- Lwd.var initial in 73 73 - let set_mined b n = 74 74 - update b.(n / cf.nbrows).(n mod cf.nbrows) 75 75 - (fun c -> {c with mined = true}) 76 76 - in 77 77 - let count_mined_adj b (i, j) = 78 78 - let x = ref 0 in 79 79 - let inc_if_mined (i, j) = if (Lwd.peek b.(i).(j)).mined then incr x in 80 80 - List.iter inc_if_mined (neighbours cf (i, j)); 81 81 - !x 82 82 - in 83 83 - let set_count b (i, j) = 84 84 - let cell = b.(i).(j) in 85 85 - if not (Lwd.peek cell).mined then 86 86 - update cell (fun c -> {c with nbm = count_mined_adj b (i, j)}) 87 87 - in 88 88 - let list_mined = random_list_mines (cf.nbcols * cf.nbrows) cf.nbmines in 89 89 - let board = 90 90 - Array.init cf.nbcols @@ fun _ -> 91 91 - Array.init cf.nbrows @@ fun _ -> 92 92 - Lwd.var initial 93 93 - in 94 94 - iter_on_cell cf (copy_cell_init board); 95 95 - List.iter (set_mined board) list_mined; 96 96 - iter_on_cell cf (set_count board); 97 97 - board 98 98 - 99 99 - let cells_to_see bd cf (i, j) = 100 100 - let visited = Array.make_matrix cf.nbcols cf.nbrows false in 101 101 - let rec relevant = function 102 102 - | [] -> [], [] 103 103 - | ((x, y) as c) :: l -> 104 104 - let cell = Lwd.peek bd.(x).(y) in 105 105 - if cell.mined || cell.flag || cell.seen || visited.(x).(y) 106 106 - then relevant l 107 107 - else 108 108 - let l1, l2 = relevant l in 109 109 - visited.(x).(y) <- true; 110 110 - if cell.nbm = 0 then l1, c :: l2 else c :: l1, l2 111 111 - in 112 112 - let rec cells_to_see_rec = function 113 113 - | [] -> [] 114 114 - | ((x, y) as c) :: l -> 115 115 - if (Lwd.peek bd.(x).(y)).nbm <> 0 116 116 - then c :: cells_to_see_rec l 117 117 - else 118 118 - let l1, l2 = relevant (neighbours cf c) in 119 119 - (c :: l1) @ cells_to_see_rec (l2 @ l) 120 120 - in 121 121 - visited.(i).(j) <- true; 122 122 - cells_to_see_rec [ i, j ] 123 123 - 124 124 - let b0 = 3 125 125 - 126 126 - let l1 = 15 127 127 - 128 128 - let l2 = l1 129 129 - 130 130 - let l4 = 20 + (2 * b0) 131 131 - 132 132 - let l3 = (l4 * default_config.nbcols) + (2 * b0) 133 133 - 134 134 - let l5 = 40 + (2 * b0) 135 135 - 136 136 - let h1 = l1 137 137 - 138 138 - let h2 = 30 139 139 - 140 140 - let h3 = l5 + 20 + (2 * b0) 141 141 - 142 142 - let h4 = h2 143 143 - 144 144 - let h5 = 20 + (2 * b0) 145 145 - 146 146 - let h6 = l5 + (2 * b0) 147 147 - 148 148 - type demin_cf = 149 149 - { bd : cell Lwd.var array array 150 150 - ; cf : config 151 151 - ; mutable nb_marked_cells : int 152 152 - ; mutable nb_hidden_cells : int 153 153 - ; mutable flag_switch_on : bool 154 154 - } 155 155 - 156 156 - let cell_image_src cell = 157 157 - Html.uri_of_string @@ 158 158 - if cell.flag 159 159 - then "sprites/flag.png" 160 160 - else if cell.mined 161 161 - then "sprites/bomb.png" 162 162 - else if cell.seen 163 163 - then 164 164 - if cell.nbm = 0 165 165 - then "sprites/empty.png" 166 166 - else "sprites/" ^ string_of_int cell.nbm ^ ".png" 167 167 - else "sprites/normal.png" 168 168 - 169 169 - let cell_image cell ~on_click = 170 170 - Html.img 171 171 - ~src:(Lwd.map ~f:cell_image_src cell) 172 172 - ~alt:(Lwd.pure "Hello") 173 173 - ~a:[Html.a_onclick (Lwdom.attr (fun _ -> on_click ()))] 174 174 - () 175 175 - 176 176 - let mark_cell d cell = 177 177 - let cell' = Lwd.peek cell in 178 178 - if cell'.flag then ( 179 179 - d.nb_marked_cells <- d.nb_marked_cells - 1; 180 180 - Lwd.set cell {cell' with flag = false} 181 181 - ) else ( 182 182 - d.nb_marked_cells <- d.nb_marked_cells + 1; 183 183 - Lwd.set cell {cell' with flag = true} 184 184 - ) 185 185 - 186 186 - let reveal d i j = 187 187 - let reveal_cell (i, j) = 188 188 - Lwd.set d.bd.(i).(j) {(Lwd.peek d.bd.(i).(j)) with seen = true}; 189 189 - d.nb_hidden_cells <- d.nb_hidden_cells - 1 190 190 - in 191 191 - List.iter reveal_cell (cells_to_see d.bd d.cf (i, j)); 192 192 - if d.nb_hidden_cells = 0 193 193 - then (Dom_html.window##alert (js "YOU WIN")) 194 194 - 195 195 - let create_demin nb_c nb_r nb_m = 196 196 - let nbc = max default_config.nbcols nb_c and nbr = max default_config.nbrows nb_r in 197 197 - let nbm = min (nbc * nbr) (max 1 nb_m) in 198 198 - let cf = { nbcols = nbc; nbrows = nbr; nbmines = nbm } in 199 199 - generate_seed (); 200 200 - { cf 201 201 - ; bd = initialize_board cf 202 202 - ; nb_marked_cells = 0 203 203 - ; nb_hidden_cells = (cf.nbrows * cf.nbcols) - cf.nbmines 204 204 - ; flag_switch_on = false 205 205 - } 206 206 - 207 207 - type mode = 208 208 - | Normal 209 209 - | Flag 210 210 - 211 211 - let init_table d = 212 212 - let mode = ref Normal in 213 213 - (*let buf = document##createDocumentFragment in 214 214 - Dom.appendChild buf (document##createTextNode (js "Mode : ")); 215 215 - let img = Html.createImg document in 216 216 - Dom.appendChild buf img; 217 217 - img##.src := js "sprites/bomb.png"; 218 218 - img##.onclick := 219 219 - Html.handler (fun _ -> 220 220 - (match !mode with 221 221 - | Normal -> 222 222 - mode := Flag; 223 223 - img##.src := js "sprites/flag.png" 224 224 - | Flag -> 225 225 - mode := Normal; 226 226 - img##.src := js "sprites/bomb.png"); 227 227 - Js._false); 228 228 - Dom.appendChild buf (Html.createBr document);*) 229 229 - let render_column x col = 230 230 - col 231 231 - |> Array.mapi (fun y cell -> 232 232 - cell_image (Lwd.get cell) ~on_click:(fun () -> 233 233 - begin match !mode with 234 234 - | Normal -> 235 235 - let cell' = Lwd.peek cell in 236 236 - if cell'.seen 237 237 - then () 238 238 - else if d.flag_switch_on 239 239 - then mark_cell d cell 240 240 - else if cell'.flag 241 241 - then () 242 242 - else if cell'.mined 243 243 - then ( 244 244 - (*draw_board d; disable_events d;*) 245 245 - Dom_html.window##alert (js "YOU LOSE")) 246 246 - else reveal d x y 247 247 - | Flag -> 248 248 - update cell (fun c -> {c with flag = not c.flag}) 249 249 - end; 250 250 - true 251 251 - ) 252 252 - ) 253 253 - |> Array.to_list 254 254 - |> children 255 255 - in 256 256 - Array.mapi (fun x col -> 257 257 - children [ 258 258 - children [Html.br ()]; 259 259 - render_column x col; 260 260 - ] 261 261 - ) d.bd 262 262 - |> children_array 263 263 - 264 264 - let run nbc nbr nbm = 265 265 - let d = create_demin nbc nbr nbm in 266 266 - init_table d

forks/lwd/examples/minesweeper-tyxml/sprites/1.png

reviewed

This is a binary file and will not be displayed.

forks/lwd/examples/minesweeper-tyxml/sprites/2.png

reviewed

This is a binary file and will not be displayed.

forks/lwd/examples/minesweeper-tyxml/sprites/3.png

reviewed

This is a binary file and will not be displayed.

forks/lwd/examples/minesweeper-tyxml/sprites/4.png

reviewed

This is a binary file and will not be displayed.

forks/lwd/examples/minesweeper-tyxml/sprites/5.png

reviewed

This is a binary file and will not be displayed.

forks/lwd/examples/minesweeper-tyxml/sprites/6.png

reviewed

This is a binary file and will not be displayed.

forks/lwd/examples/minesweeper-tyxml/sprites/7.png

reviewed

This is a binary file and will not be displayed.

forks/lwd/examples/minesweeper-tyxml/sprites/8.png

reviewed

This is a binary file and will not be displayed.

forks/lwd/examples/minesweeper-tyxml/sprites/bomb.png

reviewed

This is a binary file and will not be displayed.

forks/lwd/examples/minesweeper-tyxml/sprites/empty.png

reviewed

This is a binary file and will not be displayed.

forks/lwd/examples/minesweeper-tyxml/sprites/flag.png

reviewed

This is a binary file and will not be displayed.

forks/lwd/examples/minesweeper-tyxml/sprites/normal.png

reviewed

This is a binary file and will not be displayed.

-301

forks/lwd/examples/minesweeper-tyxml/sprites/scalable.svg

reviewed

··· 1 1 - <?xml version="1.0" encoding="UTF-8" standalone="no"?> 2 2 - <!-- Created with Inkscape (http://www.inkscape.org/) --> 3 3 - <svg 4 4 - xmlns:dc="http://purl.org/dc/elements/1.1/" 5 5 - xmlns:cc="http://creativecommons.org/ns#" 6 6 - xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#" 7 7 - xmlns:svg="http://www.w3.org/2000/svg" 8 8 - xmlns="http://www.w3.org/2000/svg" 9 9 - xmlns:xlink="http://www.w3.org/1999/xlink" 10 10 - xmlns:sodipodi="http://sodipodi.sourceforge.net/DTD/sodipodi-0.dtd" 11 11 - xmlns:inkscape="http://www.inkscape.org/namespaces/inkscape" 12 12 - width="20" 13 13 - height="20" 14 14 - id="svg2" 15 15 - sodipodi:version="0.32" 16 16 - inkscape:version="0.46" 17 17 - version="1.0" 18 18 - inkscape:export-filename="/home/benjamin/Bureau/ocaml_page/examples/minesweeper/8.png" 19 19 - inkscape:export-xdpi="90" 20 20 - inkscape:export-ydpi="90" 21 21 - sodipodi:docname="original.svg" 22 22 - inkscape:output_extension="org.inkscape.output.svg.inkscape"> 23 23 - <defs 24 24 - id="defs4"> 25 25 - <linearGradient 26 26 - id="linearGradient3329"> 27 27 - <stop 28 28 - id="stop3331" 29 29 - offset="0" 30 30 - style="stop-color:#f6f6f6;stop-opacity:1;" /> 31 31 - <stop 32 32 - id="stop3333" 33 33 - offset="1" 34 34 - style="stop-color:#cdcdcd;stop-opacity:1;" /> 35 35 - </linearGradient> 36 36 - <linearGradient 37 37 - id="linearGradient3312"> 38 38 - <stop 39 39 - style="stop-color:#ec4200;stop-opacity:1;" 40 40 - offset="0" 41 41 - id="stop3314" /> 42 42 - <stop 43 43 - id="stop3320" 44 44 - offset="0.5" 45 45 - style="stop-color:#ec2b00;stop-opacity:1;" /> 46 46 - <stop 47 47 - style="stop-color:#face00;stop-opacity:1;" 48 48 - offset="1" 49 49 - id="stop3316" /> 50 50 - </linearGradient> 51 51 - <linearGradient 52 52 - id="linearGradient3227"> 53 53 - <stop 54 54 - style="stop-color:#ffffff;stop-opacity:1;" 55 55 - offset="0" 56 56 - id="stop3229" /> 57 57 - <stop 58 58 - style="stop-color:#000000;stop-opacity:1;" 59 59 - offset="1" 60 60 - id="stop3231" /> 61 61 - </linearGradient> 62 62 - <linearGradient 63 63 - id="linearGradient3169"> 64 64 - <stop 65 65 - style="stop-color:#e0e0e0;stop-opacity:1;" 66 66 - offset="0" 67 67 - id="stop3171" /> 68 68 - <stop 69 69 - style="stop-color:#4a4a4a;stop-opacity:1;" 70 70 - offset="1" 71 71 - id="stop3173" /> 72 72 - </linearGradient> 73 73 - <linearGradient 74 74 - id="linearGradient3161"> 75 75 - <stop 76 76 - style="stop-color:#888a85;stop-opacity:1;" 77 77 - offset="0" 78 78 - id="stop3163" /> 79 79 - <stop 80 80 - style="stop-color:#888a85;stop-opacity:0;" 81 81 - offset="1" 82 82 - id="stop3165" /> 83 83 - </linearGradient> 84 84 - <inkscape:perspective 85 85 - sodipodi:type="inkscape:persp3d" 86 86 - inkscape:vp_x="0 : 526.18109 : 1" 87 87 - inkscape:vp_y="6.1230318e-14 : 1000 : 0" 88 88 - inkscape:vp_z="744.09448 : 526.18109 : 1" 89 89 - inkscape:persp3d-origin="372.04724 : 350.78739 : 1" 90 90 - id="perspective10" /> 91 91 - <linearGradient 92 92 - inkscape:collect="always" 93 93 - xlink:href="#linearGradient3329" 94 94 - id="linearGradient3167" 95 95 - x1="19" 96 96 - y1="19" 97 97 - x2="1" 98 98 - y2="1" 99 99 - gradientUnits="userSpaceOnUse" /> 100 100 - <linearGradient 101 101 - inkscape:collect="always" 102 102 - xlink:href="#linearGradient3329" 103 103 - id="linearGradient3175" 104 104 - x1="1" 105 105 - y1="1" 106 106 - x2="19" 107 107 - y2="19" 108 108 - gradientUnits="userSpaceOnUse" /> 109 109 - <radialGradient 110 110 - inkscape:collect="always" 111 111 - xlink:href="#linearGradient3227" 112 112 - id="radialGradient3233" 113 113 - cx="9.3315725" 114 114 - cy="9.6578655" 115 115 - fx="9.3315725" 116 116 - fy="9.6578655" 117 117 - r="7.0749736" 118 118 - gradientUnits="userSpaceOnUse" 119 119 - gradientTransform="matrix(0.6744495,1.011674,-0.8480598,0.5653733,11.228345,-5.2429421)" /> 120 120 - <linearGradient 121 121 - inkscape:collect="always" 122 122 - xlink:href="#linearGradient3227" 123 123 - id="linearGradient3273" 124 124 - x1="8" 125 125 - y1="6" 126 126 - x2="12" 127 127 - y2="6" 128 128 - gradientUnits="userSpaceOnUse" 129 129 - gradientTransform="matrix(0.7614538,0.4101533,-0.4101533,0.7614538,5.7206622,-0.6279632)" /> 130 130 - <radialGradient 131 131 - inkscape:collect="always" 132 132 - xlink:href="#linearGradient3312" 133 133 - id="radialGradient3318" 134 134 - cx="15.71875" 135 135 - cy="3.234375" 136 136 - fx="15.71875" 137 137 - fy="3.234375" 138 138 - r="2.0909442" 139 139 - gradientTransform="matrix(1.7779835,0,0,1.8444152,-12.793148,-1.4811553)" 140 140 - gradientUnits="userSpaceOnUse" /> 141 141 - <linearGradient 142 142 - inkscape:collect="always" 143 143 - xlink:href="#linearGradient3169" 144 144 - id="linearGradient3325" 145 145 - gradientUnits="userSpaceOnUse" 146 146 - x1="19" 147 147 - y1="19" 148 148 - x2="1" 149 149 - y2="1" 150 150 - gradientTransform="translate(1.0559359e-2,-3.1678968e-2)" /> 151 151 - <linearGradient 152 152 - inkscape:collect="always" 153 153 - xlink:href="#linearGradient3169" 154 154 - id="linearGradient3327" 155 155 - gradientUnits="userSpaceOnUse" 156 156 - x1="1" 157 157 - y1="1" 158 158 - x2="19" 159 159 - y2="19" 160 160 - gradientTransform="translate(1.0559359e-2,-3.1678968e-2)" /> 161 161 - </defs> 162 162 - <sodipodi:namedview 163 163 - id="base" 164 164 - pagecolor="#ffffff" 165 165 - bordercolor="#666666" 166 166 - borderopacity="1.0" 167 167 - inkscape:pageopacity="0.0" 168 168 - inkscape:pageshadow="2" 169 169 - inkscape:zoom="47.35" 170 170 - inkscape:cx="10" 171 171 - inkscape:cy="10" 172 172 - inkscape:document-units="px" 173 173 - inkscape:current-layer="layer5" 174 174 - showgrid="false" 175 175 - guidetolerance="10000" 176 176 - gridtolerance="10000" 177 177 - objecttolerance="10000" 178 178 - inkscape:window-width="1920" 179 179 - inkscape:window-height="1149" 180 180 - inkscape:window-x="0" 181 181 - inkscape:window-y="50" 182 182 - showguides="true" 183 183 - inkscape:guide-bbox="true"> 184 184 - <inkscape:grid 185 185 - type="xygrid" 186 186 - id="grid2383" 187 187 - visible="true" 188 188 - enabled="true" /> 189 189 - </sodipodi:namedview> 190 190 - <metadata 191 191 - id="metadata7"> 192 192 - <rdf:RDF> 193 193 - <cc:Work 194 194 - rdf:about=""> 195 195 - <dc:format>image/svg+xml</dc:format> 196 196 - <dc:type 197 197 - rdf:resource="http://purl.org/dc/dcmitype/StillImage" /> 198 198 - </cc:Work> 199 199 - </rdf:RDF> 200 200 - </metadata> 201 201 - <g 202 202 - inkscape:label="fond" 203 203 - inkscape:groupmode="layer" 204 204 - id="layer1" 205 205 - style="display:inline"> 206 206 - <rect 207 207 - style="opacity:1;fill:url(#linearGradient3167);fill-opacity:1.0;stroke:url(#linearGradient3175);stroke-width:1;stroke-linecap:square;stroke-linejoin:miter;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1" 208 208 - id="rect2389" 209 209 - width="18" 210 210 - height="18" 211 211 - x="1" 212 212 - y="1" 213 213 - rx="3" 214 214 - ry="3" /> 215 215 - </g> 216 216 - <g 217 217 - inkscape:groupmode="layer" 218 218 - id="layer4" 219 219 - style="display:none"> 220 220 - <rect 221 221 - style="opacity:1;fill:url(#linearGradient3325);fill-opacity:1;stroke:url(#linearGradient3327);stroke-width:1;stroke-linecap:square;stroke-linejoin:miter;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1;display:inline" 222 222 - id="rect3323" 223 223 - width="18" 224 224 - height="18" 225 225 - x="1.0105594" 226 226 - y="0.96832085" 227 227 - rx="3" 228 228 - ry="3" /> 229 229 - </g> 230 230 - <g 231 231 - inkscape:groupmode="layer" 232 232 - id="layer3" 233 233 - inkscape:label="bomb" 234 234 - style="display:none"> 235 235 - <path 236 236 - sodipodi:type="arc" 237 237 - style="opacity:1;fill:url(#radialGradient3233);fill-opacity:1;stroke:none;stroke-width:1;stroke-linecap:square;stroke-linejoin:miter;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1" 238 238 - id="path3217" 239 239 - sodipodi:cx="11.256599" 240 240 - sodipodi:cy="11.657866" 241 241 - sodipodi:rx="7.0749736" 242 242 - sodipodi:ry="7.0749736" 243 243 - d="M 18.331573,11.657866 A 7.0749736,7.0749736 0 1 1 4.1816258,11.657866 A 7.0749736,7.0749736 0 1 1 18.331573,11.657866 z" 244 244 - transform="matrix(0.7614538,0.4101533,-0.4101533,0.7614538,4.5664032,-0.9135925)" /> 245 245 - <path 246 246 - style="opacity:1;fill:url(#linearGradient3273);fill-opacity:1;stroke:none;stroke-width:1;stroke-linecap:square;stroke-linejoin:miter;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1" 247 247 - d="M 10.581833,4.9376249 L 9.3513731,7.2219865 C 9.1249687,7.6423091 9.623483,8.3509378 10.464128,8.803747 C 11.304773,9.2565562 12.170784,9.2829225 12.397189,8.8625999 L 13.627649,6.5782383 C 13.401244,6.9985608 12.535233,6.9721946 11.694588,6.5193853 C 10.853943,6.0665761 10.355429,5.3579474 10.581833,4.9376249 z" 248 248 - id="path3251" /> 249 249 - <path 250 250 - d="M 12,6 A 2,1 0 1 1 8,6 A 2,1 0 1 1 12,6 z" 251 251 - sodipodi:ry="1" 252 252 - sodipodi:rx="2" 253 253 - sodipodi:cy="6" 254 254 - sodipodi:cx="10" 255 255 - id="path3261" 256 256 - style="opacity:1;fill:#a3a3a3;fill-opacity:1;stroke:none;stroke-width:1;stroke-linecap:square;stroke-linejoin:miter;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1" 257 257 - sodipodi:type="arc" 258 258 - transform="matrix(0.7614538,0.4101533,-0.4101533,0.7614538,6.9511221,-2.9123247)" /> 259 259 - <path 260 260 - style="fill:none;fill-rule:evenodd;stroke:#000000;stroke-width:0.69999999;stroke-linecap:round;stroke-linejoin:miter;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1" 261 261 - d="M 12.45579,5.4071681 C 13.079466,4.249308 15.048968,4.2520623 15.048968,4.2520623" 262 262 - id="path3309" /> 263 263 - <path 264 264 - style="fill:none;fill-rule:evenodd;stroke:url(#radialGradient3318);stroke-width:0.99013829px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1" 265 265 - d="M 13.76548,1.122875 L 14.654472,2.7897345 L 13.76548,1.122875 z M 16.876951,1.178437 L 15.876836,2.8452965 L 16.876951,1.178437 z M 11.931935,2.6786105 L 13.598794,3.6787262 L 11.931935,2.6786105 z M 18.377125,3.1231064 L 16.654704,3.9565362 L 18.377125,3.1231064 z M 13.598794,5.1788998 L 11.931935,6.1234535 L 13.598794,5.1788998 z M 16.710266,5.1788998 L 18.266001,6.2901395 L 16.710266,5.1788998 z M 14.543348,6.0678916 L 13.543232,7.6791891 L 14.543348,6.0678916 z M 15.765712,6.1234535 L 16.599142,7.845875 L 15.765712,6.1234535 z" 266 266 - id="path3289" /> 267 267 - </g> 268 268 - <g 269 269 - inkscape:groupmode="layer" 270 270 - id="layer2" 271 271 - inkscape:label="drapal" 272 272 - style="display:none"> 273 273 - <path 274 274 - style="fill:#cc0000;fill-rule:evenodd;stroke:#000000;stroke-width:0.82692653px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1" 275 275 - d="M 6.0591867,4.5318592 C 6.0591867,4.5318592 6.8697195,3.886521 8.9374052,3.9049592 C 11.005091,3.9233974 11.666751,4.992815 12.956987,5.0296916 C 14.247222,5.066568 15.735956,4.4949827 15.735956,4.4949827 L 15.735956,9.5654974 C 15.735956,9.5654974 14.793092,10.06333 13.337441,10.026453 C 11.88179,9.9895764 11.451711,9.0861033 9.202069,8.9939122 C 6.9524269,8.9017209 6.174977,9.3995533 6.174977,9.3995533 L 6.0591867,4.5318592 z" 276 276 - id="path3192" /> 277 277 - <path 278 278 - style="fill:none;fill-rule:evenodd;stroke:#000000;stroke-width:0.82692653px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1" 279 279 - d="M 6.0591867,4.6240504 L 6.3238504,16.221701" 280 280 - id="path3194" /> 281 281 - </g> 282 282 - <g 283 283 - inkscape:groupmode="layer" 284 284 - id="layer5" 285 285 - inkscape:label="nuù" 286 286 - style="display:inline"> 287 287 - <text 288 288 - xml:space="preserve" 289 289 - style="font-size:12px;font-style:normal;font-weight:normal;fill:#000000;fill-opacity:1;stroke:none;stroke-width:1px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1;font-family:Bitstream Vera Sans" 290 290 - x="4.7695312" 291 291 - y="15.832031" 292 292 - id="text3356" 293 293 - inkscape:export-xdpi="90" 294 294 - inkscape:export-ydpi="90"><tspan 295 295 - sodipodi:role="line" 296 296 - x="4.7695312" 297 297 - y="15.832031" 298 298 - style="font-size:16px;font-style:normal;font-variant:normal;font-weight:normal;font-stretch:normal;font-family:DejaVu Sans;-inkscape-font-specification:DejaVu Sans" 299 299 - id="tspan3360">8</tspan></text> 300 300 - </g> 301 301 - </svg>

+6 -5

forks/lwd/examples/minimal.ml forks/nottui/examples/minimal.ml

reviewed

··· 2 2 3 3 (* Put the UI here *) 4 4 5 5 + 5 6 (*let node title ~f = 6 7 let vopened = Lwd.var false in 7 8 let label = ··· 43 44 if d = d' then f else (string_of_float (c_to_f d), 0)) 44 45 45 46 let farenheit_edit = 46 46 - Nottui_widgets.edit_field 47 47 + W.edit_field 47 48 farenheit_text 48 49 ~on_change:(fun (text, _ as state) -> 49 50 let d = match float_of_string_opt text with ··· 61 62 ~f:(fun d (d', f) -> if d = d' then f else (string_of_float d, 0)) 62 63 63 64 let celsius_edit = 64 64 - Nottui_widgets.edit_field 65 65 + W.edit_field 65 66 celsius_text 66 67 ~on_change:(fun (text, _ as state) -> 67 68 let d = match float_of_string_opt text with ··· 74 75 75 76 let root = 76 77 Lwd_utils.pack Ui.pack_y [ 77 77 - Lwd.pure (Nottui_widgets.string "Celsius:"); 78 78 + Lwd.pure (W.string "Celsius:"); 78 79 celsius_edit; 79 79 - Lwd.pure (Nottui_widgets.string "Farenheight:"); 80 80 + Lwd.pure (W.string "Farenheight:"); 80 81 farenheit_edit; 81 82 ] 82 83 ··· 94 95 root; root; root; root; root; root; 95 96 ] 96 97 97 97 - let root = Nottui_widgets.scrollbox root 98 98 + let root = W.Old.scrollbox root 98 99 99 100 let () = Ui_loop.run ~tick_period:0.2 root

+16 -15

forks/lwd/examples/misc.ml forks/nottui/examples/misc.ml

reviewed

··· 1 1 open Nottui 2 2 - open Nottui_widgets 2 2 + 3 3 4 4 (* App-specific widgets *) 5 5 6 6 let simple_edit x = 7 7 let var = Lwd.var (x, 0) in 8 8 - edit_field (Lwd.get var) ~on_change:(Lwd.set var) ~on_submit:ignore 8 8 + W.edit_field (Lwd.get var) ~on_change:(Lwd.set var) ~on_submit:ignore 9 9 10 10 let strict_table () = 11 11 let columns = Lwd_table.make () in 12 12 for colidx = 0 to 99 do 13 13 let rows = Lwd_table.make () in 14 14 - Lwd_table.append' rows (printf "Column %d" colidx |> Lwd.pure); 14 14 + Lwd_table.append' rows (W.printf "Column %d" colidx |> Lwd.pure); 15 15 for rowidx = 0 to 99 do 16 16 Lwd_table.append' rows 17 17 (simple_edit (Printf.sprintf "Test-%03d-%03d" colidx rowidx)) ··· 20 20 ( rows 21 21 |> Lwd_table.reduce (Lwd_utils.lift_monoid Ui.pack_y) 22 22 |> Lwd.join ); 23 23 - Lwd_table.append' columns (Lwd.return (string " ")) 23 23 + Lwd_table.append' columns (Lwd.return (W.string " ")) 24 24 done; 25 25 - scroll_area 25 25 + W.Scroll.area 26 26 @@ Lwd.join (Lwd_table.reduce (Lwd_utils.lift_monoid Ui.pack_x) columns) 27 27 28 28 (*let lazy_table t = ··· 81 81 else lazy_table body; 82 82 in 83 83 view_menu () 84 84 - *) 84 84 + *) 85 85 86 86 (* Entry point *) 87 87 ··· 90 90 let bot = Lwd.var (Lwd.return Ui.empty) 91 91 92 92 let wm = 93 93 - Nottui_widgets.window_manager @@ 94 94 - Lwd_utils.pack Ui.pack_y [ Lwd.join (Lwd.get top); Lwd.join (Lwd.get bot) ] 93 93 + W.Old.window_manager @@ 94 94 + W.vbox [ Lwd.join (Lwd.get top); Lwd.join (Lwd.get bot) ] 95 95 96 96 (*let () = Statmemprof_emacs.start 1E-4 30 5*) 97 97 98 98 let () = 99 99 + let open W.Old in 99 100 Lwd.set top @@ 100 101 Lwd_utils.pack Ui.pack_x 101 102 [ 102 103 main_menu_item wm "File" (fun () -> 103 103 - Lwd_utils.pack Ui.pack_y 104 104 + W.vbox 104 105 [ 105 106 Lwd.return @@ sub_entry "New" ignore; 106 107 Lwd.return @@ sub_entry "Open" ignore; 107 108 sub_menu_item wm "Recent" (fun () -> 108 108 - Lwd_utils.pack Ui.pack_y 109 109 + W.vbox 109 110 [ 110 111 Lwd.return @@ sub_entry "A" ignore; 111 112 Lwd.return @@ sub_entry "B" ignore; ··· 114 115 Lwd.return @@ sub_entry "Quit" (fun () -> raise Exit); 115 116 ]); 116 117 main_menu_item wm "View" (fun _ -> 117 117 - Lwd.set bot (Lwd.return (string "<View>")); 118 118 + Lwd.set bot (Lwd.return (W.string "<View>")); 118 119 Lwd.return Ui.empty); 119 120 main_menu_item wm "Edit" (fun _ -> 120 120 - Lwd.set bot (Lwd.return (string "<Edit>")); 121 121 + Lwd.set bot (Lwd.return (W.string "<Edit>")); 121 122 Lwd.return Ui.empty); 122 123 ]; 123 124 Lwd.set bot @@ 124 124 - Lwd_utils.pack Ui.pack_y 125 125 + W.vbox 125 126 [ 126 127 simple_edit "Hello world"; 127 127 - v_pane (strict_table ()) (Lwd.return @@ string "B"); 128 128 - h_pane (Lwd.return (string "A")) (Lwd.return (string "B")); 128 128 + W.v_pane (strict_table ()) (Lwd.return @@ W.string "B"); 129 129 + W.h_pane (Lwd.return (W.string "A")) (Lwd.return (W.string "B")); 129 130 ]; 130 131 try Ui_loop.run ~tick_period:0.2 (window_manager_view wm) 131 132 with Exit -> ()

+8 -8

forks/lwd/examples/pretty.ml forks/nottui/examples/pretty.ml

reviewed

··· 1 1 open Nottui 2 2 module P = Nottui_pretty 3 3 4 4 - let string ?attr text = P.ui (Nottui_widgets.string ?attr text) 4 4 + let string ?attr text = P.ui (W.string ?attr text) 5 5 6 6 let (^^) = P.(^^) 7 7 let (^/^) a b = P.(a ^^ break 1 ^^ b) 8 8 9 9 - let base = Lwd.var Nottui_widgets.empty_lwd 9 9 + let base = Lwd.var W.empty_lwd 10 10 11 11 - let wm = Nottui_widgets.window_manager (Lwd.join (Lwd.get base)) 11 11 + let wm = W.Old.window_manager (Lwd.join (Lwd.get base)) 12 12 13 13 let spring = P.ui (Ui.resize ~sw:1 Ui.empty) 14 14 15 15 let selector text f choices = 16 16 - Nottui_widgets.main_menu_item wm text (fun () -> 16 16 + W.Old.main_menu_item wm text (fun () -> 17 17 Lwd.pure @@ Ui.vcat ( 18 18 List.map 19 19 (fun choice -> 20 20 - Nottui_widgets.sub_entry choice (fun () -> f choice)) 20 20 + W.Old.sub_entry choice (fun () -> f choice)) 21 21 choices 22 22 ) 23 23 ) ··· 70 70 71 71 let () = 72 72 Lwd.set base ( 73 73 - Nottui_widgets.h_pane 74 74 - (Nottui_widgets.scroll_area (varying_width contents)) 73 73 + W.h_pane 74 74 + (W.Scroll.area (varying_width contents)) 75 75 (Lwd.pure Ui.empty) 76 76 ); 77 77 - Ui_loop.run (Nottui_widgets.window_manager_view wm) 77 77 + Ui_loop.run (W.Old.window_manager_view wm)

+18 -16

forks/lwd/examples/reranger.ml forks/nottui/examples/reranger.ml

reviewed

··· 1 1 open Nottui 2 2 - open Nottui_widgets 2 2 + open! Lwd_infix 3 3 + 3 4 4 5 let is_double_click = 5 6 let k = ref 0 in ··· 18 19 19 20 let remember_width ~wref ui = 20 21 wref := max (Ui.layout_spec ui).Ui.w !wref; 21 21 - Ui.resize ~w:!wref ui 22 22 + Ui.resize ~w:!wref ui 22 23 23 24 let rec dir ?(initial_path = []) ?after_width:(wref = ref 0) path = 24 25 let column = Lwd.var (Lwd.return Ui.empty) in 25 25 - let header = string ~attr:Notty.(A.bg A.green) (Filename.basename path) in 26 26 + let header = W.string ~attr:Notty.(A.bg A.green) (Filename.basename path) in 26 27 let after = Lwd.var (Lwd.return Ui.empty) in 27 28 let directories = Lwd_table.make () in 28 29 let files = Lwd_table.make () in 29 30 let body = 30 30 - Nottui_widgets.scroll_area 31 31 - (Lwd_utils.pack Ui.pack_y 31 31 + 32 32 + (W.vbox 32 33 [ 33 34 Lwd_table.reduce Ui.pack_y directories; 34 35 Lwd_table.reduce Ui.pack_y files; 35 36 ]) 37 37 + |>W.Scroll.v_area 36 38 in 37 39 let rec set_constrain constrain = 38 40 let header = ··· 44 46 `Handled | _ -> `Unhandled) 45 47 header 46 48 in 47 47 - let t = Lwd_utils.pack Ui.pack_y [ Lwd.return header; body ] in 49 49 + let t = W.vbox [ Lwd.return header; body ] in 48 50 let t = 49 49 - if constrain then Lwd.map ~f:(Ui.resize ~w:12) t 51 51 + if constrain then Lwd.map ~f:(Ui.resize ~w:12 ) t 50 52 else Lwd.map ~f:(remember_width ~wref) t 51 53 in 52 54 Lwd.set column (Lwd_utils.pack Ui.pack_x [ t; Lwd.join (Lwd.get after) ]) ··· 58 60 let t = 59 61 try dir ?initial_path ~after_width (Filename.concat path name) 60 62 with exn -> 61 61 - Lwd.return (string ~attr:Notty.(A.bg A.red) (Printexc.to_string exn)) 63 63 + Lwd.return (W.string ~attr:Notty.(A.bg A.red) (Printexc.to_string exn)) 62 64 in 63 63 - Lwd.set after (Lwd.map ~f:(Ui.join_x (string " ")) t) 65 65 + Lwd.set after (Lwd.map ~f:(Ui.join_x (W.string " ")) t) 64 66 in 65 67 let highlighted_cell = ref None in 66 68 let rec render_directory ?(highlight = false) cell name = ··· 76 78 render_directory ~highlight:true cell name; 77 79 goto name; 78 80 `Handled | _ -> `Unhandled) 79 79 - (string 81 81 + (W.string 80 82 ~attr:Notty.(A.bg (if highlight then A.lightblue else A.blue)) 81 83 name) 82 84 in ··· 100 102 ^ Filename.quote (Filename.concat path name) ) 101 103 : int ); 102 104 `Handled | _ -> `Unhandled) 103 103 - (string name) 105 105 + (W.string name) 104 106 in 105 107 let entries = Sys.readdir path in 106 108 Array.sort String.compare entries; ··· 112 114 let text = 113 115 match exn with Sys_error _ -> name | exn -> Printexc.to_string exn 114 116 in 115 115 - Lwd_table.append' files (string ~attr:Notty.(A.bg A.red) text)) 117 117 + Lwd_table.append' files (W.string ~attr:Notty.(A.bg A.red) text)) 116 118 entries; 117 119 (match initial_path with [] -> () | x :: xs -> goto ~initial_path:xs x); 118 120 Lwd.join (Lwd.get column) ··· 130 132 List.rev (split (Sys.getcwd ())) 131 133 in 132 134 let body = Lwd.var (Lwd.pure Ui.empty) in 133 133 - let wm = Nottui_widgets.window_manager (Lwd.join (Lwd.get body)) in 134 134 - let ui = Lwd_utils.pack Ui.pack_y [ 135 135 - main_menu_item wm "Quit" (fun () -> exit 0); 135 135 + let wm = W.Old.window_manager (Lwd.join (Lwd.get body)) in 136 136 + let ui = W.vbox [ 137 137 + W.Old.main_menu_item wm "Quit" (fun () -> exit 0); 136 138 dir ~initial_path "/" 137 139 ] 138 140 in 139 141 Lwd.set body (Lwd.map ~f:(Ui.resize ~pad:gravity_pad ~crop:gravity_crop) ui); 140 140 - Ui_loop.run (Nottui_widgets.window_manager_view wm) 142 142 + Ui_loop.run (W.Old.window_manager_view wm) 141 143

+3 -3

forks/lwd/examples/stress.ml forks/nottui/examples/stress.ml

reviewed

··· 1 1 open Nottui 2 2 - open Nottui_widgets 2 2 + 3 3 4 4 (* App-specific widgets *) 5 5 ··· 11 11 Lwd_table.append' columns rows; 12 12 Array.init 100 (fun _ -> Lwd_table.append rows ~set:0)) 13 13 in 14 14 - let render_cell _ v = string (string_of_int v) in 14 14 + let render_cell _ v = W.string (string_of_int v) in 15 15 let render_column _ rows = Lwd_table.map_reduce render_cell Ui.pack_y rows in 16 16 let table = 17 17 Lwd_table.map_reduce render_column 18 18 (Lwd_utils.lift_monoid Ui.pack_x) 19 19 columns 20 20 in 21 21 - (cells, Lwd.join table |> scroll_area) 21 21 + (cells, Lwd.join table |> W.Scroll.area) 22 22 23 23 (* Entry point *) 24 24

-4

forks/lwd/lib/brr-lwd/dune

reviewed

··· 1 1 - (library 2 2 - (name brr_lwd) 3 3 - (public_name brr-lwd) 4 4 - (libraries brr lwd))

-411

forks/lwd/lib/brr-lwd/elwd.ml

reviewed

··· 1 1 - open Brr 2 2 - open El 3 3 - 4 4 - type t = El.t 5 5 - 6 6 - type 'a col = [ 7 7 - | `P of 'a 8 8 - (** Pure element *) 9 9 - | `R of 'a Lwd.t 10 10 - (** Reactive element *) 11 11 - | `S of 'a Lwd_seq.t Lwd.t 12 12 - (** Reactive sequence of elements *) 13 13 - ] list 14 14 - (** Describing collections of elements *) 15 15 - 16 16 - type handler = Handler : { 17 17 - opts: Ev.listen_opts option; 18 18 - type': 'a Ev.type'; 19 19 - func: 'a Ev.t -> unit; 20 20 - } -> handler 21 21 - 22 22 - let handler ?opts type' func = 23 23 - Handler {opts; type'; func} 24 24 - 25 25 - let is_pure_element = function 26 26 - | `P _ -> true 27 27 - | `R x -> Option.is_some (Lwd.is_pure x) 28 28 - | `S x -> Option.is_some (Lwd.is_pure x) 29 29 - 30 30 - let extract_pure_element x = Option.get (Lwd.is_pure x) 31 31 - 32 32 - let extract_pure_elements xs = 33 33 - List.flatten ( 34 34 - List.map (function 35 35 - | `P x -> [x] 36 36 - | `R x -> [extract_pure_element x] 37 37 - | `S x -> Lwd_seq.to_list (extract_pure_element x) 38 38 - ) xs 39 39 - ) 40 40 - 41 41 - let prepare_col : _ col -> _ = function 42 42 - | [] -> [], [] 43 43 - | col -> 44 44 - let pure, impure = List.partition is_pure_element col in 45 45 - extract_pure_elements pure, impure 46 46 - 47 47 - (** Reactive sequence of elements *) 48 48 - 49 49 - let consume_children = function 50 50 - | [] -> [], None 51 51 - | [`P x] -> [x], None 52 52 - | [`S x] -> [], Some x 53 53 - | [`R x] -> [], Some (Lwd.map ~f:Lwd_seq.element x) 54 54 - | col -> 55 55 - if List.for_all is_pure_element col 56 56 - then 57 57 - List.flatten ( 58 58 - List.map (function 59 59 - | `P x -> [x] 60 60 - | `R x -> [extract_pure_element x] 61 61 - | `S x -> Lwd_seq.to_list (extract_pure_element x) 62 62 - ) 63 63 - col 64 64 - ), None 65 65 - else [], Some ( 66 66 - Lwd_utils.map_reduce (function 67 67 - | `P x -> Lwd.pure (Lwd_seq.element x) 68 68 - | `R x -> Lwd.map ~f:Lwd_seq.element x 69 69 - | `S x -> x 70 70 - ) Lwd_seq.lwd_monoid 71 71 - col 72 72 - ) 73 73 - 74 74 - type child_tree = 75 75 - | Leaf of El.t 76 76 - | Inner of { mutable bound: Jv.t; 77 77 - left: child_tree; right: child_tree; } 78 78 - 79 79 - let child_node node = Leaf node 80 80 - 81 81 - let child_join left right = Inner { bound = Jv.null; left; right } 82 82 - 83 83 - let jv_parentNode = Jstr.v "parentNode" 84 84 - let jv_nextSibling = Jstr.v "nextSibling" 85 85 - let jv_append = Jstr.v "append" 86 86 - let jv_before = Jstr.v "before" 87 87 - let jv_remove = Jstr.v "remove" 88 88 - let jv_contains = Jstr.v "contains" 89 89 - 90 90 - let jv_toRemove = 91 91 - Jstr.v "lwd-to-remove" (* HACK Could be turned into a Javascript symbol *) 92 92 - 93 93 - let contains_focus node = 94 94 - match Brr.Document.active_el (Brr.El.document node) with 95 95 - | None -> false 96 96 - | Some el -> 97 97 - Jv.to_bool (Jv.call' (El.to_jv node) jv_contains [|El.to_jv el|]) 98 98 - 99 99 - let update_children 100 100 - (self : El.t) 101 101 - (children : El.t Lwd_seq.t Lwd.t) : El.t Lwd.t = 102 102 - let reducer = 103 103 - ref (Lwd_seq.Reducer.make ~map:child_node ~reduce:child_join) 104 104 - in 105 105 - Lwd.map children ~f:begin fun children -> 106 106 - let dropped, reducer' = 107 107 - Lwd_seq.Reducer.update_and_get_dropped !reducer children in 108 108 - reducer := reducer'; 109 109 - let schedule_for_removal child () = match child with 110 110 - | Leaf node -> Jv.set' (El.to_jv node) jv_toRemove Jv.true'; 111 111 - | Inner _ -> () 112 112 - in 113 113 - Lwd_seq.Reducer.fold_dropped `Map schedule_for_removal dropped (); 114 114 - let preserve_focus = contains_focus self in 115 115 - begin match Lwd_seq.Reducer.reduce reducer' with 116 116 - | None -> () 117 117 - | Some tree -> 118 118 - let rec update acc = function 119 119 - | Leaf node -> 120 120 - let node' = El.to_jv node in 121 121 - Jv.delete' node' jv_toRemove; 122 122 - (*Brr.Console.log ["Updating "; node];*) 123 123 - if Jv.get' node' jv_parentNode != El.to_jv self then ( 124 124 - if Jv.is_null acc 125 125 - then ignore (Jv.call' (El.to_jv self) jv_append [|node'|]) 126 126 - else ignore (Jv.call' acc jv_before [|node'|]) 127 127 - ) else if ( 128 128 - (* Check if there is not any work to do *) 129 129 - Jv.get' node' jv_nextSibling != acc && 130 130 - (* Check if we are in the focus case and try to "bubble sort" to 131 131 - preserve focus *) 132 132 - not ( 133 133 - preserve_focus && contains_focus node && 134 134 - let rec shift_siblings () = 135 135 - let sibling = Jv.get' node' jv_nextSibling in 136 136 - if sibling == acc then true 137 137 - else if Jv.is_null sibling then false 138 138 - else ( 139 139 - ignore (Jv.call' node' jv_before [|sibling|]); 140 140 - shift_siblings () 141 141 - ) 142 142 - in 143 143 - shift_siblings () 144 144 - ) 145 145 - ) then ( 146 146 - if Jv.is_null acc 147 147 - then ignore (Jv.call' (El.to_jv self) jv_append [|node'|]) 148 148 - else ignore (Jv.call' acc jv_before [|node'|]) 149 149 - ); 150 150 - node' 151 151 - | Inner t -> 152 152 - if Jv.is_null t.bound then ( 153 153 - let acc = update acc t.right in 154 154 - let acc = update acc t.left in 155 155 - t.bound <- acc; 156 156 - acc 157 157 - ) else 158 158 - t.bound 159 159 - in 160 160 - ignore (update Jv.null tree) 161 161 - end; 162 162 - let remove_child child () = match child with 163 163 - | Leaf node -> 164 164 - let node = El.to_jv node in 165 165 - if Jv.is_some (Jv.get' node jv_toRemove) then ( 166 166 - (*Brr.Console.log ["Removing "; node];*) 167 167 - Jv.delete' node jv_toRemove; 168 168 - ignore (Jv.call' node jv_remove [||]) 169 169 - ) 170 170 - | Inner _ -> () 171 171 - in 172 172 - Lwd_seq.Reducer.fold_dropped `Map remove_child dropped (); 173 173 - self 174 174 - end 175 175 - 176 176 - let pure_unit = Lwd.pure () 177 177 - 178 178 - let dummy_kv_at = (Jstr.empty, Jstr.empty) 179 179 - 180 180 - let attach_attribs el attribs = 181 181 - let set_kv (k, v) = 182 182 - if Jstr.equal k At.Name.class' 183 183 - then El.set_class v true el 184 184 - else El.set_at k (Some v) el 185 185 - in 186 186 - let unset_kv (k, v) = 187 187 - if Jstr.equal k At.Name.class' 188 188 - then El.set_class v false el 189 189 - else El.set_at k None el 190 190 - in 191 191 - let set_lwd_at () = 192 192 - let prev = ref dummy_kv_at in 193 193 - fun at -> 194 194 - if !prev != dummy_kv_at then 195 195 - unset_kv !prev; 196 196 - let pair = At.to_pair at in 197 197 - set_kv pair; 198 198 - prev := pair 199 199 - in 200 200 - Lwd_utils.map_reduce (function 201 201 - | `P _ -> assert false 202 202 - | `R at -> Lwd.map ~f:(set_lwd_at ()) at 203 203 - | `S ats -> 204 204 - let set_at' at = 205 205 - let kv = At.to_pair at in 206 206 - set_kv kv; 207 207 - kv 208 208 - in 209 209 - let reducer = 210 210 - ref (Lwd_seq.Reducer.make 211 211 - ~map:set_at' 212 212 - ~reduce:(fun _ _ -> dummy_kv_at)) 213 213 - in 214 214 - let update ats = 215 215 - let dropped, reducer' = 216 216 - Lwd_seq.Reducer.update_and_get_dropped !reducer ats 217 217 - in 218 218 - reducer := reducer'; 219 219 - Lwd_seq.Reducer.fold_dropped `Map 220 220 - (fun kv () -> unset_kv kv) 221 221 - dropped (); 222 222 - ignore (Lwd_seq.Reducer.reduce reducer': _ option) 223 223 - in 224 224 - Lwd.map ~f:update ats 225 225 - ) (pure_unit, fun _ _ -> pure_unit) 226 226 - attribs 227 227 - 228 228 - let listen el (Handler {opts; type'; func}) = 229 229 - Ev.listen ?opts type' func (El.as_target el) 230 230 - 231 231 - let attach_events el events = 232 232 - Lwd_utils.map_reduce (function 233 233 - | `P _ -> assert false 234 234 - | `R at -> 235 235 - let cached = ref None in 236 236 - Lwd.map ~f:(fun h -> 237 237 - begin match !cached with 238 238 - | None -> () 239 239 - | Some l -> Ev.unlisten l 240 240 - end; 241 241 - cached := Some (listen el h) 242 242 - ) at 243 243 - | `S ats -> 244 244 - let reducer = 245 245 - ref (Lwd_seq.Reducer.make 246 246 - ~map:(listen el) 247 247 - ~reduce:(fun x _y -> x)) 248 248 - in 249 249 - let update ats = 250 250 - let dropped, reducer' = 251 251 - Lwd_seq.Reducer.update_and_get_dropped !reducer ats 252 252 - in 253 253 - reducer := reducer'; 254 254 - Lwd_seq.Reducer.fold_dropped `Map 255 255 - (fun l () -> Ev.unlisten l) 256 256 - dropped (); 257 257 - ignore (Lwd_seq.Reducer.reduce reducer': _ option) 258 258 - in 259 259 - Lwd.map ~f:update ats 260 260 - ) (pure_unit, fun _ _ -> pure_unit) 261 261 - events 262 262 - 263 263 - let v ?d ?(at=[]) ?(ev=[]) tag children = 264 264 - let at, impure_at = prepare_col at in 265 265 - let ev, impure_ev = prepare_col ev in 266 266 - let children, impure_children = consume_children children in 267 267 - let el = El.v ?d ~at tag children in 268 268 - let result = 269 269 - match impure_at, impure_children with 270 270 - | [], None -> Lwd.pure el 271 271 - | [], Some children -> 272 272 - update_children el children 273 273 - | at, None -> 274 274 - Lwd.map ~f:(fun () -> el) (attach_attribs el at) 275 275 - | at, Some children -> 276 276 - Lwd.map2 ~f:(fun () el -> el) 277 277 - (attach_attribs el at) 278 278 - (update_children el children) 279 279 - in 280 280 - List.iter (fun h -> ignore (listen el h)) ev; 281 281 - let result = 282 282 - match impure_ev with 283 283 - | [] -> result 284 284 - | evs -> 285 285 - Lwd.map2 ~f:(fun () el -> el) 286 286 - (attach_events el evs) 287 287 - result 288 288 - in 289 289 - result 290 290 - 291 291 - (** {1:els Element constructors} *) 292 292 - 293 293 - type cons = ?d:document -> ?at:At.t col -> ?ev:handler col -> t col -> t Lwd.t 294 294 - (** The type for element constructors. This is simply {!v} with a 295 295 - pre-applied element name. *) 296 296 - 297 297 - type void_cons = ?d:document -> ?at:At.t col -> ?ev:handler col -> unit -> t Lwd.t 298 298 - (** The type for void element constructors. This is simply {!v} 299 299 - with a pre-applied element name and without children. *) 300 300 - 301 301 - let cons name ?d ?at ?ev cs = v ?d ?at ?ev name cs 302 302 - let void_cons name ?d ?at ?ev () = v ?d ?at ?ev name [] 303 303 - 304 304 - let a = cons Name.a 305 305 - let abbr = cons Name.abbr 306 306 - let address = cons Name.address 307 307 - let area = void_cons Name.area 308 308 - let article = cons Name.article 309 309 - let aside = cons Name.aside 310 310 - let audio = cons Name.audio 311 311 - let b = cons Name.b 312 312 - let base = void_cons Name.base 313 313 - let bdi = cons Name.bdi 314 314 - let bdo = cons Name.bdo 315 315 - let blockquote = cons Name.blockquote 316 316 - let body = cons Name.body 317 317 - let br = void_cons Name.br 318 318 - let button = cons Name.button 319 319 - let canvas = cons Name.canvas 320 320 - let caption = cons Name.caption 321 321 - let cite = cons Name.cite 322 322 - let code = cons Name.code 323 323 - let col = void_cons Name.col 324 324 - let colgroup = cons Name.colgroup 325 325 - let command = cons Name.command 326 326 - let datalist = cons Name.datalist 327 327 - let dd = cons Name.dd 328 328 - let del = cons Name.del 329 329 - let details = cons Name.details 330 330 - let dfn = cons Name.dfn 331 331 - let div = cons Name.div 332 332 - let dl = cons Name.dl 333 333 - let dt = cons Name.dt 334 334 - let em = cons Name.em 335 335 - let embed = void_cons Name.embed 336 336 - let fieldset = cons Name.fieldset 337 337 - let figcaption = cons Name.figcaption 338 338 - let figure = cons Name.figure 339 339 - let footer = cons Name.footer 340 340 - let form = cons Name.form 341 341 - let h1 = cons Name.h1 342 342 - let h2 = cons Name.h2 343 343 - let h3 = cons Name.h3 344 344 - let h4 = cons Name.h4 345 345 - let h5 = cons Name.h5 346 346 - let h6 = cons Name.h6 347 347 - let head = cons Name.head 348 348 - let header = cons Name.header 349 349 - let hgroup = cons Name.hgroup 350 350 - let hr = void_cons Name.hr 351 351 - let html = cons Name.html 352 352 - let i = cons Name.i 353 353 - let iframe = cons Name.iframe 354 354 - let img = void_cons Name.img 355 355 - let input = void_cons Name.input 356 356 - let ins = cons Name.ins 357 357 - let kbd = cons Name.kbd 358 358 - let keygen = cons Name.keygen 359 359 - let label = cons Name.label 360 360 - let legend = cons Name.legend 361 361 - let li = cons Name.li 362 362 - let link = void_cons Name.link 363 363 - let map = cons Name.map 364 364 - let mark = cons Name.mark 365 365 - let menu = cons Name.menu 366 366 - let meta = void_cons Name.meta 367 367 - let meter = cons Name.meter 368 368 - let nav = cons Name.nav 369 369 - let noscript = cons Name.noscript 370 370 - let object' = cons Name.object' 371 371 - let ol = cons Name.ol 372 372 - let optgroup = cons Name.optgroup 373 373 - let option = cons Name.option 374 374 - let output = cons Name.output 375 375 - let p = cons Name.p 376 376 - let param = void_cons Name.param 377 377 - let pre = cons Name.pre 378 378 - let progress = cons Name.progress 379 379 - let q = cons Name.q 380 380 - let rp = cons Name.rp 381 381 - let rt = cons Name.rt 382 382 - let ruby = cons Name.ruby 383 383 - let s = cons Name.s 384 384 - let samp = cons Name.samp 385 385 - let script = cons Name.script 386 386 - let section = cons Name.section 387 387 - let select = cons Name.select 388 388 - let small = cons Name.small 389 389 - let source = void_cons Name.source 390 390 - let span = cons Name.span 391 391 - let strong = cons Name.strong 392 392 - let style = cons Name.style 393 393 - let sub = cons Name.sub 394 394 - let summary = cons Name.summary 395 395 - let sup = cons Name.sup 396 396 - let table = cons Name.table 397 397 - let tbody = cons Name.tbody 398 398 - let td = cons Name.td 399 399 - let textarea = cons Name.textarea 400 400 - let tfoot = cons Name.tfoot 401 401 - let th = cons Name.th 402 402 - let thead = cons Name.thead 403 403 - let time = cons Name.time 404 404 - let title = cons Name.title 405 405 - let tr = cons Name.tr 406 406 - let track = void_cons Name.track 407 407 - let u = cons Name.u 408 408 - let ul = cons Name.ul 409 409 - let var = cons Name.var 410 410 - let video = cons Name.video 411 411 - let wbr = void_cons Name.wbr

-432

forks/lwd/lib/brr-lwd/elwd.mli

reviewed

··· 1 1 - open Brr 2 2 - open El 3 3 - 4 4 - type t = El.t 5 5 - 6 6 - type 'a col = [ 7 7 - | `P of 'a 8 8 - (** Pure element *) 9 9 - | `R of 'a Lwd.t 10 10 - (** Reactive element *) 11 11 - | `S of 'a Lwd_seq.t Lwd.t 12 12 - (** Reactive sequence of elements *) 13 13 - ] list 14 14 - (** Describing collections of elements *) 15 15 - 16 16 - type handler (* An event handler *) 17 17 - val handler : ?opts:Ev.listen_opts -> 'a Ev.type' -> ('a Ev.t -> unit) -> handler 18 18 - 19 19 - val v : ?d:document -> ?at:At.t col -> ?ev:handler col -> tag_name -> t col -> t Lwd.t 20 20 - (** [v ?d ?at name cs] is an element [name] with attribute [at] 21 21 - (defaults to [[]]) and children [cs]. If [at] specifies an 22 22 - attribute more thanonce, the last one takes over with the 23 23 - exception of {!At.class'} whose occurences accumulate to define 24 24 - the final value. [d] is the document on which the element is 25 25 - defined it defaults {!Brr.G.document}. *) 26 26 - 27 27 - (** {1:els Element constructors} *) 28 28 - 29 29 - type cons = ?d:document -> ?at:At.t col -> ?ev:handler col -> t col -> t Lwd.t 30 30 - (** The type for element constructors. This is simply {!v} with a 31 31 - pre-applied element name. *) 32 32 - 33 33 - type void_cons = ?d:document -> ?at:At.t col -> ?ev:handler col -> unit -> t Lwd.t 34 34 - (** The type for void element constructors. This is simply {!v} 35 35 - with a pre-applied element name and without children. *) 36 36 - 37 37 - val a : cons 38 38 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/a}a} *) 39 39 - 40 40 - val abbr : cons 41 41 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/abbr}abbr} *) 42 42 - 43 43 - val address : cons 44 44 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/address} 45 45 - address} *) 46 46 - 47 47 - val area : void_cons 48 48 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/area} 49 49 - area} *) 50 50 - 51 51 - val article : cons 52 52 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/article} 53 53 - article} *) 54 54 - 55 55 - val aside : cons 56 56 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/aside} 57 57 - aside} *) 58 58 - 59 59 - val audio : cons 60 60 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/audio} 61 61 - audio} *) 62 62 - 63 63 - val b : cons 64 64 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/b}b} *) 65 65 - 66 66 - val base : void_cons 67 67 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/base} 68 68 - base} *) 69 69 - 70 70 - val bdi : cons 71 71 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/bdi} 72 72 - bdi} *) 73 73 - 74 74 - val bdo : cons 75 75 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/bdo} 76 76 - bdo} *) 77 77 - 78 78 - val blockquote : cons 79 79 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/blockquote} 80 80 - blockquote} *) 81 81 - 82 82 - val body : cons 83 83 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/body} 84 84 - body} *) 85 85 - 86 86 - val br : void_cons 87 87 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/br}br} *) 88 88 - 89 89 - val button : cons 90 90 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/button} 91 91 - button} *) 92 92 - 93 93 - val canvas : cons 94 94 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/canvas} 95 95 - canvas} *) 96 96 - 97 97 - val caption : cons 98 98 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/caption} 99 99 - caption} *) 100 100 - 101 101 - val cite : cons 102 102 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/cite} 103 103 - cite} *) 104 104 - 105 105 - val code : cons 106 106 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/code} 107 107 - code} *) 108 108 - 109 109 - val col : void_cons 110 110 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/col} 111 111 - col} *) 112 112 - 113 113 - val colgroup : cons 114 114 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/colgroup} 115 115 - colgroup} *) 116 116 - 117 117 - val command : cons 118 118 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/command} 119 119 - command} *) 120 120 - 121 121 - val datalist : cons 122 122 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/datalist} 123 123 - datalist} *) 124 124 - 125 125 - val dd : cons 126 126 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/dd}dd} *) 127 127 - 128 128 - val del : cons 129 129 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/del} 130 130 - del} *) 131 131 - 132 132 - val details : cons 133 133 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/details} 134 134 - details} *) 135 135 - 136 136 - val dfn : cons 137 137 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/dfn} 138 138 - dfn} *) 139 139 - 140 140 - val div : cons 141 141 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/div} 142 142 - div} *) 143 143 - 144 144 - val dl : cons 145 145 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/dl}dl} *) 146 146 - 147 147 - val dt : cons 148 148 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/dt}dt} *) 149 149 - 150 150 - val em : cons 151 151 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/em}em} *) 152 152 - 153 153 - val embed : void_cons 154 154 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/embed} 155 155 - embed} *) 156 156 - 157 157 - val fieldset : cons 158 158 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/fieldset} 159 159 - fieldset} *) 160 160 - 161 161 - val figcaption : cons 162 162 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/figcaption} 163 163 - figcaption} *) 164 164 - 165 165 - val figure : cons 166 166 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/figure} 167 167 - figure} *) 168 168 - 169 169 - val footer : cons 170 170 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/footer} 171 171 - footer} *) 172 172 - 173 173 - val form : cons 174 174 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/form} 175 175 - form} *) 176 176 - 177 177 - val h1 : cons 178 178 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/h1}h1} *) 179 179 - 180 180 - val h2 : cons 181 181 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/h2}h2} *) 182 182 - 183 183 - val h3 : cons 184 184 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/h3}h3} *) 185 185 - 186 186 - val h4 : cons 187 187 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/h4}h4} *) 188 188 - 189 189 - val h5 : cons 190 190 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/h5}h5} *) 191 191 - 192 192 - val h6 : cons 193 193 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/h6}h6} *) 194 194 - 195 195 - val head : cons 196 196 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/head} 197 197 - head} *) 198 198 - 199 199 - val header : cons 200 200 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/header} 201 201 - header} *) 202 202 - 203 203 - val hgroup : cons 204 204 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/hgroup} 205 205 - hgroup} *) 206 206 - 207 207 - val hr : void_cons 208 208 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/hr}hr} *) 209 209 - 210 210 - val html : cons 211 211 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/html} 212 212 - html} *) 213 213 - 214 214 - val i : cons 215 215 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/i}i} *) 216 216 - 217 217 - val iframe : cons 218 218 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/iframe} 219 219 - iframe} *) 220 220 - 221 221 - val img : void_cons 222 222 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/img} 223 223 - img} *) 224 224 - 225 225 - val input : void_cons 226 226 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/input} 227 227 - input} *) 228 228 - 229 229 - val ins : cons 230 230 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/ins} 231 231 - ins} *) 232 232 - 233 233 - val kbd : cons 234 234 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/kbd} 235 235 - kbd} *) 236 236 - 237 237 - val keygen : cons 238 238 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/keygen} 239 239 - keygen} *) 240 240 - 241 241 - val label : cons 242 242 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/label} 243 243 - label} *) 244 244 - 245 245 - val legend : cons 246 246 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/legend} 247 247 - legend} *) 248 248 - 249 249 - val li : cons 250 250 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/li}li} *) 251 251 - 252 252 - val link : void_cons 253 253 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/link}link} *) 254 254 - 255 255 - val map : cons 256 256 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/map}map} *) 257 257 - 258 258 - val mark : cons 259 259 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/mark}mark} *) 260 260 - 261 261 - val menu : cons 262 262 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/menu}menu} *) 263 263 - 264 264 - val meta : void_cons 265 265 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/meta}meta} *) 266 266 - 267 267 - val meter : cons 268 268 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/meter} 269 269 - meter} *) 270 270 - 271 271 - val nav : cons 272 272 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/nav}nav} *) 273 273 - 274 274 - val noscript : cons 275 275 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/noscript} 276 276 - noscript} *) 277 277 - 278 278 - val object' : cons 279 279 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/object} 280 280 - object} *) 281 281 - 282 282 - val ol : cons 283 283 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/ol}ol} *) 284 284 - 285 285 - val optgroup : cons 286 286 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/optgroup} 287 287 - optgroup} *) 288 288 - 289 289 - val option : cons 290 290 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/option} 291 291 - option} *) 292 292 - 293 293 - val output : cons 294 294 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/output} 295 295 - output} *) 296 296 - 297 297 - val p : cons 298 298 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/p}p} *) 299 299 - 300 300 - val param : void_cons 301 301 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/param} 302 302 - param} *) 303 303 - 304 304 - val pre : cons 305 305 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/pre} 306 306 - pre} *) 307 307 - 308 308 - val progress : cons 309 309 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/progress} 310 310 - progress} *) 311 311 - 312 312 - val q : cons 313 313 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/q}q} *) 314 314 - 315 315 - val rp : cons 316 316 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/rp}rp} *) 317 317 - 318 318 - val rt : cons 319 319 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/rt}rt} *) 320 320 - 321 321 - val ruby : cons 322 322 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/ruby}ruby} *) 323 323 - 324 324 - val s : cons 325 325 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/s}s} *) 326 326 - 327 327 - val samp : cons 328 328 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/samp} 329 329 - samp} *) 330 330 - 331 331 - val script : cons 332 332 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/script} 333 333 - script} *) 334 334 - 335 335 - val section : cons 336 336 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/section} 337 337 - section} *) 338 338 - 339 339 - val select : cons 340 340 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/select} 341 341 - select} *) 342 342 - 343 343 - val small : cons 344 344 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/small} 345 345 - small} *) 346 346 - 347 347 - val source : void_cons 348 348 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/source} 349 349 - source} *) 350 350 - 351 351 - val span : cons 352 352 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/span} 353 353 - span} *) 354 354 - 355 355 - val strong : cons 356 356 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/strong} 357 357 - strong} *) 358 358 - 359 359 - val style : cons 360 360 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/style} 361 361 - style} *) 362 362 - 363 363 - val sub : cons 364 364 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/sub} 365 365 - sub} *) 366 366 - 367 367 - val summary : cons 368 368 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/summary} 369 369 - summary} *) 370 370 - 371 371 - val sup : cons 372 372 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/sup} 373 373 - sup} *) 374 374 - 375 375 - val table : cons 376 376 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/table} 377 377 - table} *) 378 378 - 379 379 - val tbody : cons 380 380 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/tbody} 381 381 - tbody} *) 382 382 - 383 383 - val td : cons 384 384 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/td}td} *) 385 385 - 386 386 - val textarea : cons 387 387 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/textarea} 388 388 - textarea} *) 389 389 - 390 390 - val tfoot : cons 391 391 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/tfoot} 392 392 - tfoot} *) 393 393 - 394 394 - val th : cons 395 395 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/th}th} *) 396 396 - 397 397 - val thead : cons 398 398 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/thead} 399 399 - thead} *) 400 400 - 401 401 - val time : cons 402 402 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/time} 403 403 - time} *) 404 404 - 405 405 - val title : cons 406 406 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/title} 407 407 - title} *) 408 408 - 409 409 - val tr : cons 410 410 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/tr}tr} *) 411 411 - 412 412 - val track : void_cons 413 413 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/track} 414 414 - track} *) 415 415 - 416 416 - val u : cons 417 417 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/u}u} *) 418 418 - 419 419 - val ul : cons 420 420 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/ul}ul} *) 421 421 - 422 422 - val var : cons 423 423 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/var} 424 424 - var} *) 425 425 - 426 426 - val video : cons 427 427 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/video} 428 428 - video} *) 429 429 - 430 430 - val wbr : void_cons 431 431 - (** {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/wbr} 432 432 - wbr} *)

-21

forks/lwd/lib/lwd/dune

reviewed

··· 1 1 - (library 2 2 - (name lwd) 3 3 - (public_name lwd) 4 4 - (modules lwd lwd_seq lwd_table lwd_infix lwd_utils) 5 5 - (libraries seq) 6 6 - (inline_tests 7 7 - (backend qtest.lib) 8 8 - (executable 9 9 - (flags 10 10 - (-w -33)))) 11 11 - (wrapped false) 12 12 - (preprocess 13 13 - (per_module 14 14 - ((action 15 15 - (run %{dep:pp.exe} %{input-file})) 16 16 - lwd_infix 17 17 - lwd_seq)))) 18 18 - 19 19 - (executable 20 20 - (name pp) 21 21 - (modules pp))

-719

forks/lwd/lib/lwd/lwd.ml

reviewed

··· 1 1 - (** Create-only version of [Obj.t] *) 2 2 - module Any : sig 3 3 - type t 4 4 - val any : 'a -> t 5 5 - end = struct 6 6 - type t = Obj.t 7 7 - let any = Obj.repr 8 8 - end 9 9 - 10 10 - type 'a eval = 11 11 - | Eval_none 12 12 - | Eval_progress 13 13 - | Eval_some of 'a 14 14 - 15 15 - type 'a t_ = 16 16 - | Pure of 'a 17 17 - | Operator : { 18 18 - mutable value : 'a eval; (* cached value *) 19 19 - mutable trace : trace; (* list of parents this can invalidate *) 20 20 - mutable trace_idx : trace_idx; (* list of direct children that can invalidate this *) 21 21 - desc: 'a desc; 22 22 - } -> 'a t_ 23 23 - | Root : { 24 24 - mutable value : 'a eval; (* cached value *) 25 25 - mutable trace_idx : trace_idx; (* list of direct children that can invalidate this *) 26 26 - mutable on_invalidate : 'a -> unit; 27 27 - mutable acquired : bool; 28 28 - child : 'a t_; 29 29 - } -> 'a t_ 30 30 - 31 31 - and _ desc = 32 32 - | Map : 'a t_ * ('a -> 'b) -> 'b desc 33 33 - | Map2 : 'a t_ * 'b t_ * ('a -> 'b -> 'c) -> 'c desc 34 34 - | Pair : 'a t_ * 'b t_ -> ('a * 'b) desc 35 35 - | App : ('a -> 'b) t_ * 'a t_ -> 'b desc 36 36 - | Join : { child : 'a t_ t_; mutable intermediate : 'a t_ option } -> 'a desc 37 37 - | Var : { mutable binding : 'a } -> 'a desc 38 38 - | Prim : { acquire : 'a t -> 'a; 39 39 - release : 'a t -> 'a -> unit } -> 'a desc 40 40 - | Fix : { doc : 'a t_; wrt : _ t_ } -> 'a desc 41 41 - 42 42 - (* a set of (active) parents for a ['a t], used during invalidation *) 43 43 - and trace = 44 44 - | T0 45 45 - | T1 : _ t_ -> trace 46 46 - | T2 : _ t_ * _ t_ -> trace 47 47 - | T3 : _ t_ * _ t_ * _ t_ -> trace 48 48 - | T4 : _ t_ * _ t_ * _ t_ * _ t_ -> trace 49 49 - | Tn : { mutable active : int; mutable count : int; 50 50 - mutable entries : Any.t t_ array } -> trace 51 51 - 52 52 - (* a set of direct children for a composite document *) 53 53 - and trace_idx = 54 54 - | I0 55 55 - | I1 : { mutable idx : int ; 56 56 - obj : 'a t_; 57 57 - mutable next : trace_idx } -> trace_idx 58 58 - 59 59 - (* The type system cannot see that t is covariant in its parameter. 60 60 - Use the Force to convince it. *) 61 61 - and +'a t 62 62 - external inj : 'a t_ -> 'a t = "%identity" 63 63 - external prj : 'a t -> 'a t_ = "%identity" 64 64 - external prj2 : 'a t t -> 'a t_ t_ = "%identity" 65 65 - 66 66 - (* Basic combinators *) 67 67 - let return x = inj (Pure x) 68 68 - let pure x = inj (Pure x) 69 69 - 70 70 - let is_pure x = match prj x with 71 71 - | Pure x -> Some x 72 72 - | _ -> None 73 73 - 74 74 - let dummy = Pure (Any.any ()) 75 75 - 76 76 - let operator desc = 77 77 - Operator { value = Eval_none; trace = T0; desc; trace_idx = I0 } 78 78 - 79 79 - let map x ~f = inj ( 80 80 - match prj x with 81 81 - | Pure vx -> Pure (f vx) 82 82 - | x -> operator (Map (x, f)) 83 83 - ) 84 84 - 85 85 - let map2 x y ~f = inj ( 86 86 - match prj x, prj y with 87 87 - | Pure vx, Pure vy -> Pure (f vx vy) 88 88 - | x, y -> operator (Map2 (x, y, f)) 89 89 - ) 90 90 - 91 91 - 92 92 - let pair x y = inj ( 93 93 - match prj x, prj y with 94 94 - | Pure vx, Pure vy -> Pure (vx, vy) 95 95 - | x, y -> operator (Pair (x, y)) 96 96 - ) 97 97 - 98 98 - let app f x = inj ( 99 99 - match prj f, prj x with 100 100 - | Pure vf, Pure vx -> Pure (vf vx) 101 101 - | f, x -> operator (App (f, x)) 102 102 - ) 103 103 - 104 104 - let join child = inj ( 105 105 - match prj2 child with 106 106 - | Pure v -> v 107 107 - | child -> operator (Join { child; intermediate = None }) 108 108 - ) 109 109 - 110 110 - let bind x ~f = join (map ~f x) 111 111 - 112 112 - (* Management of trace indices *) 113 113 - 114 114 - let addr oc obj = 115 115 - Printf.fprintf oc "0x%08x" (Obj.magic obj : int) 116 116 - 117 117 - external t_equal : _ t_ -> _ t_ -> bool = "%eq" 118 118 - external obj_t : 'a t_ -> Any.t t_ = "%identity" 119 119 - 120 120 - let rec dump_trace : type a. a t_ -> unit = 121 121 - fun obj -> match obj with 122 122 - | Pure _ -> Printf.eprintf "%a: Pure _\n%!" addr obj 123 123 - | Operator t -> 124 124 - Printf.eprintf "%a: Operator _ -> %a\n%!" addr obj dump_trace_aux t.trace; 125 125 - begin match t.trace with 126 126 - | T0 -> () 127 127 - | T1 a -> dump_trace a 128 128 - | T2 (a,b) -> dump_trace a; dump_trace b 129 129 - | T3 (a,b,c) -> dump_trace a; dump_trace b; dump_trace c 130 130 - | T4 (a,b,c,d) -> dump_trace a; dump_trace b; dump_trace c; dump_trace d 131 131 - | Tn t -> Array.iter dump_trace t.entries 132 132 - end 133 133 - | Root _ -> Printf.eprintf "%a: Root _\n%!" addr obj 134 134 - 135 135 - and dump_trace_aux oc = function 136 136 - | T0 -> Printf.fprintf oc "T0" 137 137 - | T1 a -> Printf.fprintf oc "T1 %a" addr a 138 138 - | T2 (a,b) -> 139 139 - Printf.fprintf oc "T2 (%a, %a)" addr a addr b 140 140 - | T3 (a,b,c) -> 141 141 - Printf.fprintf oc "T3 (%a, %a, %a)" addr a addr b addr c 142 142 - | T4 (a,b,c,d) -> 143 143 - Printf.fprintf oc "T4 (%a, %a, %a, %a)" addr a addr b addr c addr d 144 144 - | Tn t -> 145 145 - Printf.fprintf oc "Tn {active = %d; count = %d; entries = " 146 146 - t.active t.count; 147 147 - Array.iter (Printf.fprintf oc "(%a)" addr) t.entries; 148 148 - Printf.fprintf oc "}" 149 149 - 150 150 - let dump_trace x = dump_trace (obj_t (prj x)) 151 151 - 152 152 - let add_idx obj idx = function 153 153 - | Pure _ -> assert false 154 154 - | Root t' -> t'.trace_idx <- I1 { idx; obj; next = t'.trace_idx } 155 155 - | Operator t' -> t'.trace_idx <- I1 { idx; obj; next = t'.trace_idx } 156 156 - 157 157 - let rec rem_idx_rec obj = function 158 158 - | I0 -> assert false 159 159 - | I1 t as self -> 160 160 - if t_equal t.obj obj 161 161 - then (t.idx, t.next) 162 162 - else ( 163 163 - let idx, result = rem_idx_rec obj t.next in 164 164 - t.next <- result; 165 165 - (idx, self) 166 166 - ) 167 167 - 168 168 - (* remove [obj] from the lwd's trace. *) 169 169 - let rem_idx obj = function 170 170 - | Pure _ -> assert false 171 171 - | Root t' -> 172 172 - let idx, trace_idx = rem_idx_rec obj t'.trace_idx in 173 173 - t'.trace_idx <- trace_idx; idx 174 174 - | Operator t' -> 175 175 - let idx, trace_idx = rem_idx_rec obj t'.trace_idx in 176 176 - t'.trace_idx <- trace_idx; idx 177 177 - 178 178 - (* move [obj] from old index to new index. *) 179 179 - let rec mov_idx_rec obj oldidx newidx = function 180 180 - | I0 -> assert false 181 181 - | I1 t -> 182 182 - if t.idx = oldidx && t_equal t.obj obj 183 183 - then t.idx <- newidx 184 184 - else mov_idx_rec obj oldidx newidx t.next 185 185 - 186 186 - let mov_idx obj oldidx newidx = function 187 187 - | Pure _ -> assert false 188 188 - | Root t' -> mov_idx_rec obj oldidx newidx t'.trace_idx 189 189 - | Operator t' -> mov_idx_rec obj oldidx newidx t'.trace_idx 190 190 - 191 191 - let rec get_idx_rec obj = function 192 192 - | I0 -> assert false 193 193 - | I1 t -> 194 194 - if t_equal t.obj obj 195 195 - then t.idx 196 196 - else get_idx_rec obj t.next 197 197 - 198 198 - (* find index of [obj] in the given lwd *) 199 199 - let get_idx obj = function 200 200 - | Pure _ -> assert false 201 201 - | Root t' -> get_idx_rec obj t'.trace_idx 202 202 - | Operator t' -> get_idx_rec obj t'.trace_idx 203 203 - 204 204 - type status = 205 205 - | Neutral 206 206 - | Safe 207 207 - | Unsafe 208 208 - 209 209 - type sensitivity = 210 210 - | Strong 211 211 - | Fragile 212 212 - 213 213 - (* Propagating invalidation recursively. 214 214 - Each document is invalidated at most once, 215 215 - and only if it has [t.value = Some _]. *) 216 216 - let rec invalidate_node : type a . status ref -> sensitivity -> a t_ -> unit = 217 217 - fun status sensitivity node -> 218 218 - match node, sensitivity with 219 219 - | Pure _, _ -> assert false 220 220 - | Root ({value; _} as t), _ -> 221 221 - t.value <- Eval_none; 222 222 - begin match value with 223 223 - | Eval_none -> () 224 224 - | Eval_progress -> 225 225 - status := Unsafe 226 226 - | Eval_some x -> 227 227 - begin match sensitivity with 228 228 - | Strong -> () 229 229 - | Fragile -> status := Unsafe 230 230 - end; 231 231 - t.on_invalidate x (* user callback that {i observes} this root. *) 232 232 - end 233 233 - | Operator {value = Eval_none; _}, Fragile -> 234 234 - begin match !status with 235 235 - | Unsafe | Safe -> () 236 236 - | _ -> status := Safe 237 237 - end 238 238 - | Operator {value = Eval_none; _}, _ -> () 239 239 - | Operator {desc = Fix {wrt = Operator {value = Eval_none; _}; _}; _}, Fragile -> 240 240 - begin match !status with 241 241 - | Safe | Unsafe -> () 242 242 - | Neutral -> status := Safe 243 243 - end 244 244 - | Operator {desc = Fix {wrt = Operator {value = Eval_some _; _}; _}; _}, Fragile -> 245 245 - () 246 246 - | Operator t, _ -> 247 247 - let sensitivity = 248 248 - match t.value with Eval_progress -> Fragile | _ -> sensitivity 249 249 - in 250 250 - t.value <- Eval_none; 251 251 - (* invalidate parents recursively *) 252 252 - invalidate_trace status sensitivity t.trace 253 253 - 254 254 - (* invalidate recursively documents in the given trace *) 255 255 - and invalidate_trace status sensitivity = function 256 256 - | T0 -> () 257 257 - | T1 x -> invalidate_node status sensitivity x 258 258 - | T2 (x, y) -> 259 259 - invalidate_node status sensitivity x; 260 260 - invalidate_node status sensitivity y 261 261 - | T3 (x, y, z) -> 262 262 - invalidate_node status sensitivity x; 263 263 - invalidate_node status sensitivity y; 264 264 - invalidate_node status sensitivity z 265 265 - | T4 (x, y, z, w) -> 266 266 - invalidate_node status sensitivity x; 267 267 - invalidate_node status sensitivity y; 268 268 - invalidate_node status sensitivity z; 269 269 - invalidate_node status sensitivity w 270 270 - | Tn t -> 271 271 - let active = t.active in 272 272 - t.active <- 0; 273 273 - for i = 0 to active - 1 do 274 274 - invalidate_node status sensitivity t.entries.(i) 275 275 - done 276 276 - 277 277 - let default_unsafe_mutation_logger () = 278 278 - let callstack = Printexc.get_callstack 20 in 279 279 - Printf.fprintf stderr 280 280 - "Lwd: unsafe mutation (variable invalidated during evaluation) at\n%a" 281 281 - Printexc.print_raw_backtrace callstack 282 282 - 283 283 - let unsafe_mutation_logger = ref default_unsafe_mutation_logger 284 284 - 285 285 - let do_invalidate sensitivity node = 286 286 - let status = ref Neutral in 287 287 - invalidate_node status sensitivity node; 288 288 - let unsafe = 289 289 - match !status with 290 290 - | Neutral | Safe -> false 291 291 - | Unsafe -> true 292 292 - in 293 293 - if unsafe then !unsafe_mutation_logger () 294 294 - 295 295 - (* Variables *) 296 296 - type 'a var = 'a t_ 297 297 - let var x = operator (Var {binding = x}) 298 298 - let get x = inj x 299 299 - 300 300 - let set (vx:_ var) x : unit = 301 301 - match vx with 302 302 - | Operator ({desc = Var v; _}) -> 303 303 - (* set the variable, and invalidate all observers *) 304 304 - v.binding <- x; 305 305 - do_invalidate Strong vx 306 306 - | _ -> assert false 307 307 - 308 308 - let peek = function 309 309 - | Operator ({desc = Var v; _}) -> v.binding 310 310 - | _ -> assert false 311 311 - 312 312 - let update f v = set v (f (peek v)) 313 313 - 314 314 - let may_update f v = 315 315 - match f (peek v) with 316 316 - | None -> () 317 317 - | Some x -> set v x 318 318 - 319 319 - (* Primitives *) 320 320 - type 'a prim = 'a t 321 321 - let prim ~acquire ~release = 322 322 - inj (operator (Prim { acquire; release })) 323 323 - let get_prim x = x 324 324 - 325 325 - let invalidate x = match prj x with 326 326 - | Operator {desc = Prim p; value; _} as t -> 327 327 - (* the value is invalidated, be sure to invalidate all parents as well *) 328 328 - begin match value with 329 329 - | Eval_none -> () 330 330 - | Eval_progress -> do_invalidate Fragile t; 331 331 - | Eval_some v -> 332 332 - do_invalidate Strong t; 333 333 - p.release x v 334 334 - end 335 335 - | _ -> assert false 336 336 - 337 337 - (* Fix point *) 338 338 - 339 339 - let fix doc ~wrt = match prj wrt with 340 340 - | Root _ -> assert false 341 341 - | Pure _ -> doc 342 342 - | Operator _ as wrt -> inj (operator (Fix {doc = prj doc; wrt})) 343 343 - 344 344 - type release_list = 345 345 - | Release_done 346 346 - | Release_more : 347 347 - { origin : 'a t_; element : 'b t_; next : release_list } -> release_list 348 348 - 349 349 - type release_queue = release_list ref 350 350 - let make_release_queue () = ref Release_done 351 351 - 352 352 - type release_failure = exn * Printexc.raw_backtrace 353 353 - 354 354 - (* [sub_release [] origin self] is called when [origin] is released, 355 355 - where [origin] is reachable from [self]'s trace. 356 356 - We're going to remove [origin] from that trace as [origin] is now dead. 357 357 - 358 358 - [sub_release] cannot raise. 359 359 - If a primitive raises, the exception is caught and a warning is emitted. *) 360 360 - let rec sub_release 361 361 - : type a b . release_failure list -> a t_ -> b t_ -> release_failure list 362 362 - = fun failures origin -> function 363 363 - | Root _ -> assert false 364 364 - | Pure _ -> failures 365 365 - | Operator t as self -> 366 366 - (* compute [t.trace \ {origin}] *) 367 367 - let trace = match t.trace with 368 368 - | T0 -> assert false 369 369 - | T1 x -> assert (t_equal x origin); T0 370 370 - | T2 (x, y) -> 371 371 - if t_equal x origin then T1 y 372 372 - else if t_equal y origin then T1 x 373 373 - else assert false 374 374 - | T3 (x, y, z) -> 375 375 - if t_equal x origin then T2 (y, z) 376 376 - else if t_equal y origin then T2 (x, z) 377 377 - else if t_equal z origin then T2 (x, y) 378 378 - else assert false 379 379 - | T4 (x, y, z, w) -> 380 380 - if t_equal x origin then T3 (y, z, w) 381 381 - else if t_equal y origin then T3 (x, z, w) 382 382 - else if t_equal z origin then T3 (x, y, w) 383 383 - else if t_equal w origin then T3 (x, y, z) 384 384 - else assert false 385 385 - | Tn tn as trace -> 386 386 - let revidx = rem_idx self origin in 387 387 - assert (t_equal tn.entries.(revidx) origin); 388 388 - let count = tn.count - 1 in 389 389 - tn.count <- count; 390 390 - if revidx < count then ( 391 391 - let obj = tn.entries.(count) in 392 392 - tn.entries.(revidx) <- obj; 393 393 - tn.entries.(count) <- dummy; 394 394 - mov_idx self count revidx obj 395 395 - ) else 396 396 - tn.entries.(revidx) <- dummy; 397 397 - if tn.active > count then tn.active <- count; 398 398 - if count = 4 then ( 399 399 - (* downgrade to [T4] to save space *) 400 400 - let a = tn.entries.(0) and b = tn.entries.(1) in 401 401 - let c = tn.entries.(2) and d = tn.entries.(3) in 402 402 - ignore (rem_idx self a : int); 403 403 - ignore (rem_idx self b : int); 404 404 - ignore (rem_idx self c : int); 405 405 - ignore (rem_idx self d : int); 406 406 - T4 (a, b, c, d) 407 407 - ) else ( 408 408 - let len = Array.length tn.entries in 409 409 - if count <= len lsr 2 then 410 410 - Tn { active = tn.active; count = tn.count; 411 411 - entries = Array.sub tn.entries 0 (len lsr 1) } 412 412 - else 413 413 - trace 414 414 - ) 415 415 - in 416 416 - t.trace <- trace; 417 417 - match trace with 418 418 - | T0 -> 419 419 - (* [self] is not active anymore, since it's not reachable 420 420 - from any root. We can release its cached value and 421 421 - recursively release its subtree. *) 422 422 - let value = t.value in 423 423 - t.value <- Eval_progress; 424 424 - begin match t.desc with 425 425 - | Map (x, _) -> sub_release failures self x 426 426 - | Map2 (x, y, _) -> 427 427 - sub_release (sub_release failures self x) self y 428 428 - | Pair (x, y) -> 429 429 - sub_release (sub_release failures self x) self y 430 430 - | App (x, y) -> 431 431 - sub_release (sub_release failures self x) self y 432 432 - | Join ({ child; intermediate } as t) -> 433 433 - let failures = sub_release failures self child in 434 434 - begin match intermediate with 435 435 - | None -> failures 436 436 - | Some child' -> 437 437 - t.intermediate <- None; 438 438 - sub_release failures self child' 439 439 - end 440 440 - | Var _ -> failures 441 441 - | Fix {doc; wrt} -> 442 442 - sub_release (sub_release failures self wrt) self doc 443 443 - | Prim t -> 444 444 - begin match value with 445 445 - | Eval_none | Eval_progress -> failures 446 446 - | Eval_some x -> 447 447 - begin match t.release (inj self) x with 448 448 - | () -> failures 449 449 - | exception exn -> 450 450 - let bt = Printexc.get_raw_backtrace () in 451 451 - (exn, bt) :: failures 452 452 - end 453 453 - end 454 454 - end 455 455 - | _ -> failures 456 456 - 457 457 - (* [sub_acquire] cannot raise *) 458 458 - let rec sub_acquire : type a b . a t_ -> b t_ -> unit = fun origin -> 459 459 - function 460 460 - | Root _ -> assert false 461 461 - | Pure _ -> () 462 462 - | Operator t as self -> 463 463 - (* [acquire] is true if this is the first time this operator 464 464 - is used, in which case we need to acquire its children *) 465 465 - let acquire = match t.trace with T0 -> true | _ -> false in 466 466 - let trace = match t.trace with 467 467 - | T0 -> T1 origin 468 468 - | T1 x -> T2 (origin, x) 469 469 - | T2 (x, y) -> T3 (origin, x, y) 470 470 - | T3 (x, y, z) -> T4 (origin, x, y, z) 471 471 - | T4 (x, y, z, w) -> 472 472 - let obj_origin = obj_t origin in 473 473 - let entries = 474 474 - [| obj_t x; obj_t y; obj_t z; obj_t w; obj_origin; dummy; dummy; dummy |] 475 475 - in 476 476 - for i = 0 to 4 do add_idx self i entries.(i) done; 477 477 - Tn { active = 5; count = 5; entries } 478 478 - | Tn tn as trace -> 479 479 - let index = tn.count in 480 480 - let entries, trace = 481 481 - (* possibly resize array [entries] *) 482 482 - if index < Array.length tn.entries then ( 483 483 - tn.count <- tn.count + 1; 484 484 - (tn.entries, trace) 485 485 - ) else ( 486 486 - let entries = Array.make (index * 2) dummy in 487 487 - Array.blit tn.entries 0 entries 0 index; 488 488 - (entries, Tn { active = tn.active; count = index + 1; entries }) 489 489 - ) 490 490 - in 491 491 - let obj_origin = obj_t origin in 492 492 - entries.(index) <- obj_origin; 493 493 - add_idx self index obj_origin; 494 494 - trace 495 495 - in 496 496 - t.trace <- trace; 497 497 - if acquire then ( 498 498 - (* acquire immediate children, and so on recursively *) 499 499 - match t.desc with 500 500 - | Map (x, _) -> sub_acquire self x 501 501 - | Map2 (x, y, _) -> 502 502 - sub_acquire self x; 503 503 - sub_acquire self y 504 504 - | Pair (x, y) -> 505 505 - sub_acquire self x; 506 506 - sub_acquire self y 507 507 - | App (x, y) -> 508 508 - sub_acquire self x; 509 509 - sub_acquire self y 510 510 - | Fix {doc; wrt} -> 511 511 - sub_acquire self doc; 512 512 - sub_acquire self wrt 513 513 - | Join { child; intermediate } -> 514 514 - sub_acquire self child; 515 515 - begin match intermediate with 516 516 - | None -> () 517 517 - | Some _ -> 518 518 - assert false (* this can't initialized already, first-time acquire *) 519 519 - end 520 520 - | Var _ -> () 521 521 - | Prim _ -> () 522 522 - ) 523 523 - 524 524 - (* make sure that [origin] is in [self.trace], passed as last arg. *) 525 525 - let activate_tracing self origin = function 526 526 - | Tn tn -> 527 527 - let idx = get_idx self origin in (* index of [self] in [origin.trace_idx] *) 528 528 - let active = tn.active in 529 529 - (* [idx < active] means [self] is already traced by [origin]. 530 530 - We only have to add [self] to the entries if [idx >= active]. *) 531 531 - if idx >= active then ( 532 532 - tn.active <- active + 1; 533 533 - ); 534 534 - if idx > active then ( 535 535 - (* swap with last entry in [tn.entries] *) 536 536 - let old = tn.entries.(active) in 537 537 - tn.entries.(idx) <- old; 538 538 - tn.entries.(active) <- obj_t origin; 539 539 - mov_idx self active idx old; 540 540 - mov_idx self idx active origin 541 541 - ) 542 542 - | _ -> () 543 543 - 544 544 - let sub_is_damaged = function 545 545 - | Root _ -> assert false 546 546 - | Pure _ -> false 547 547 - | Operator {value; _} -> 548 548 - match value with 549 549 - | Eval_none -> true 550 550 - | Eval_some _ -> false 551 551 - | Eval_progress -> assert false 552 552 - 553 553 - (* [sub_sample origin self] computes a value for [self]. 554 554 - 555 555 - [sub_sample] raise if any user-provided computation raises. 556 556 - Graph will be left in a coherent state but exception will be propagated 557 557 - to the observer. *) 558 558 - let sub_sample queue = 559 559 - let rec aux : type a b . a t_ -> b t_ -> b = fun origin -> 560 560 - function 561 561 - | Root _ -> assert false 562 562 - | Pure x -> x 563 563 - | Operator t as self -> 564 564 - (* try to use cached value, if present *) 565 565 - match t.value with 566 566 - | Eval_some value -> 567 567 - activate_tracing self origin t.trace; 568 568 - value 569 569 - | _ -> 570 570 - t.value <- Eval_progress; 571 571 - let result : b = match t.desc with 572 572 - | Map (x, f) -> f (aux self x) 573 573 - | Map2 (x, y, f) -> f (aux self x) (aux self y) 574 574 - | Pair (x, y) -> (aux self x, aux self y) 575 575 - | App (f, x) -> (aux self f) (aux self x) 576 576 - | Fix {doc; wrt} -> 577 577 - let _ = aux self wrt in 578 578 - let result = aux self doc in 579 579 - if sub_is_damaged wrt then 580 580 - aux origin self 581 581 - else ( 582 582 - if sub_is_damaged doc then 583 583 - do_invalidate Fragile self; 584 584 - result 585 585 - ) 586 586 - | Join x -> 587 587 - let intermediate = 588 588 - (* We haven't touched any state yet, 589 589 - it is safe for [aux] to raise *) 590 590 - aux self x.child 591 591 - in 592 592 - begin match x.intermediate with 593 593 - | None -> 594 594 - x.intermediate <- Some intermediate; 595 595 - sub_acquire self intermediate; 596 596 - | Some x' when x' != intermediate -> 597 597 - queue := Release_more { 598 598 - origin = self; 599 599 - element = x'; 600 600 - next = !queue; 601 601 - }; 602 602 - x.intermediate <- Some intermediate; 603 603 - sub_acquire self intermediate; 604 604 - | Some _ -> () 605 605 - end; 606 606 - aux self intermediate 607 607 - | Var x -> x.binding 608 608 - | Prim t -> t.acquire (inj self) 609 609 - in 610 610 - begin match t.value with 611 611 - | Eval_progress -> t.value <- Eval_some result; 612 612 - | Eval_none | Eval_some _ -> () 613 613 - end; 614 614 - (* [self] just became active, so it may invalidate [origin] in case its 615 615 - value changes because of [t.desc], like if it's a variable and gets 616 616 - mutated, or if it's a primitive that gets invalidated. 617 617 - We need to put [origin] into [self.trace] in case it isn't there yet. *) 618 618 - activate_tracing self origin t.trace; 619 619 - result 620 620 - in 621 621 - aux 622 622 - 623 623 - type 'a root = 'a t 624 624 - 625 625 - let observe ?(on_invalidate=ignore) child : _ root = 626 626 - let root = Root { 627 627 - child = prj child; 628 628 - value = Eval_none; 629 629 - on_invalidate; 630 630 - trace_idx = I0; 631 631 - acquired = false; 632 632 - } in 633 633 - inj root 634 634 - 635 635 - exception Release_failure of exn option * release_failure list 636 636 - 637 637 - let raw_flush_release_queue queue = 638 638 - let rec aux failures = function 639 639 - | Release_done -> failures 640 640 - | Release_more t -> 641 641 - let failures = sub_release failures t.origin t.element in 642 642 - aux failures t.next 643 643 - in 644 644 - aux [] queue 645 645 - 646 646 - let flush_release_queue queue = 647 647 - let queue' = !queue in 648 648 - queue := Release_done; 649 649 - raw_flush_release_queue queue' 650 650 - 651 651 - let sample queue x = match prj x with 652 652 - | Pure _ | Operator _ -> assert false 653 653 - | Root t as self -> 654 654 - match t.value with 655 655 - | Eval_some value -> value 656 656 - | _ -> 657 657 - (* no cached value, compute it now *) 658 658 - if not t.acquired then ( 659 659 - t.acquired <- true; 660 660 - sub_acquire self t.child; 661 661 - ); 662 662 - t.value <- Eval_progress; 663 663 - let value = sub_sample queue self t.child in 664 664 - begin match t.value with 665 665 - | Eval_progress -> t.value <- Eval_some value; (* cache value *) 666 666 - | Eval_none | Eval_some _ -> () 667 667 - end; 668 668 - value 669 669 - 670 670 - let is_damaged x = match prj x with 671 671 - | Pure _ | Operator _ -> assert false 672 672 - | Root {value = Eval_some _; _} -> false 673 673 - | Root {value = Eval_none | Eval_progress; _} -> true 674 674 - 675 675 - let release queue x = match prj x with 676 676 - | Pure _ | Operator _ -> assert false 677 677 - | Root t as self -> 678 678 - if t.acquired then ( 679 679 - (* release subtree, remove cached value *) 680 680 - t.value <- Eval_none; 681 681 - t.acquired <- false; 682 682 - queue := Release_more { origin = self; element = t.child; next = !queue } 683 683 - ) 684 684 - 685 685 - let set_on_invalidate x f = 686 686 - match prj x with 687 687 - | Pure _ | Operator _ -> assert false 688 688 - | Root t -> t.on_invalidate <- f 689 689 - 690 690 - let flush_or_fail main_exn queue = 691 691 - match flush_release_queue queue with 692 692 - | [] -> () 693 693 - | failures -> raise (Release_failure (main_exn, failures)) 694 694 - 695 695 - let quick_sample root = 696 696 - let queue = ref Release_done in 697 697 - match sample queue root with 698 698 - | result -> flush_or_fail None queue; result 699 699 - | exception exn -> flush_or_fail (Some exn) queue; raise exn 700 700 - 701 701 - let quick_release root = 702 702 - let queue = ref Release_done in 703 703 - release queue root; 704 704 - flush_or_fail None queue 705 705 - 706 706 - module Infix = struct 707 707 - let (>>=) x f = bind x ~f 708 708 - let (>|=) x f = map x ~f 709 709 - let (<*>) = app 710 710 - end 711 711 - 712 712 - (*$R 713 713 - let x = var 0 in 714 714 - let y = map ~f:succ (get x) in 715 715 - let o_y = Lwd.observe y in 716 716 - assert_equal 1 (quick_sample o_y); 717 717 - set x 10; 718 718 - assert_equal 11 (quick_sample o_y); 719 719 - *)

-152

forks/lwd/lib/lwd/lwd.mli

reviewed

··· 1 1 - type +'a t 2 2 - (** A dynamic document of type ['a]. Documents can be produced in several 3 3 - different ways: 4 4 - 5 5 - - operators, such as {!map}, {!bind}, {!app}, {!pair}, etc. 6 6 - combine several documents into one. The result is (lazily) 7 7 - updated whenever the sub-documents are. 8 8 - 9 9 - - variables {!var}, a mutable reference. 10 10 - - primitive documents {!prim}, providing custom leaves to trees of 11 11 - documents. 12 12 - *) 13 13 - 14 14 - val return : 'a -> 'a t 15 15 - (** The content document with the given value inside *) 16 16 - 17 17 - val pure : 'a -> 'a t 18 18 - (** Alias to {!return} *) 19 19 - 20 20 - val map : 'a t -> f:('a -> 'b) -> 'b t 21 21 - (** [map d ~f] is the document that has value [f x] whenever [d] has value [x] *) 22 22 - 23 23 - val map2 : 'a t -> 'b t -> f:('a -> 'b -> 'c) -> 'c t 24 24 - (** [map2 d1 d2 ~f] is the document that has value [f x1 x2] whenever 25 25 - [d1] has value [x1] and [d2] has value [x2] *) 26 26 - 27 27 - val join : 'a t t -> 'a t 28 28 - (** Monadic operator [join d] is the document pointed to by document [d]. 29 29 - This is powerful but potentially costly in case of recomputation. 30 30 - *) 31 31 - 32 32 - val bind : 'a t -> f:('a -> 'b t) -> 'b t 33 33 - (** Monadic bind, a mix of {!join} and {!map} *) 34 34 - 35 35 - val app : ('a -> 'b) t -> 'a t -> 'b t 36 36 - (** Applicative: [app df dx] is the document that has value [f x] 37 37 - whenever [df] has value [f] and [dx] has value [x] *) 38 38 - 39 39 - val pair : 'a t -> 'b t -> ('a * 'b) t 40 40 - (** [pair a b] is [map2 (fun x y->x,y) a b] *) 41 41 - 42 42 - val is_pure : 'a t -> 'a option 43 43 - (** [is_pure x] will return [Some v] if [x] was built with [pure v] or 44 44 - [return v]. 45 45 - 46 46 - Normal code should not rely on the "reactive-ness" of a value, but this is 47 47 - often useful for optimising reactive data structures. 48 48 - *) 49 49 - 50 50 - type 'a var 51 51 - (** The workhorse of Lwd: a mutable variable that also tracks dependencies. 52 52 - Every time {!set} is called, all documents that depend on this variable 53 53 - via {!map}, {!bind}, etc. will be at least partially invalidated 54 54 - and will be recomputed incrementally on demand. *) 55 55 - 56 56 - val var : 'a -> 'a var 57 57 - (** Create a new variable with the given initial value *) 58 58 - 59 59 - val get : 'a var -> 'a t 60 60 - (** A document that reflects the current content of a variable *) 61 61 - 62 62 - val set : 'a var -> 'a -> unit 63 63 - (** Change the variable's content, invalidating all documents depending 64 64 - on it. *) 65 65 - 66 66 - val peek : 'a var -> 'a 67 67 - (** Observe the current value of the variable, without any dependency 68 68 - tracking. *) 69 69 - 70 70 - val update : ('a -> 'a) -> 'a var -> unit 71 71 - (** Modify a variable based on its currently observed value. *) 72 72 - 73 73 - val may_update : ('a -> 'a option) -> 'a var -> unit 74 74 - (** Conditionnally modify a variable based on its currently observed value. *) 75 75 - 76 76 - type +'a prim 77 77 - (** A primitive document. It can correspond, for example, to 78 78 - a primitive UI element. 79 79 - 80 80 - A primitive is a resource with [acquire] and [release] functions 81 81 - to manage its lifecycle. *) 82 82 - 83 83 - val prim : acquire:('a prim -> 'a) -> release:('a prim -> 'a -> unit) -> 'a prim 84 84 - (** create a new primitive document. 85 85 - @param acquire is called when the document becomes observed (indirectly) 86 86 - via at least one {!root}. The resulting primitive is passed as an argument 87 87 - to support certain recursive use cases. 88 88 - @param release is called when the document is no longer observed. 89 89 - Internal resources can be freed. *) 90 90 - 91 91 - val get_prim : 'a prim -> 'a t 92 92 - val invalidate : 'a prim -> unit 93 93 - 94 94 - (** Some document might change variables during their evaluation. 95 95 - These are called "unstable" documents. 96 96 - 97 97 - Evaluating these might need many passes to eventually converge to a value. 98 98 - The `fix` operator tries to stabilize a sub-document by repeating 99 99 - evaluation until a stable condition is reached. 100 100 - *) 101 101 - val fix : 'a t -> wrt:_ t -> 'a t 102 102 - 103 103 - val default_unsafe_mutation_logger : unit -> unit 104 104 - val unsafe_mutation_logger : (unit -> unit) ref 105 105 - 106 106 - (** Releasing unused graphs *) 107 107 - type release_failure = exn * Printexc.raw_backtrace 108 108 - 109 109 - exception Release_failure of exn option * release_failure list 110 110 - 111 111 - type release_queue 112 112 - val make_release_queue : unit -> release_queue 113 113 - val flush_release_queue : release_queue -> release_failure list 114 114 - 115 115 - type +'a root 116 116 - (** A root of computation, whose value(s) over time we're interested in. *) 117 117 - 118 118 - val observe : ?on_invalidate:('a -> unit) -> 'a t -> 'a root 119 119 - (** [observe x] creates a root that contains document [x]. 120 120 - @param on_invalidate is called whenever the root is invalidated 121 121 - because the content of [x] has changed. This can be useful to 122 122 - perform side-effects such as re-rendering some UI. *) 123 123 - 124 124 - val set_on_invalidate : 'a root -> ('a -> unit) -> unit 125 125 - (** Change the callback for the root. 126 126 - See [observe] for more details. *) 127 127 - 128 128 - val sample : release_queue -> 'a root -> 'a 129 129 - (** Force the computation of the value for this root. 130 130 - The value is cached, so this is idempotent, until the next invalidation. *) 131 131 - 132 132 - val is_damaged : 'a root -> bool 133 133 - (** [is_damaged root] is true if the root doesn't have a valid value in 134 134 - cache. This can be the case if the value was never computed, or 135 135 - if it was computed and then invalidated. *) 136 136 - 137 137 - val release : release_queue -> 'a root -> unit 138 138 - (** Forget about this root and release sub-values no longer reachable from 139 139 - any root. *) 140 140 - 141 141 - val quick_sample : 'a root -> 'a 142 142 - 143 143 - val quick_release : 'a root -> unit 144 144 - 145 145 - module Infix : sig 146 146 - val (>|=) : 'a t -> ('a -> 'b) -> 'b t 147 147 - val (>>=) : 'a t -> ('a -> 'b t) -> 'b t 148 148 - val (<*>) : ('a -> 'b) t -> 'a t -> 'b t 149 149 - end 150 150 - 151 151 - (* For debug purposes *) 152 152 - val dump_trace : 'a t -> unit

-8

forks/lwd/lib/lwd/lwd_infix.ml

reviewed

··· 1 1 - (*BEGIN LETOP*) 2 2 - let (let$) : 'a Lwd.t -> ('a -> 'b) -> 'b Lwd.t = Lwd.Infix.(>|=) 3 3 - let (and$) : 'a Lwd.t -> 'b Lwd.t -> ('a * 'b) Lwd.t = Lwd.pair 4 4 - let (let$*) : 'a Lwd.t -> ('a -> 'b Lwd.t) -> 'b Lwd.t = Lwd.Infix.(>>=) 5 5 - (*END*) 6 6 - 7 7 - let ($=) : 'a Lwd.var -> 'a -> unit = Lwd.set 8 8 - let ($<-) : 'a Lwd_table.row -> 'a -> unit = Lwd_table.set

-16

forks/lwd/lib/lwd/lwd_infix.mli

reviewed

··· 1 1 - (*BEGIN LETOP*) 2 2 - val (let$) : 'a Lwd.t -> ('a -> 'b) -> 'b Lwd.t 3 3 - (** Alias to {!Lwd.map'} suitable for let-op bindings *) 4 4 - 5 5 - val (let$*) : 'a Lwd.t -> ('a -> 'b Lwd.t) -> 'b Lwd.t 6 6 - (** Alias to {!Lwd.bind} suitable for let-op bindings *) 7 7 - 8 8 - val (and$) : 'a Lwd.t -> 'b Lwd.t -> ('a * 'b) Lwd.t 9 9 - (** Alias to {!Lwd.pair} suitable for let-op bindings *) 10 10 - (*END*) 11 11 - 12 12 - val ($=) : 'a Lwd.var -> 'a -> unit 13 13 - (** Infix alias to {!Lwd.set} *) 14 14 - 15 15 - val ($<-) : 'a Lwd_table.row -> 'a -> unit 16 16 - (** Infix alias to {!Lwd_table.set} *)

-908

forks/lwd/lib/lwd/lwd_seq.ml

reviewed

··· 1 1 - (*BEGIN INJECTIVITY*) 2 2 - type !+'a t = 3 3 - (*ELSE*) 4 4 - type +'a t = 5 5 - (*END*) 6 6 - | Nil 7 7 - | Leaf of { mutable mark: int; v: 'a; } 8 8 - | Join of { mutable mark: int; l: 'a t; r: 'a t; } 9 9 - 10 10 - type 'a seq = 'a t 11 11 - 12 12 - let empty = Nil 13 13 - 14 14 - let element v = Leaf { mark = 0; v } 15 15 - 16 16 - let mask_bits = 2 17 17 - 18 18 - let maxi a b : int = if b > a then b else a 19 19 - 20 20 - let rank = function 21 21 - | Nil -> 0 22 22 - | Leaf t -> 23 23 - if t.mark <> 0 then 24 24 - invalid_arg "Lwd_seq.rank: node is marked"; 25 25 - 0 26 26 - | Join t -> 27 27 - if t.mark land mask_bits <> 0 then 28 28 - invalid_arg "Lwd_seq.rank: node is marked"; 29 29 - t.mark lsr mask_bits 30 30 - 31 31 - let concat a b = match a, b with 32 32 - | Nil, x | x, Nil -> x 33 33 - | l, r -> Join { mark = (maxi (rank l) (rank r) + 1) lsl mask_bits; l; r } 34 34 - 35 35 - type ('a, 'b) view = 36 36 - | Empty 37 37 - | Element of 'a 38 38 - | Concat of 'b * 'b 39 39 - 40 40 - let view = function 41 41 - | Nil -> Empty 42 42 - | Leaf t -> Element t.v 43 43 - | Join t -> Concat (t.l, t.r) 44 44 - 45 45 - module Balanced : sig 46 46 - type 'a t = private 'a seq 47 47 - val empty : 'a t 48 48 - val element : 'a -> 'a t 49 49 - val concat : 'a t -> 'a t -> 'a t 50 50 - 51 51 - val view : 'a t -> ('a, 'a t) view 52 52 - end = struct 53 53 - type 'a t = 'a seq 54 54 - 55 55 - let empty = empty 56 56 - let element = element 57 57 - 58 58 - let check l r = abs (l - r) <= 1 59 59 - 60 60 - let rec node_left l r = 61 61 - let ml = rank l in 62 62 - let mr = rank r in 63 63 - if check ml mr then concat l r else match l with 64 64 - | Nil | Leaf _ -> assert false 65 65 - | Join t -> 66 66 - if check (rank t.l) ml 67 67 - then concat t.l (node_left t.r r) 68 68 - else match t.r with 69 69 - | Nil | Leaf _ -> assert false 70 70 - | Join tr -> 71 71 - let trr = node_left tr.r r in 72 72 - if check (1 + maxi (rank t.l) (rank tr.l)) (rank trr) 73 73 - then concat (concat t.l tr.l) trr 74 74 - else concat t.l (concat tr.l trr) 75 75 - 76 76 - let rec node_right l r = 77 77 - let ml = rank l in 78 78 - let mr = rank r in 79 79 - if check mr ml then concat l r else match r with 80 80 - | Nil | Leaf _ -> assert false 81 81 - | Join t -> 82 82 - if check (rank t.r) mr 83 83 - then concat (node_right l t.l) t.r 84 84 - else match t.l with 85 85 - | Nil | Leaf _ -> assert false 86 86 - | Join tl -> 87 87 - let tll = node_right l tl.l in 88 88 - if check (1 + maxi (rank tl.r) (rank t.r)) (rank tll) 89 89 - then concat tll (concat tl.r t.r) 90 90 - else concat (concat tll tl.r) t.r 91 91 - 92 92 - let concat l r = 93 93 - let ml = rank l in 94 94 - let mr = rank r in 95 95 - if check ml mr 96 96 - then concat l r 97 97 - else if ml <= mr 98 98 - then node_right l r 99 99 - else node_left l r 100 100 - 101 101 - let view = view 102 102 - end 103 103 - 104 104 - module Marking : sig 105 105 - type mark = (*private*) int 106 106 - val is_shared : mark -> bool 107 107 - val is_not_shared : mark -> bool 108 108 - val is_none : mark -> bool 109 109 - val is_both : mark -> bool 110 110 - val is_old : mark -> bool 111 111 - val is_new : mark -> bool 112 112 - (*val has_old : mark -> bool*) 113 113 - (*val has_new : mark -> bool*) 114 114 - val set_both : mark -> mark 115 115 - val unmark : mark -> mark 116 116 - val get_index : mark -> int 117 117 - val with_index_new : int -> mark 118 118 - 119 119 - type stats 120 120 - val marked : stats -> int 121 121 - val shared : stats -> int 122 122 - val blocked : stats -> int 123 123 - 124 124 - type traversal 125 125 - val old_stats : traversal -> stats 126 126 - val new_stats : traversal -> stats 127 127 - 128 128 - val unsafe_traverse : old_root:_ seq -> new_root:_ seq -> traversal 129 129 - 130 130 - val restore : _ seq -> unit 131 131 - end = struct 132 132 - type mark = int 133 133 - 134 134 - let mask_none = 0 135 135 - let mask_old = 1 136 136 - let mask_new = 2 137 137 - let mask_both = 3 138 138 - 139 139 - let is_shared m = m = -1 140 140 - let is_not_shared m = m <> -1 141 141 - let is_none m = m land mask_both = mask_none 142 142 - let is_both m = m land mask_both = mask_both 143 143 - let is_old m = m land mask_both = mask_old 144 144 - let is_new m = m land mask_both = mask_new 145 145 - (*let has_old m = m land mask_old <> 0*) 146 146 - (*let has_new m = m land mask_new <> 0*) 147 147 - let set_both m = m lor mask_both 148 148 - 149 149 - let get_index m = m lsr mask_bits 150 150 - let with_index_new index = (index lsl mask_bits) lor mask_new 151 151 - 152 152 - let unmark m = m land lnot mask_both 153 153 - 154 154 - type stats = { 155 155 - mutable marked: int; 156 156 - mutable shared: int; 157 157 - mutable blocked: int; 158 158 - } 159 159 - let marked s = s.marked 160 160 - let shared s = s.shared 161 161 - let blocked s = s.blocked 162 162 - 163 163 - let mk_stats () = { marked = 0; shared = 0; blocked = 0 } 164 164 - 165 165 - let new_marked stats = stats.marked <- stats.marked + 1 166 166 - let new_shared stats = stats.shared <- stats.shared + 1 167 167 - let new_blocked stats = stats.blocked <- stats.blocked + 1 168 168 - 169 169 - let rec block stats mask = function 170 170 - | Nil -> () 171 171 - | Leaf t' -> 172 172 - let mark = t'.mark in 173 173 - if mark land mask_both <> mask_both && mark land mask_both <> 0 174 174 - then ( 175 175 - if mark land mask = 0 then new_marked stats else assert false; 176 176 - new_blocked stats; 177 177 - t'.mark <- mark lor mask_both 178 178 - ) 179 179 - | Join t' -> 180 180 - let mark = t'.mark in 181 181 - if mark land mask_both <> mask_both && mark land mask_both <> 0 182 182 - then ( 183 183 - if mark land mask = 0 then new_marked stats else assert false; 184 184 - new_blocked stats; 185 185 - t'.mark <- mark lor mask_both; 186 186 - block stats mask t'.l; 187 187 - block stats mask t'.r; 188 188 - ) 189 189 - 190 190 - let enqueue stats q mask = function 191 191 - | Nil -> () 192 192 - | Leaf t' -> 193 193 - let mark = t'.mark in 194 194 - if mark land mask = 0 then ( 195 195 - (* Not yet seen *) 196 196 - new_marked stats; 197 197 - if mark land mask_both <> 0 then ( 198 198 - (* Newly shared, clear mask *) 199 199 - t'.mark <- -1; 200 200 - new_blocked stats; 201 201 - new_shared stats; 202 202 - ) else 203 203 - t'.mark <- mark lor mask; 204 204 - ); 205 205 - if mark <> -1 && mark land mask_both = mask_both then ( 206 206 - t'.mark <- -1; 207 207 - new_shared stats 208 208 - ) 209 209 - | Join t' as t -> 210 210 - let mark = t'.mark in 211 211 - if mark land mask = 0 then ( 212 212 - (* Not yet seen *) 213 213 - new_marked stats; 214 214 - if mark land mask_both <> 0 then ( 215 215 - (* Newly shared, clear mask *) 216 216 - t'.mark <- -1; 217 217 - new_blocked stats; 218 218 - new_shared stats; 219 219 - block stats mask t'.l; 220 220 - block stats mask t'.r; 221 221 - ) else ( 222 222 - (* First mark *) 223 223 - t'.mark <- mark lor mask; 224 224 - Queue.push t q 225 225 - ) 226 226 - ); 227 227 - if mark <> -1 && mark land mask_both = mask_both then ( 228 228 - t'.mark <- -1; 229 229 - new_shared stats 230 230 - ) 231 231 - 232 232 - let dequeue stats q mask = 233 233 - match Queue.pop q with 234 234 - | Join t -> 235 235 - if t.mark land mask_both = mask then ( 236 236 - enqueue stats q mask t.l; 237 237 - enqueue stats q mask t.r; 238 238 - ) 239 239 - | _ -> assert false 240 240 - 241 241 - let traverse1 stats q mask = 242 242 - while not (Queue.is_empty q) do 243 243 - dequeue stats q mask 244 244 - done 245 245 - 246 246 - let rec traverse sold snew qold qnew = 247 247 - if Queue.is_empty qold then 248 248 - traverse1 snew qnew mask_new 249 249 - else if Queue.is_empty qnew then 250 250 - traverse1 sold qold mask_old 251 251 - else ( 252 252 - dequeue sold qold mask_old; 253 253 - dequeue snew qnew mask_new; 254 254 - traverse sold snew qold qnew 255 255 - ) 256 256 - 257 257 - type traversal = { 258 258 - old_stats: stats; 259 259 - new_stats: stats; 260 260 - } 261 261 - 262 262 - let old_stats tr = tr.old_stats 263 263 - let new_stats tr = tr.new_stats 264 264 - 265 265 - let unsafe_traverse ~old_root ~new_root = 266 266 - let old_stats = mk_stats () in 267 267 - let new_stats = mk_stats () in 268 268 - let old_queue = Queue.create () in 269 269 - let new_queue = Queue.create () in 270 270 - enqueue old_stats old_queue mask_old old_root; 271 271 - enqueue new_stats new_queue mask_new new_root; 272 272 - traverse old_stats new_stats old_queue new_queue; 273 273 - {old_stats; new_stats} 274 274 - 275 275 - let restore = function 276 276 - | Nil -> () 277 277 - | Leaf t -> t.mark <- 0 278 278 - | Join t -> 279 279 - t.mark <- (maxi (rank t.l) (rank t.r) + 1) lsl mask_bits 280 280 - end 281 281 - 282 282 - (* Marks go through many states. 283 283 - 284 284 - A mark is usually split in two parts: 285 285 - - the mask, made of the two least significant bits 286 286 - - the index is an unsigned integer formed of all the remaining bits 287 287 - 288 288 - The exception is the distinguished mask with value -1 (all bits set to 1) 289 289 - that denote a "locked" node. 290 290 - 291 291 - When the mask is 0, the index denotes the rank of the node: the depth of 292 292 - the tree rooted at this node. 293 293 - When the mask is non-zero, the index meaning is left to the traversal 294 294 - algorithm. 295 295 - Restoring the mark sets the mask to 0 and the indext to the rank, 296 296 - but is only possible when the children of the node are themselves restored. 297 297 - *) 298 298 - 299 299 - module Reducer = struct 300 300 - type (+'a, 'b) xform = 301 301 - | XEmpty 302 302 - | XLeaf of { a: 'a t; mutable b: 'b option; } 303 303 - | XJoin of { a: 'a t; mutable b: 'b option; 304 304 - l: ('a, 'b) xform; r: ('a, 'b) xform; } 305 305 - 306 306 - type ('a, 'b) unmark_state = { 307 307 - dropped : 'b option array; 308 308 - mutable dropped_leaf : int; 309 309 - mutable dropped_join : int; 310 310 - shared : 'a seq array; 311 311 - shared_x : ('a, 'b) xform list array; 312 312 - mutable shared_index: int; 313 313 - } 314 314 - 315 315 - let next_shared_index st = 316 316 - let result = st.shared_index in 317 317 - st.shared_index <- result + 1; 318 318 - result 319 319 - 320 320 - let rec unblock = function 321 321 - | XEmpty -> () 322 322 - | XLeaf {a = Nil | Join _; _} -> assert false 323 323 - | XJoin {a = Nil | Leaf _; _} -> assert false 324 324 - | XLeaf {a = Leaf t'; _} -> 325 325 - let mark = t'.mark in 326 326 - if Marking.is_not_shared mark && Marking.is_both mark then 327 327 - t'.mark <- Marking.unmark mark; 328 328 - | XJoin {a = Join t'; l; r; _} -> 329 329 - let mark = t'.mark in 330 330 - if Marking.is_not_shared mark && Marking.is_both mark then ( 331 331 - t'.mark <- Marking.unmark mark; 332 332 - unblock l; 333 333 - unblock r 334 334 - ) 335 335 - 336 336 - let rec unmark_old st = function 337 337 - | XEmpty -> () 338 338 - | XLeaf {a = Nil | Join _; _} -> assert false 339 339 - | XJoin {a = Nil | Leaf _; _} -> assert false 340 340 - | XLeaf {a = Leaf t' as a; b} as t -> 341 341 - let mark = t'.mark in 342 342 - if Marking.is_old mark then ( 343 343 - let dropped_leaf = st.dropped_leaf in 344 344 - if dropped_leaf > -1 then ( 345 345 - st.dropped.(dropped_leaf) <- b; 346 346 - st.dropped_leaf <- dropped_leaf + 1; 347 347 - assert (st.dropped_leaf <= st.dropped_join); 348 348 - ); 349 349 - t'.mark <- Marking.unmark mark 350 350 - ) else if Marking.is_shared mark then ( 351 351 - let index = next_shared_index st in 352 352 - st.shared.(index) <- a; 353 353 - st.shared_x.(index) <- [t]; 354 354 - t'.mark <- Marking.with_index_new index; 355 355 - ) else if Marking.is_new mark then ( 356 356 - let index = Marking.get_index mark in 357 357 - st.shared_x.(index) <- t :: st.shared_x.(index); 358 358 - ) else if Marking.is_both mark then ( 359 359 - assert false 360 360 - (*t'.mark <- mark land lnot both_mask*) 361 361 - ) 362 362 - | XJoin {a = Join t' as a; l; r; b} as t -> 363 363 - let mark = t'.mark in 364 364 - if Marking.is_shared mark then ( 365 365 - let index = next_shared_index st in 366 366 - st.shared.(index) <- a; 367 367 - st.shared_x.(index) <- [t]; 368 368 - t'.mark <- Marking.with_index_new index; 369 369 - unblock l; 370 370 - unblock r; 371 371 - ) else if Marking.is_old mark then ( 372 372 - if st.dropped_join > -1 then ( 373 373 - let dropped_join = st.dropped_join - 1 in 374 374 - st.dropped.(dropped_join) <- b; 375 375 - st.dropped_join <- dropped_join; 376 376 - assert (st.dropped_leaf <= st.dropped_join); 377 377 - ); 378 378 - t'.mark <- Marking.unmark mark; 379 379 - unmark_old st l; 380 380 - unmark_old st r; 381 381 - ) else if Marking.is_new mark then ( 382 382 - let index = mark lsr mask_bits in 383 383 - st.shared_x.(index) <- t :: st.shared_x.(index); 384 384 - ) else if Marking.is_both mark then ( 385 385 - assert false 386 386 - ) 387 387 - 388 388 - let prepare_shared st = 389 389 - for i = 0 to st.shared_index - 1 do 390 390 - begin match st.shared.(i) with 391 391 - | Nil -> () 392 392 - | Leaf t -> t.mark <- Marking.set_both t.mark 393 393 - | Join t -> t.mark <- Marking.set_both t.mark 394 394 - end; 395 395 - match st.shared_x.(i) with 396 396 - | [] -> assert false 397 397 - | [_] -> () 398 398 - | xs -> st.shared_x.(i) <- List.rev xs 399 399 - done 400 400 - 401 401 - let rec unmark_new st = function 402 402 - | Nil -> XEmpty 403 403 - | Leaf t' as t -> 404 404 - let mark = t'.mark in 405 405 - if Marking.is_not_shared mark && Marking.is_both mark then ( 406 406 - let index = mark lsr mask_bits in 407 407 - match st.shared_x.(index) with 408 408 - | [] -> XLeaf {a = t; b = None} 409 409 - | x :: xs -> st.shared_x.(index) <- xs; x 410 410 - ) else ( 411 411 - t'.mark <- 0; 412 412 - XLeaf {a = t; b = None} 413 413 - ) 414 414 - | Join t' as t -> 415 415 - let mark = t'.mark in 416 416 - if mark = -1 then ( 417 417 - let index = next_shared_index st in 418 418 - t'.mark <- 0; 419 419 - st.shared.(index) <- t; 420 420 - let l = unmark_new st t'.l in 421 421 - let r = unmark_new st t'.r in 422 422 - XJoin {a = t; b = None; l; r} 423 423 - ) else if Marking.is_both mark then ( 424 424 - let index = mark lsr mask_bits in 425 425 - match st.shared_x.(index) with 426 426 - | [] -> assert false 427 427 - | x :: xs -> 428 428 - st.shared_x.(index) <- xs; 429 429 - if xs == [] then t'.mark <- 0; 430 430 - x 431 431 - ) else ( 432 432 - t'.mark <- Marking.unmark t'.mark; 433 433 - let l = unmark_new st t'.l in 434 434 - let r = unmark_new st t'.r in 435 435 - XJoin {a = t; b = None; l; r} 436 436 - ) 437 437 - 438 438 - type 'b dropped = { 439 439 - leaves: int; 440 440 - table: 'b option array; 441 441 - extra_leaf: 'b list; 442 442 - extra_join: 'b list; 443 443 - } 444 444 - 445 445 - let no_dropped = 446 446 - { leaves = 0; table = [||]; extra_leaf = []; extra_join = [] } 447 447 - 448 448 - let diff get_dropped xold tnew = match xold, tnew with 449 449 - | XEmpty, Nil -> no_dropped, XEmpty 450 450 - | (XLeaf {a; _} | XJoin {a; _}), _ when a == tnew -> no_dropped, xold 451 451 - | _ -> 452 452 - let traversal = 453 453 - Marking.unsafe_traverse 454 454 - ~old_root:(match xold with 455 455 - | XEmpty -> empty 456 456 - | (XLeaf {a; _} | XJoin {a; _}) -> a 457 457 - ) 458 458 - ~new_root:tnew 459 459 - in 460 460 - let sold = Marking.old_stats traversal in 461 461 - let snew = Marking.new_stats traversal in 462 462 - let nb_dropped = 463 463 - Marking.marked sold - (Marking.blocked sold + Marking.blocked snew) 464 464 - in 465 465 - let nb_shared = 466 466 - Marking.shared sold + Marking.shared snew 467 467 - in 468 468 - let st = { 469 469 - dropped = if get_dropped then Array.make nb_dropped None else [||]; 470 470 - dropped_leaf = if get_dropped then 0 else - 1; 471 471 - dropped_join = if get_dropped then nb_dropped else - 1; 472 472 - shared = Array.make nb_shared Nil; 473 473 - shared_x = Array.make nb_shared []; 474 474 - shared_index = 0; 475 475 - } in 476 476 - (*Printf.eprintf "sold.shared:%d sold.marked:%d sold.blocked:%d\n%!" 477 477 - sold.shared sold.marked sold.blocked; 478 478 - Printf.eprintf "snew.shared:%d snew.marked:%d snew.blocked:%d\n%!" 479 479 - snew.shared snew.marked snew.blocked;*) 480 480 - unmark_old st xold; 481 481 - assert (st.dropped_leaf = st.dropped_join); 482 482 - prepare_shared st; 483 483 - let result = unmark_new st tnew in 484 484 - (*Printf.eprintf "new_computed:%d%!\n" !new_computed;*) 485 485 - for i = st.shared_index - 1 downto 0 do 486 486 - Marking.restore st.shared.(i) 487 487 - done; 488 488 - if get_dropped then ( 489 489 - let xleaf = ref [] in 490 490 - let xjoin = ref [] in 491 491 - for i = 0 to st.shared_index - 1 do 492 492 - List.iter (function 493 493 - | XLeaf { b = Some b; _} -> xleaf := b :: !xleaf 494 494 - | XJoin { b = Some b; _} -> xjoin := b :: !xjoin 495 495 - | _ -> () 496 496 - ) st.shared_x.(i) 497 497 - done; 498 498 - ({ leaves = st.dropped_leaf; 499 499 - table = st.dropped; 500 500 - extra_leaf = !xleaf; 501 501 - extra_join = !xjoin }, result) 502 502 - ) else 503 503 - no_dropped, result 504 504 - 505 505 - type ('a, 'b) map_reduce = { 506 506 - map: 'a -> 'b; 507 507 - reduce: 'b -> 'b -> 'b; 508 508 - } 509 509 - 510 510 - let eval map_reduce = function 511 511 - | XEmpty -> None 512 512 - | other -> 513 513 - let rec aux = function 514 514 - | XEmpty | XLeaf {a = Nil | Join _; _} -> assert false 515 515 - | XLeaf {b = Some b; _} | XJoin {b = Some b; _} -> b 516 516 - | XLeaf ({a = Leaf t';_ } as t) -> 517 517 - let result = map_reduce.map t'.v in 518 518 - t.b <- Some result; 519 519 - result 520 520 - | XJoin t -> 521 521 - let l = aux t.l and r = aux t.r in 522 522 - let result = map_reduce.reduce l r in 523 523 - t.b <- Some result; 524 524 - result 525 525 - in 526 526 - Some (aux other) 527 527 - 528 528 - type ('a, 'b) reducer = ('a, 'b) map_reduce * ('a, 'b) xform 529 529 - 530 530 - let make ~map ~reduce = ({map; reduce}, XEmpty) 531 531 - 532 532 - let reduce (map_reduce, tree : _ reducer) = 533 533 - eval map_reduce tree 534 534 - 535 535 - let update (map_reduce, old_tree : _ reducer) new_tree : _ reducer = 536 536 - let _, tree = diff false old_tree new_tree in 537 537 - (map_reduce, tree) 538 538 - 539 539 - let update_and_get_dropped (map_reduce, old_tree : _ reducer) new_tree 540 540 - : _ dropped * _ reducer = 541 541 - let dropped, tree = diff true old_tree new_tree in 542 542 - (dropped, (map_reduce, tree)) 543 543 - 544 544 - let fold_dropped kind f dropped acc = 545 545 - let acc = ref acc in 546 546 - let start, bound = match kind with 547 547 - | `All -> 0, Array.length dropped.table 548 548 - | `Map -> 0, dropped.leaves 549 549 - | `Reduce -> dropped.leaves, Array.length dropped.table 550 550 - in 551 551 - for i = start to bound - 1 do 552 552 - match dropped.table.(i) with 553 553 - | None -> () 554 554 - | Some x -> acc := f x !acc 555 555 - done; 556 556 - begin match kind with 557 557 - | `All | `Map -> 558 558 - List.iter (fun x -> acc := f x !acc) dropped.extra_leaf 559 559 - | `Reduce -> () 560 560 - end; 561 561 - begin match kind with 562 562 - | `All | `Reduce -> 563 563 - List.iter (fun x -> acc := f x !acc) dropped.extra_join 564 564 - | `Map -> () 565 565 - end; 566 566 - !acc 567 567 - end 568 568 - 569 569 - (* Lwd interface *) 570 570 - 571 571 - let rec pure_map_reduce map reduce = function 572 572 - | Nil -> assert false 573 573 - | Leaf t -> map t.v 574 574 - | Join t -> 575 575 - reduce 576 576 - (pure_map_reduce map reduce t.l) 577 577 - (pure_map_reduce map reduce t.r) 578 578 - 579 579 - let fold ~map ~reduce seq = 580 580 - match Lwd.is_pure seq with 581 581 - | Some Nil -> Lwd.pure None 582 582 - | Some other -> Lwd.pure (Some (pure_map_reduce map reduce other)) 583 583 - | None -> 584 584 - let reducer = ref (Reducer.make ~map ~reduce) in 585 585 - Lwd.map seq ~f:begin fun seq -> 586 586 - let reducer' = Reducer.update !reducer seq in 587 587 - reducer := reducer'; 588 588 - Reducer.reduce reducer' 589 589 - end 590 590 - 591 591 - let fold_monoid map (zero, reduce) seq = 592 592 - match Lwd.is_pure seq with 593 593 - | Some Nil -> Lwd.pure zero 594 594 - | Some other -> Lwd.pure (pure_map_reduce map reduce other) 595 595 - | None -> 596 596 - let reducer = ref (Reducer.make ~map ~reduce) in 597 597 - Lwd.map seq ~f:begin fun seq -> 598 598 - let reducer' = Reducer.update !reducer seq in 599 599 - reducer := reducer'; 600 600 - match Reducer.reduce reducer' with 601 601 - | None -> zero 602 602 - | Some x -> x 603 603 - end 604 604 - 605 605 - let monoid = (empty, concat) 606 606 - 607 607 - let transform_list ls f = 608 608 - Lwd_utils.map_reduce f monoid ls 609 609 - 610 610 - let of_list ls = transform_list ls element 611 611 - 612 612 - let rec of_sub_array f arr i j = 613 613 - if j < i then empty 614 614 - else if j = i then f arr.(i) 615 615 - else 616 616 - let k = i + (j - i) / 2 in 617 617 - concat (of_sub_array f arr i k) (of_sub_array f arr (k + 1) j) 618 618 - 619 619 - let transform_array arr f = of_sub_array f arr 0 (Array.length arr - 1) 620 620 - 621 621 - let of_array arr = transform_array arr element 622 622 - 623 623 - let to_list x = 624 624 - let rec fold x acc = match x with 625 625 - | Nil -> acc 626 626 - | Leaf t -> t.v :: acc 627 627 - | Join t -> fold t.l (fold t.r acc) 628 628 - in 629 629 - fold x [] 630 630 - 631 631 - let to_array x = 632 632 - let rec count = function 633 633 - | Nil -> 0 634 634 - | Leaf _ -> 1 635 635 - | Join t -> count t.l + count t.r 636 636 - in 637 637 - match count x with 638 638 - | 0 -> [||] 639 639 - | n -> 640 640 - let rec first = function 641 641 - | Nil -> assert false 642 642 - | Leaf t -> t.v 643 643 - | Join t -> first t.l 644 644 - in 645 645 - let first = first x in 646 646 - let arr = Array.make n first in 647 647 - let rec fold i = function 648 648 - | Nil -> i 649 649 - | Leaf t -> arr.(i) <- t.v; i + 1 650 650 - | Join t -> 651 651 - let i = fold i t.l in 652 652 - let i = fold i t.r in 653 653 - i 654 654 - in 655 655 - let _ : int = fold 0 x in 656 656 - arr 657 657 - 658 658 - let lwd_empty : 'a t Lwd.t = Lwd.pure Nil 659 659 - let lwd_monoid : 'a. 'a t Lwd.t Lwd_utils.monoid = 660 660 - (lwd_empty, fun x y -> Lwd.map2 ~f:concat x y) 661 661 - 662 662 - let map f seq = 663 663 - fold_monoid (fun x -> element (f x)) monoid seq 664 664 - 665 665 - let filter f seq = 666 666 - fold_monoid (fun x -> if f x then element x else empty) monoid seq 667 667 - 668 668 - let filter_map f seq = 669 669 - let select x = match f x with 670 670 - | Some y -> element y 671 671 - | None -> empty 672 672 - in 673 673 - fold_monoid select monoid seq 674 674 - 675 675 - let bind (seq : 'a seq Lwd.t) (f : 'a -> 'b seq Lwd.t) : 'b seq Lwd.t = 676 676 - Lwd.join (fold_monoid f lwd_monoid seq) 677 677 - 678 678 - let seq_bind (seq : 'a seq Lwd.t) (f : 'a -> 'b seq) : 'b seq Lwd.t = 679 679 - fold_monoid f monoid seq 680 680 - 681 681 - let lift (seq : 'a Lwd.t seq Lwd.t) : 'a seq Lwd.t = 682 682 - bind seq (Lwd.map ~f:element) 683 683 - 684 684 - module BalancedTree : sig 685 685 - type 'a t = 686 686 - | Leaf 687 687 - | Node of { 688 688 - rank: int; 689 689 - l: 'a t; 690 690 - x: int * 'a seq; 691 691 - r: 'a t; 692 692 - mutable seq: 'a seq; 693 693 - } 694 694 - val leaf : 'a t 695 695 - (*val node : 'a t -> int * 'a seq -> 'a t -> 'a t*) 696 696 - 697 697 - val insert : cmp:('a -> 'a -> int) -> int -> 'a seq -> 'a t -> 'a t 698 698 - (*val union : cmp:('a -> 'a -> int) -> 'a t -> 'a t -> 'a t*) 699 699 - end = struct 700 700 - type 'a t = 701 701 - | Leaf 702 702 - | Node of { 703 703 - rank: int; 704 704 - l: 'a t; 705 705 - x: int * 'a seq; 706 706 - r: 'a t; 707 707 - mutable seq: 'a seq; 708 708 - } 709 709 - 710 710 - let leaf = Leaf 711 711 - 712 712 - let rank = function 713 713 - | Leaf -> 0 714 714 - | Node t -> t.rank 715 715 - 716 716 - let check l r = abs (l - r) <= 1 717 717 - 718 718 - let node l x r = 719 719 - Node {l; x; r; seq = empty; rank = maxi (rank l) (rank r) + 1} 720 720 - 721 721 - let rec node_left l x r = 722 722 - let ml = rank l in 723 723 - let mr = rank r in 724 724 - if check ml mr then node l x r else match l with 725 725 - | Leaf -> assert false 726 726 - | Node t -> 727 727 - if check (rank t.l) ml 728 728 - then node t.l t.x (node_left t.r x r) 729 729 - else match t.r with 730 730 - | Leaf -> assert false 731 731 - | Node tr -> 732 732 - let trr = node_left tr.r x r in 733 733 - if check (1 + maxi (rank t.l) (rank tr.l)) (rank trr) 734 734 - then node (node t.l t.x tr.l) tr.x trr 735 735 - else node t.l t.x (node tr.l tr.x trr) 736 736 - 737 737 - let rec node_right l x r = 738 738 - let ml = rank l in 739 739 - let mr = rank r in 740 740 - if check mr ml then node l x r else match r with 741 741 - | Leaf -> assert false 742 742 - | Node t -> 743 743 - if check (rank t.r) mr 744 744 - then node (node_right l x t.l) t.x t.r 745 745 - else match t.l with 746 746 - | Leaf -> assert false 747 747 - | Node tl -> 748 748 - let tll = node_right l x tl.l in 749 749 - if check (1 + maxi (rank tl.r) (rank t.r)) (rank tll) 750 750 - then node tll tl.x (node tl.r t.x t.r) 751 751 - else node (node tll tl.x tl.r) t.x t.r 752 752 - 753 753 - let node l x r = 754 754 - let ml = rank l in 755 755 - let mr = rank r in 756 756 - if check ml mr 757 757 - then node l x r 758 758 - else if ml <= mr 759 759 - then node_right l x r 760 760 - else node_left l x r 761 761 - 762 762 - let rec join l r = match l, r with 763 763 - | Leaf, t | t, Leaf -> t 764 764 - | Node tl, Node tr -> 765 765 - if tl.rank <= tr.rank then 766 766 - node (join l tr.l) tr.x tr.r 767 767 - else 768 768 - node tl.l tl.x (join tl.r r) 769 769 - 770 770 - let get_element = function 771 771 - | Nil | Join _ -> assert false 772 772 - | Leaf {v;_} -> v 773 773 - 774 774 - (*let rec split ~cmp k = function 775 775 - | Leaf -> Leaf, 0, Leaf 776 776 - | Node t -> 777 777 - let c = cmp k (get_element (snd (t.x))) in 778 778 - if c < 0 then 779 779 - let l', v', r' = split ~cmp k t.l in 780 780 - l', v', join r' t.r 781 781 - else if c > 0 then 782 782 - let l', v', r' = split ~cmp k t.r in 783 783 - join t.l l', v', r' 784 784 - else 785 785 - (t.l, fst t.x, t.r) 786 786 - 787 787 - let rec union ~cmp t1 t2 = 788 788 - match t1, t2 with 789 789 - | Leaf, t | t, Leaf -> t 790 790 - | Node t1, t2 -> 791 791 - let m1, k1 = t1.x in 792 792 - let l2, m2, r2 = split ~cmp (get_element k1) t2 in 793 793 - let l' = union ~cmp t1.l l2 in 794 794 - let r' = union ~cmp t1.r r2 in 795 795 - let m = m1 + m2 in 796 796 - if m = 0 then 797 797 - join l' r' 798 798 - else ( 799 799 - assert (m > 0); 800 800 - node l' (m, k1) r'; 801 801 - ) 802 802 - *) 803 803 - 804 804 - let insert ~cmp m1 s t = 805 805 - assert (m1 <> 0); 806 806 - let rec aux = function 807 807 - | Leaf -> node Leaf (m1, s) Leaf 808 808 - | Node t -> 809 809 - let m2, x = t.x in 810 810 - let c = cmp (get_element s) (get_element x) in 811 811 - if c = 0 then 812 812 - let m = m1 + m2 in 813 813 - if m = 0 then 814 814 - join t.l t.r 815 815 - else 816 816 - node t.l (m, x) t.r 817 817 - else if c < 0 then 818 818 - let l' = aux t.l in 819 819 - node l' t.x t.r 820 820 - else 821 821 - let r' = aux t.r in 822 822 - node t.l t.x r' 823 823 - in 824 824 - aux t 825 825 - end 826 826 - 827 827 - let rec seq_of_tree = function 828 828 - | BalancedTree.Leaf -> empty 829 829 - | BalancedTree.Node t -> 830 830 - match t.seq with 831 831 - | Nil -> 832 832 - let sl = seq_of_tree t.l in 833 833 - let sr = seq_of_tree t.r in 834 834 - assert (fst t.x > 0); 835 835 - let seq = concat sl (concat (snd t.x) sr) in 836 836 - t.seq <- seq; 837 837 - seq 838 838 - | seq -> seq 839 839 - 840 840 - let sort_uniq cmp seq = 841 841 - let previous_seq = ref empty in 842 842 - let previous_tree = ref BalancedTree.leaf in 843 843 - let f new_seq = 844 844 - let old_seq = !previous_seq in 845 845 - let old_tree = !previous_tree in 846 846 - let _ = Marking.unsafe_traverse ~old_root:old_seq ~new_root:new_seq in 847 847 - let rec unblock = function 848 848 - | Nil -> () 849 849 - | Leaf t -> t.mark <- Marking.unmark t.mark 850 850 - | Join t as seq -> 851 851 - let mark = t.mark in 852 852 - unblock t.l; 853 853 - unblock t.r; 854 854 - if Marking.is_shared mark then ( 855 855 - Marking.restore seq; 856 856 - ) else if Marking.is_both mark then ( 857 857 - t.mark <- Marking.unmark mark; 858 858 - ) else 859 859 - assert (Marking.is_none mark) 860 860 - in 861 861 - let rec unmark_new tree = function 862 862 - | Nil -> tree 863 863 - | Leaf t as seq -> 864 864 - let mark = t.mark in 865 865 - t.mark <- 0; 866 866 - if Marking.is_new mark then 867 867 - BalancedTree.insert ~cmp (+1) seq tree 868 868 - else ( 869 869 - assert (Marking.is_both mark || Marking.is_none mark); 870 870 - tree 871 871 - ) 872 872 - | Join t as seq -> 873 873 - let mark = t.mark in 874 874 - if Marking.is_new mark then ( 875 875 - t.mark <- Marking.unmark mark; 876 876 - unmark_new (unmark_new tree t.l) t.r 877 877 - ) else ( 878 878 - unblock seq; 879 879 - tree 880 880 - ) 881 881 - in 882 882 - let rec unmark_old tree = function 883 883 - | Nil -> tree 884 884 - | Leaf t as seq -> 885 885 - let mark = t.mark in 886 886 - t.mark <- 0; 887 887 - if Marking.is_old mark then 888 888 - BalancedTree.insert ~cmp (-1) seq tree 889 889 - else ( 890 890 - assert (Marking.is_both mark || Marking.is_none mark); 891 891 - tree 892 892 - ) 893 893 - | Join t as seq -> 894 894 - let mark = t.mark in 895 895 - if Marking.is_old mark then ( 896 896 - t.mark <- Marking.unmark mark; 897 897 - unmark_old (unmark_old tree t.l) t.r 898 898 - ) else ( 899 899 - unblock seq; 900 900 - tree 901 901 - ) 902 902 - in 903 903 - let new_tree = unmark_old (unmark_new old_tree new_seq) old_seq in 904 904 - previous_seq := new_seq; 905 905 - previous_tree := new_tree; 906 906 - seq_of_tree new_tree 907 907 - in 908 908 - Lwd.map seq ~f

-209

forks/lwd/lib/lwd/lwd_seq.mli

reviewed

··· 1 1 - (** {1 Sequence manipulation} 2 2 - 3 3 - [Lwd_seq] is an ordered collection with a pure interface. 4 4 - Changes to collections are easy to track. 5 5 - 6 6 - A collection can be transformed with the usual map, filter and fold 7 7 - combinators. If the collection is updated, shared elements (in the sense of 8 8 - physical sharing), the result of the previous transformation will be reused 9 9 - for these elements. 10 10 - 11 11 - The book-keeping overhead is O(n) in the number of changes, so O(1) per 12 12 - element. 13 13 - *) 14 14 - 15 15 - (*BEGIN INJECTIVITY*) 16 16 - type !+'a t 17 17 - type !+'a seq = 'a t 18 18 - (*ELSE*) 19 19 - type +'a t 20 20 - type +'a seq = 'a t 21 21 - (*END*) 22 22 - 23 23 - (** The type of sequences *) 24 24 - 25 25 - (** {2 Primitive constructors} *) 26 26 - 27 27 - val empty : 'a seq 28 28 - (** A sequence with no element. *) 29 29 - 30 30 - val element : 'a -> 'a seq 31 31 - (** A singleton sequence. The physical identity of the element is considered 32 32 - when reusing previous computations. 33 33 - 34 34 - If you do: 35 35 - 36 36 - {[let x1 = element x 37 37 - let x2 = element x]} 38 38 - 39 39 - Then [x1] and [x2] are seen as different elements and no sharing will be 40 40 - done during transformation. 41 41 - *) 42 42 - 43 43 - val concat : 'a seq -> 'a seq -> 'a seq 44 44 - (** Concatenate two sequences into a bigger one. 45 45 - As for [element], the physical identity of a sequence is considered for 46 46 - reuse. 47 47 - *) 48 48 - 49 49 - (** {2 Looking at sequence contents} *) 50 50 - 51 51 - type ('a, 'b) view = 52 52 - | Empty 53 53 - | Element of 'a 54 54 - | Concat of 'b * 'b 55 55 - 56 56 - val view : 'a seq -> ('a, 'a seq) view 57 57 - (** View how a sequence is defined *) 58 58 - 59 59 - (** {2 Conversion between sequences, lists and arrays} *) 60 60 - 61 61 - val transform_list : 'a list -> ('a -> 'b seq) -> 'b seq 62 62 - (** Produce a sequence by transforming each element of a list and concatenating 63 63 - all results. *) 64 64 - 65 65 - val transform_array : 'a array -> ('a -> 'b seq) -> 'b seq 66 66 - (** Produce a sequence by transforming each element of an array and 67 67 - concatenating all results. *) 68 68 - 69 69 - val of_list : 'a list -> 'a seq 70 70 - (** Produce a sequence from a list *) 71 71 - 72 72 - val of_array : 'a array -> 'a seq 73 73 - (** Produce a sequence from an array *) 74 74 - 75 75 - val to_list : 'a seq -> 'a list 76 76 - (** Produce a list from a sequence *) 77 77 - 78 78 - val to_array : 'a seq -> 'a array 79 79 - (** Produce an array from a sequence *) 80 80 - 81 81 - (** {2 Balanced variant of sequences} *) 82 82 - 83 83 - module Balanced : sig 84 84 - 85 85 - (** A variant of the sequence type that guarantees that the depth of a 86 86 - transformation, measured as the number of nested [concat] nodes, grows in 87 87 - O(log n) where n is the number of elements in the sequnce. 88 88 - 89 89 - This is useful to prevent stack overflows and to avoid degenerate cases 90 90 - where a single element changes, but it is at the end of a linear sequence 91 91 - of [concat] nodes, thus making the total work O(n). 92 92 - For instance, in: 93 93 - 94 94 - {[concat e1 (concat e2 (concat e3 (... (concat e_n))...))]} 95 95 - 96 96 - If [e_n] changes, the whole spine has to be recomputed. 97 97 - 98 98 - Using [Balanced.concat], the representation will be re-balanced 99 99 - internally. Then [Balanced.view] should be used to access the balanced 100 100 - sequence. 101 101 - 102 102 - When working with balanced sequences in a transformation pipeline, it is 103 103 - only useful to balance the first sequence of the pipeline. Derived 104 104 - sequence will have a depth bounded by the depth of the first one. 105 105 - *) 106 106 - 107 107 - type 'a t = private 'a seq 108 108 - (** Type of balanced sequences *) 109 109 - 110 110 - val empty : 'a t 111 111 - val element : 'a -> 'a t 112 112 - val concat : 'a t -> 'a t -> 'a t 113 113 - 114 114 - val view : 'a t -> ('a, 'a t) view 115 115 - end 116 116 - 117 117 - (** {2 Transforming sequences} *) 118 118 - 119 119 - (** 120 120 - All sequences live in [Lwd] monad: if a sequence changes slightly, parts 121 121 - that have not changed will not be re-transformed. 122 122 - *) 123 123 - 124 124 - val fold : 125 125 - map:('a -> 'b) -> reduce:('b -> 'b -> 'b) -> 'a seq Lwd.t -> 'b option Lwd.t 126 126 - (** [fold ~map ~reduce] transforms a sequence. 127 127 - If the sequence is non-empty, the [map] function is applied to element 128 128 - nodes and the [reduce] function is used to combine transformed concatenated 129 129 - nodes. 130 130 - If the sequence is empty, None is returned. 131 131 - *) 132 132 - 133 133 - val fold_monoid : 134 134 - ('a -> 'b) -> 'b Lwd_utils.monoid -> 'a seq Lwd.t -> 'b Lwd.t 135 135 - (** Like [fold], but reduction and default value are defined by a [monoid] *) 136 136 - 137 137 - val map : 138 138 - ('a -> 'b) -> 'a seq Lwd.t -> 'b seq Lwd.t 139 139 - (** [map f] transforms a sequence by applying [f] to each element. *) 140 140 - 141 141 - val filter : 142 142 - ('a -> bool) -> 'a seq Lwd.t -> 'a seq Lwd.t 143 143 - (** [filter p] transforms a sequence by keeping elements that satisfies [p]. *) 144 144 - 145 145 - val filter_map : 146 146 - ('a -> 'b option) -> 'a seq Lwd.t -> 'b seq Lwd.t 147 147 - (** Filter and map elements at the same time *) 148 148 - 149 149 - val lift : 'a Lwd.t seq Lwd.t -> 'a seq Lwd.t 150 150 - (** Remove a layer of [Lwd] inside a sequence. *) 151 151 - 152 152 - val bind : 'a seq Lwd.t -> ('a -> 'b seq Lwd.t) -> 'b seq Lwd.t 153 153 - (** Sequence forms a monad too... *) 154 154 - 155 155 - val seq_bind : 'a seq Lwd.t -> ('a -> 'b seq) -> 'b seq Lwd.t 156 156 - (** Sequence forms a monad too... *) 157 157 - 158 158 - val monoid : 'a t Lwd_utils.monoid 159 159 - (** Monoid instance for sequences *) 160 160 - 161 161 - val lwd_monoid : 'a t Lwd.t Lwd_utils.monoid 162 162 - (** Monoid instance for reactive sequences *) 163 163 - 164 164 - val sort_uniq : ('a -> 'a -> int) -> 'a seq Lwd.t -> 'a seq Lwd.t 165 165 - 166 166 - (** {2 Low-level interface for observing changes} *) 167 167 - 168 168 - module Reducer : sig 169 169 - (* The interface allows to implement incremental sequence transformation 170 170 - outside of the [Lwd] monad. 171 171 - Actually, the Lwd functions above are implemented on top of this 172 172 - interface. 173 173 - *) 174 174 - 175 175 - (* A [('a, 'b) reducer] value stores the state necessary to incrementally 176 176 - transform an ['a seq] to ['b]. 177 177 - In essence, the Lwd functions just hide a reducer value. 178 178 - *) 179 179 - type ('a, 'b) reducer 180 180 - 181 181 - (* A new reducer that transforms sequences with the given [map] and [reduce] 182 182 - functions. The reducer starts from the [empty] sequence. *) 183 183 - val make : map:('a -> 'b) -> reduce:('b -> 'b -> 'b) -> ('a, 'b) reducer 184 184 - 185 185 - (* Updates the [reducer] to transform another sequence. 186 186 - Intermediate nodes are reused when possible. 187 187 - Only the "reuse plan" is computed by [update], actual transformation is 188 188 - done by the [reduce] function. 189 189 - *) 190 190 - val update : ('a, 'b) reducer -> 'a seq -> ('a, 'b) reducer 191 191 - 192 192 - (* Returns the reduced ['b] value if the sequence is non-empty or [None] if 193 193 - the sequence is empty. 194 194 - Because transformation is done lazily, [reduce] is the only function 195 195 - that can call [map] and [reduce]. 196 196 - *) 197 197 - val reduce : ('a, 'b) reducer -> 'b option 198 198 - 199 199 - (* Sometimes it is important to track the elements that disappeared from a 200 200 - sequence. The ['b dropped] type represent all the intermediate result that 201 201 - were referenced by a reducer and are no longer after an update. 202 202 - *) 203 203 - type 'b dropped 204 204 - val update_and_get_dropped : 205 205 - ('a, 'b) reducer -> 'a seq -> 'b dropped * ('a, 'b) reducer 206 206 - 207 207 - val fold_dropped : 208 208 - [<`All|`Map|`Reduce] -> ('a -> 'b -> 'b) -> 'a dropped -> 'b -> 'b 209 209 - end

-579

forks/lwd/lib/lwd/lwd_table.ml

reviewed

··· 1 1 - type 'a binding = 2 2 - | Bound of { value : 'a ; mutable valid : bool } 3 3 - | Unbound 4 4 - 5 5 - type 'a tree = 6 6 - | Leaf 7 7 - | Node of { 8 8 - mutable version : int; 9 9 - mutable left : 'a tree; 10 10 - mutable binding : 'a binding; 11 11 - mutable right : 'a tree; 12 12 - mutable parent : 'a tree; 13 13 - mutable size : int; 14 14 - } 15 15 - | Root of { 16 16 - mutable version : int; 17 17 - mutable child : 'a tree; 18 18 - mutable generation : unit ref; 19 19 - mutable on_invalidate : Obj.t Lwd.prim list; 20 20 - } 21 21 - 22 22 - type 'a t = 'a tree 23 23 - type 'a row = 'a tree 24 24 - 25 25 - let not_origin = ref () (* not {!origin} *) 26 26 - let origin = ref () (* not {!not_origin} *) 27 27 - 28 28 - let make () = 29 29 - Root { child = Leaf; generation = origin; version = 0; on_invalidate = [] } 30 30 - 31 31 - let set_parent ~parent = function 32 32 - | Root _ -> assert false 33 33 - | Node n -> n.parent <- parent 34 34 - | Leaf -> () 35 35 - 36 36 - let reparent ~parent ~oldchild ~newchild = 37 37 - match parent with 38 38 - | Root r -> 39 39 - assert (r.child == oldchild); 40 40 - r.child <- newchild 41 41 - | Node n when n.left == oldchild -> 42 42 - n.left <- newchild 43 43 - | Node n when n.right == oldchild -> 44 44 - n.right <- newchild 45 45 - | Leaf | Node _ -> assert false 46 46 - 47 47 - let make_node set ~left ~right ~parent = 48 48 - let binding = match set with 49 49 - | None -> Unbound 50 50 - | Some value -> Bound { value ; valid = true } 51 51 - in 52 52 - let node = Node { left; right; parent; version = 0; size = 0; binding } in 53 53 - set_parent left ~parent:node; 54 54 - set_parent right ~parent:node; 55 55 - node 56 56 - 57 57 - let rec raw_invalidate = function 58 58 - | Node { size = 0; _ } -> () 59 59 - | Node t -> 60 60 - t.size <- 0; 61 61 - raw_invalidate t.parent 62 62 - | Root r -> 63 63 - List.iter Lwd.invalidate r.on_invalidate 64 64 - | Leaf -> assert false 65 65 - 66 66 - let prepend ?set = function 67 67 - | Root r as parent -> 68 68 - raw_invalidate parent; 69 69 - let node = make_node set ~left:Leaf ~right:r.child ~parent in 70 70 - r.child <- node; 71 71 - node 72 72 - | Leaf | Node _ -> assert false 73 73 - 74 74 - let prepend' x set = ignore (prepend x ~set) 75 75 - 76 76 - let append ?set = function 77 77 - | Root r as parent -> 78 78 - raw_invalidate parent; 79 79 - let node = make_node set ~left:r.child ~right:Leaf ~parent in 80 80 - r.child <- node; 81 81 - node 82 82 - | Leaf | Node _ -> assert false 83 83 - 84 84 - let append' x set = ignore (append x ~set) 85 85 - 86 86 - let before ?set = function 87 87 - | Node { parent = Leaf ; _ } | Leaf -> Leaf 88 88 - | Node n as parent -> 89 89 - raw_invalidate parent; 90 90 - let node = make_node set ~left:n.left ~right:Leaf ~parent in 91 91 - n.left <- node; 92 92 - node 93 93 - | Root _ -> assert false 94 94 - 95 95 - let after ?set = function 96 96 - | Node { parent = Leaf ; _ } | Leaf -> Leaf 97 97 - | Node n as parent -> 98 98 - raw_invalidate parent; 99 99 - let node = make_node set ~left:Leaf ~right:n.right ~parent in 100 100 - n.right <- node; 101 101 - node 102 102 - | Root _ -> assert false 103 103 - 104 104 - let get = function 105 105 - | Node { binding = Bound { value ; _ } ; _ } -> Some value 106 106 - | Leaf | Root _ | Node { binding = Unbound ; _ } -> None 107 107 - 108 108 - let invalidate_binding = function 109 109 - | Unbound -> () 110 110 - | Bound b -> b.valid <- false 111 111 - 112 112 - let set_binding x = function 113 113 - | Root _ -> assert false 114 114 - | Leaf | Node { parent = Leaf; _ } -> () 115 115 - | Node n as t -> 116 116 - raw_invalidate t; 117 117 - invalidate_binding n.binding; 118 118 - n.binding <- x 119 119 - 120 120 - let set t value = set_binding (Bound { value; valid = true }) t 121 121 - let unset t = set_binding Unbound t 122 122 - 123 123 - let is_bound = function 124 124 - | Leaf | Node { parent = Leaf; _ } -> false 125 125 - | Root _ | Node _ -> true 126 126 - 127 127 - let rec join left = function 128 128 - | Root _ | Leaf -> assert false 129 129 - | Node ({ left = Leaf; _ } as n) as self -> 130 130 - n.left <- left; 131 131 - set_parent left ~parent:self; 132 132 - self 133 133 - | Node node -> 134 134 - join left node.left 135 135 - 136 136 - let remove = function 137 137 - | Root _ | Leaf | Node {parent = Leaf; _} -> () 138 138 - | Node ({left; right; parent; _} as n) as t -> 139 139 - invalidate_binding n.binding; 140 140 - n.left <- Leaf; 141 141 - n.right <- Leaf; 142 142 - n.parent <- Leaf; 143 143 - n.binding <- Unbound; 144 144 - n.version <- max_int; 145 145 - let join, invalid = match left, right with 146 146 - | Leaf, other | other, Leaf -> (other, parent) 147 147 - | _ -> (right, join left right) 148 148 - in 149 149 - reparent ~parent ~oldchild:t ~newchild:join; 150 150 - set_parent join ~parent; 151 151 - raw_invalidate invalid 152 152 - 153 153 - let rec clear = function 154 154 - | Leaf -> () 155 155 - | Node ({left; right; _} as n) -> 156 156 - invalidate_binding n.binding; 157 157 - n.left <- Leaf; 158 158 - n.right <- Leaf; 159 159 - n.parent <- Leaf; 160 160 - n.binding <- Unbound; 161 161 - n.version <- max_int; 162 162 - clear left; 163 163 - clear right 164 164 - | Root r as root -> 165 165 - let child = r.child in 166 166 - r.child <- Leaf; 167 167 - clear child; 168 168 - raw_invalidate root 169 169 - 170 170 - (* Tree balancing *) 171 171 - 172 172 - let size = function 173 173 - | Node node -> 174 174 - assert (node.size <> 0); 175 175 - node.size 176 176 - | Leaf -> 0 177 177 - | Root _ -> assert false 178 178 - 179 179 - (** [smaller_ell smin smax] iff 180 180 - - [smin] is less than [smax] 181 181 - - [smin] and [smax] differs by less than two magnitude orders, i.e 182 182 - msbs(smin) >= msbs(smax) - 1 183 183 - where msbs is the index of the most significant bit set *) 184 184 - let smaller_ell smin smax = (smin < smax) && ((smin land smax) lsl 1 < smax) 185 185 - 186 186 - (** [disbalanced smin smax] check if two sub-trees of size [smin] and [smax], 187 187 - are disbalanczed. That is, msbs(smin) < msbs(smax) - 1 *) 188 188 - let disbalanced smin smax = smaller_ell smin (smax lsr 1) 189 189 - 190 190 - let reparent ~parent ~oldchild ~newchild = 191 191 - match parent with 192 192 - | Root r -> 193 193 - assert (r.child == oldchild); 194 194 - r.child <- newchild; 195 195 - | Node n when n.left == oldchild -> 196 196 - n.left <- newchild 197 197 - | Node n when n.right == oldchild -> 198 198 - n.right <- newchild 199 199 - | Leaf | Node _ -> assert false 200 200 - 201 201 - let rec rot_left version = function 202 202 - | Node ({ right = (Node rn) as r; _} as sn) as s -> 203 203 - let parent = sn.parent in 204 204 - let rl = match rn.left with 205 205 - | Root _ -> assert false 206 206 - | Leaf -> Leaf 207 207 - | (Node rln) as rl -> 208 208 - rln.parent <- s; 209 209 - rl 210 210 - in 211 211 - rn.left <- s; 212 212 - sn.right <- rl; 213 213 - sn.parent <- r; 214 214 - rn.parent <- parent; 215 215 - reparent ~parent ~oldchild:s ~newchild:r; 216 216 - ignore (balance version s); 217 217 - balance version r 218 218 - | _ -> assert false 219 219 - 220 220 - and rot_right version = function 221 221 - | Node ({ left = (Node ln) as l; _} as sn) as s -> 222 222 - let parent = sn.parent in 223 223 - let lr = match ln.right with 224 224 - | Root _ -> assert false 225 225 - | Leaf -> Leaf 226 226 - | (Node lrn) as lr -> 227 227 - lrn.parent <- s; 228 228 - lr 229 229 - in 230 230 - ln.right <- s; 231 231 - sn.left <- lr; 232 232 - sn.parent <- l; 233 233 - ln.parent <- parent; 234 234 - reparent ~parent ~oldchild:s ~newchild:l; 235 235 - ignore (balance version s); 236 236 - balance version l 237 237 - | _ -> assert false 238 238 - 239 239 - and inc_left version = function 240 240 - | Root _ | Leaf -> assert false 241 241 - | Node {right; _} as self -> 242 242 - begin match right with 243 243 - | Node rn when smaller_ell (size rn.right) (size rn.left) -> 244 244 - ignore (rot_right version right) 245 245 - | _ -> () 246 246 - end; 247 247 - rot_left version self 248 248 - 249 249 - and inc_right version = function 250 250 - | Root _ | Leaf -> assert false 251 251 - | Node {left; _} as self -> 252 252 - begin match left with 253 253 - | Node ln when smaller_ell (size ln.left) (size ln.right) -> 254 254 - ignore (rot_left version left) 255 255 - | _ -> () 256 256 - end; 257 257 - rot_right version self 258 258 - 259 259 - and balance version = function 260 260 - | Root _ | Leaf -> assert false 261 261 - | Node node as self -> 262 262 - let sl = size node.left and sr = size node.right in 263 263 - if sl < sr then ( 264 264 - if disbalanced sl sr 265 265 - then inc_left version self 266 266 - else (node.version <- version; node.size <- 1 + sl + sr; self) 267 267 - ) else ( 268 268 - if disbalanced sr sl 269 269 - then inc_right version self 270 270 - else (node.version <- version; node.size <- 1 + sl + sr; self) 271 271 - ) 272 272 - 273 273 - let rec compute_sub_size version = function 274 274 - | Root _ -> () 275 275 - | Leaf -> () 276 276 - | Node node as self -> 277 277 - if node.size = 0 then 278 278 - match node.left with 279 279 - | Node {size = 0; _} -> 280 280 - compute_sub_size version node.left 281 281 - | _ -> 282 282 - match node.right with 283 283 - | Node {size = 0; _} -> 284 284 - compute_sub_size version node.right 285 285 - | _ -> 286 286 - let parent = node.parent in 287 287 - ignore (balance version self); 288 288 - compute_sub_size version parent 289 289 - 290 290 - let rec reset_version version = function 291 291 - | Leaf -> () 292 292 - | Node n -> 293 293 - n.version <- version; 294 294 - reset_version version n.left; 295 295 - reset_version version n.right 296 296 - | Root _ -> assert false 297 297 - 298 298 - let rebalance = function 299 299 - | Root r -> 300 300 - begin match r.child with 301 301 - | Node { size = 0; _ } -> 302 302 - let version = succ r.version in 303 303 - let version = 304 304 - if version = max_int then ( 305 305 - r.generation <- ref (); 306 306 - reset_version 0 r.child; 307 307 - 0 308 308 - ) 309 309 - else version 310 310 - in 311 311 - r.version <- version; 312 312 - compute_sub_size version r.child; 313 313 - version 314 314 - | Node _ | Leaf -> r.version 315 315 - | Root _ -> assert false 316 316 - end 317 317 - | _ -> assert false 318 318 - 319 319 - let plus (zero, plus) x y = 320 320 - if x == zero then y 321 321 - else if y == zero then x 322 322 - else plus x y 323 323 - 324 324 - type ('a, 'b) reduction_tree = 325 325 - | Red_leaf 326 326 - | Red_node of { 327 327 - cell: 'a row; 328 328 - binding: 'a binding; 329 329 - reduction: 'b; 330 330 - aggregate: 'b; 331 331 - left : ('a, 'b) reduction_tree; 332 332 - right : ('a, 'b) reduction_tree; 333 333 - } 334 334 - 335 335 - type ('a, 'b) reduction = { 336 336 - mutable version: int; 337 337 - source: 'a tree; 338 338 - mutable result : ('a, 'b) reduction_tree; 339 339 - mutable generation: unit ref; 340 340 - mapper: 'a row -> 'a -> 'b; 341 341 - monoid: 'b Lwd_utils.monoid; 342 342 - } 343 343 - 344 344 - 345 345 - let extract_bindings tree = 346 346 - let rec aux acc = function 347 347 - | Red_leaf -> acc 348 348 - | Red_node rnode -> 349 349 - let acc = aux acc rnode.right in 350 350 - let acc = match rnode.binding with 351 351 - | Unbound -> acc 352 352 - | Bound { valid = false; _ } -> acc 353 353 - | _ -> (rnode.binding, rnode.reduction) :: acc 354 354 - in 355 355 - aux acc rnode.left 356 356 - in 357 357 - aux [] tree 358 358 - 359 359 - let full_rebuild red tree = 360 360 - let bindings = ref (extract_bindings red.result) in 361 361 - let rec aux = function 362 362 - | Node node as cell -> 363 363 - let left = aux node.left in 364 364 - let reduction = 365 365 - match node.binding, !bindings with 366 366 - | Unbound, _ -> fst red.monoid 367 367 - | binding, ((binding', reduction) :: bindings') 368 368 - when binding == binding' -> 369 369 - bindings := bindings'; 370 370 - reduction 371 371 - | Bound b, _ -> assert b.valid; red.mapper cell b.value 372 372 - in 373 373 - let right = aux node.right in 374 374 - let aggregate = match left with 375 375 - | Red_leaf -> reduction 376 376 - | Red_node r -> plus red.monoid r.aggregate reduction 377 377 - in 378 378 - let aggregate = match right with 379 379 - | Red_leaf -> aggregate 380 380 - | Red_node r -> plus red.monoid aggregate r.aggregate 381 381 - in 382 382 - Red_node { 383 383 - cell; 384 384 - binding = node.binding; 385 385 - reduction; 386 386 - aggregate; 387 387 - left; 388 388 - right; 389 389 - } 390 390 - | Leaf -> Red_leaf 391 391 - | Root _ -> assert false 392 392 - in 393 393 - let result = aux tree in 394 394 - assert (!bindings = []); 395 395 - result 396 396 - 397 397 - let extract_fringe version tree = 398 398 - let rec aux acc = function 399 399 - | Red_leaf -> acc 400 400 - | Red_node rnode as tree -> 401 401 - match rnode.cell with 402 402 - | Node node when node.version <= version -> tree :: acc 403 403 - | _ -> 404 404 - let acc = aux acc rnode.right in 405 405 - let acc = match rnode.binding with 406 406 - | Unbound -> acc 407 407 - | Bound { valid = false; _ } -> acc 408 408 - | _ -> tree :: acc 409 409 - in 410 410 - aux acc rnode.left 411 411 - in 412 412 - aux [] tree 413 413 - 414 414 - let incremental_rebuild red version tree = 415 415 - let fringe = ref (extract_fringe version red.result) in 416 416 - let rec aux = function 417 417 - | Node node as cell when node.version <= version -> 418 418 - begin match !fringe with 419 419 - | (Red_node rnode as reduction) :: fringe' -> 420 420 - assert (rnode.cell == cell); 421 421 - fringe := fringe'; 422 422 - reduction 423 423 - | _ -> assert false 424 424 - end 425 425 - | Node node as cell -> 426 426 - let left = aux node.left in 427 427 - let reduction = 428 428 - match node.binding, !fringe with 429 429 - | Unbound, _ -> fst red.monoid 430 430 - | binding, (Red_node rnode :: fringe') 431 431 - when binding == rnode.binding -> 432 432 - fringe := fringe'; 433 433 - rnode.reduction 434 434 - | Bound b, _ -> 435 435 - assert b.valid; red.mapper cell b.value 436 436 - in 437 437 - let right = aux node.right in 438 438 - let aggregate = match left with 439 439 - | Red_leaf -> reduction 440 440 - | Red_node r -> plus red.monoid r.aggregate reduction 441 441 - in 442 442 - let aggregate = match right with 443 443 - | Red_leaf -> aggregate 444 444 - | Red_node r -> plus red.monoid aggregate r.aggregate 445 445 - in 446 446 - Red_node { 447 447 - cell; 448 448 - binding = node.binding; 449 449 - reduction; 450 450 - aggregate; 451 451 - left; 452 452 - right; 453 453 - } 454 454 - | Root _ | Leaf -> Red_leaf 455 455 - in 456 456 - let result = aux tree in 457 457 - assert (!fringe = []); 458 458 - result 459 459 - 460 460 - let eval red = 461 461 - match red.source with 462 462 - | Leaf | Node _ -> assert false 463 463 - | Root root -> 464 464 - let version = rebalance red.source in 465 465 - if true then ( 466 466 - if red.generation != root.generation then ( 467 467 - red.generation <- root.generation; 468 468 - red.result <- full_rebuild red root.child; 469 469 - ) else ( 470 470 - red.result <- incremental_rebuild red red.version root.child 471 471 - ); 472 472 - ) else ( 473 473 - red.result <- full_rebuild red root.child; 474 474 - ); 475 475 - red.version <- version; 476 476 - match red.result with 477 477 - | Red_leaf -> fst red.monoid 478 478 - | Red_node r -> r.aggregate 479 479 - 480 480 - let opaque : 'a Lwd.prim -> Obj.t Lwd.prim = Obj.magic 481 481 - 482 482 - let map_reduce mapper monoid source = 483 483 - let reduction = { 484 484 - source; mapper; monoid; 485 485 - result = Red_leaf; 486 486 - generation = not_origin; 487 487 - version = 0; 488 488 - } in 489 489 - let prim = Lwd.prim 490 490 - ~acquire:(fun self -> 491 491 - match reduction.source with 492 492 - | Leaf | Node _ -> assert false 493 493 - | Root root -> 494 494 - root.on_invalidate <- opaque self :: root.on_invalidate; 495 495 - reduction 496 496 - ) 497 497 - ~release:(fun self reduction -> 498 498 - match reduction.source with 499 499 - | Leaf | Node _ -> assert false 500 500 - | Root root -> 501 501 - root.on_invalidate <- 502 502 - List.filter ((!=) (opaque self)) root.on_invalidate 503 503 - ) 504 504 - in 505 505 - Lwd.map ~f:eval (Lwd.get_prim prim) 506 506 - 507 507 - let reduce monoid source = map_reduce (fun _ x -> x) monoid source 508 508 - 509 509 - let rec iter f = function 510 510 - | Leaf -> () 511 511 - | Node t -> 512 512 - iter f t.left; 513 513 - begin match t.binding with 514 514 - | Bound x -> f x.value 515 515 - | Unbound -> () 516 516 - end; 517 517 - iter f t.right 518 518 - | Root t -> 519 519 - iter f t.child 520 520 - 521 521 - let rec left_most : 'a row -> 'a row option = function 522 522 - | Root _ -> assert false 523 523 - | Leaf -> None 524 524 - | Node n as self -> 525 525 - match left_most n.left with 526 526 - | Some _ as x -> x 527 527 - | None -> Some self 528 528 - 529 529 - let rec right_most : 'a row -> 'a row option = function 530 530 - | Root _ -> assert false 531 531 - | Leaf -> None 532 532 - | Node n as self -> 533 533 - match right_most n.right with 534 534 - | Some _ as x -> x 535 535 - | None -> Some self 536 536 - 537 537 - let first : 'a t -> 'a row option = function 538 538 - | Leaf | Node _ -> assert false 539 539 - | Root root -> left_most root.child 540 540 - 541 541 - let last : 'a t -> 'a row option = function 542 542 - | Leaf | Node _ -> assert false 543 543 - | Root root -> right_most root.child 544 544 - 545 545 - let next : 'a row -> 'a row option = function 546 546 - | Root _ -> assert false 547 547 - | Leaf -> None 548 548 - | Node n as self -> 549 549 - match left_most n.right with 550 550 - | Some _ as x -> x 551 551 - | None -> 552 552 - let rec walk_root self = function 553 553 - | Leaf -> assert false 554 554 - | Root _ -> None 555 555 - | Node n' as parent -> 556 556 - if n'.left == self then Some parent else ( 557 557 - assert (n'.right == self); 558 558 - walk_root parent n'.parent 559 559 - ) 560 560 - in 561 561 - walk_root self n.parent 562 562 - 563 563 - let prev : 'a row -> 'a row option = function 564 564 - | Root _ -> assert false 565 565 - | Leaf -> None 566 566 - | Node n as self -> 567 567 - match right_most n.left with 568 568 - | Some _ as x -> x 569 569 - | None -> 570 570 - let rec walk_root self = function 571 571 - | Leaf -> assert false 572 572 - | Root _ -> None 573 573 - | Node n' as parent -> 574 574 - if n'.right == self then Some parent else ( 575 575 - assert (n'.left == self); 576 576 - walk_root parent n'.parent 577 577 - ) 578 578 - in 579 579 - walk_root self n.parent

-102

forks/lwd/lib/lwd/lwd_table.mli

reviewed

··· 1 1 - (** {1 Table manipulation} 2 2 - 3 3 - [Lwd_table] is an ordered collection with an impure interface. 4 4 - It is designed to be efficient in an interactive setting. 5 5 - 6 6 - The interface mimics the one of a doubly-linked lists: from a node, called 7 7 - row, you can iterate backward and forward, insert and delete other nodes, 8 8 - and change the value it is bound to. 9 9 - 10 10 - The sequence of nodes can be observed by map/reduce operations, that will 11 11 - be recomputed efficiently when sequence changes. 12 12 - *) 13 13 - 14 14 - type 'a t 15 15 - type 'a row 16 16 - (** The type of tables *) 17 17 - 18 18 - val make : unit -> 'a t 19 19 - (** Create a new table *) 20 20 - 21 21 - (** {2 Inserting rows} *) 22 22 - 23 23 - val prepend : ?set:'a -> 'a t -> 'a row 24 24 - (** Insert and return a new row at the start of a table. 25 25 - It can be optionnally initialized to the value of [set]. *) 26 26 - 27 27 - val append : ?set:'a -> 'a t -> 'a row 28 28 - (** Insert and return a new row at the end of a table. 29 29 - It can be optionnally initialized to the value of [set]. *) 30 30 - 31 31 - val prepend' : 'a t -> 'a -> unit 32 32 - (* Insert a new initialized row at start of a table *) 33 33 - 34 34 - val append' : 'a t -> 'a -> unit 35 35 - (* Insert a new initialized row at end of a table *) 36 36 - 37 37 - val before : ?set:'a -> 'a row -> 'a row 38 38 - (** Insert and return a new row just before an existing row. 39 39 - It can be optionnally initialized to the value of [set]. 40 40 - 41 41 - If the input row is unbound ([is_bound] returns false), the returned row is 42 42 - too. 43 43 - *) 44 44 - 45 45 - val after : ?set:'a -> 'a row -> 'a row 46 46 - (** Insert and return a new row just after an existing row. 47 47 - It can be optionnally initialized to the value of [set]. 48 48 - 49 49 - If the input row is unbound ([is_bound] returns false), the returned row is 50 50 - too. 51 51 - *) 52 52 - 53 53 - (** {2 Iterating over rows} *) 54 54 - 55 55 - val first : 'a t -> 'a row option 56 56 - (** Returns the first row of a table, or [None] if the table is empty *) 57 57 - 58 58 - val last : 'a t -> 'a row option 59 59 - (** Returns the last row of a table, or [None] if the table is empty *) 60 60 - 61 61 - val next : 'a row -> 'a row option 62 62 - (** Returns the row next to another one, or [None] if the input row is unbound 63 63 - or is the last row *) 64 64 - 65 65 - val prev : 'a row -> 'a row option 66 66 - (** Returns the row just before another one, or [None] if the input row is 67 67 - unbound or is the first row *) 68 68 - 69 69 - (** {2 Accessing and changing row contents} *) 70 70 - 71 71 - val get : 'a row -> 'a option 72 72 - (** Get the value associated with a row, if any, or [None] if the row is 73 73 - unbound *) 74 74 - 75 75 - val set : 'a row -> 'a -> unit 76 76 - (** Set the value associated with a row, or do nothing if the row is unbound *) 77 77 - 78 78 - val unset : 'a row -> unit 79 79 - (** Unset the value associated with a row *) 80 80 - 81 81 - (** {2 Removing rows} *) 82 82 - 83 83 - val is_bound : 'a row -> bool 84 84 - (** Returns [true] iff the row is bound in a table (it has not beem [remove]d 85 85 - yet, the table has not been [clear]ed) *) 86 86 - 87 87 - val remove : 'a row -> unit 88 88 - (** [remove] a row from its table, [is_bound] will be [true] after that *) 89 89 - 90 90 - val clear : 'a t -> unit 91 91 - (** Remove all rows from a table *) 92 92 - 93 93 - (** {2 Observing table contents} *) 94 94 - 95 95 - val reduce : 'a Lwd_utils.monoid -> 'a t -> 'a Lwd.t 96 96 - (** Observe the content of a table by reducing it with a monoid *) 97 97 - 98 98 - val map_reduce : ('a row -> 'a -> 'b) -> 'b Lwd_utils.monoid -> 'a t -> 'b Lwd.t 99 99 - (** Observe the content of a table by mapping and reducing it *) 100 100 - 101 101 - val iter : ('a -> unit) -> 'a t -> unit 102 102 - (** Immediate, non reactive, iteration over elements of a table *)

-474

forks/lwd/lib/lwd/lwd_trace_debug.ml

reviewed

··· 1 1 - type 'a t = 2 2 - | Pure of 'a 3 3 - | Impure : { 4 4 - mutable value : 'a option; 5 5 - mutable trace : trace; 6 6 - mutable trace_idx : trace_idx; 7 7 - desc: 'a desc; 8 8 - } -> 'a t 9 9 - | Root : { 10 10 - mutable on_invalidate : 'a -> unit; 11 11 - mutable value : 'a option; 12 12 - child : 'a t; 13 13 - mutable trace_idx : trace_idx; 14 14 - } -> 'a t 15 15 - 16 16 - and _ desc = 17 17 - | Map : 'a t * ('a -> 'b) -> 'b desc 18 18 - | Map2 : 'a t * 'b t * ('a -> 'b -> 'c) -> 'c desc 19 19 - | Pair : 'a t * 'b t -> ('a * 'b) desc 20 20 - | App : ('a -> 'b) t * 'a t -> 'b desc 21 21 - | Bind : { child : 'a t; map : 'a -> 'b t; 22 22 - mutable intermediate : 'b t option } -> 'b desc 23 23 - | Var : { mutable binding : 'a } -> 'a desc 24 24 - | Prim : { acquire : unit -> 'a; 25 25 - release : 'a -> unit; 26 26 - mutable acquired : 'a option } -> 'a desc 27 27 - 28 28 - and trace = 29 29 - | T0 30 30 - (*| T1 : _ t -> trace 31 31 - | T2 : _ t * _ t -> trace 32 32 - | T3 : _ t * _ t * _ t -> trace 33 33 - | T4 : _ t * _ t * _ t * _ t -> trace*) 34 34 - | Tn : { mutable active : int; mutable count : int; 35 35 - mutable entries : Obj.t t array } -> trace 36 36 - 37 37 - and trace_idx = 38 38 - | I0 39 39 - | I1 : { mutable idx : int ; 40 40 - obj : 'a t; 41 41 - mutable next : trace_idx } -> trace_idx 42 42 - 43 43 - (* Basic combinators *) 44 44 - let return x = Pure x 45 45 - let pure x = Pure x 46 46 - 47 47 - let dummy = Pure (Obj.repr ()) 48 48 - 49 49 - let impure desc = 50 50 - Impure { value = None; trace = T0; desc; trace_idx = I0 } 51 51 - 52 52 - let map f x = impure (Map (x, f)) 53 53 - let map2 f x y = impure (Map2 (x, y, f)) 54 54 - let map' x f = impure (Map (x, f)) 55 55 - let map2' x y f = impure (Map2 (x, y, f)) 56 56 - let pair x y = impure (Pair (x, y)) 57 57 - let app f x = impure (App (f, x)) 58 58 - let bind child map = impure (Bind { child; map; intermediate = None }) 59 59 - let id x = x 60 60 - let join child = impure (Bind { child; map = id; intermediate = None }) 61 61 - 62 62 - (* Management of trace indexes *) 63 63 - 64 64 - external t_equal : _ t -> _ t -> bool = "%eq" 65 65 - external obj_t : 'a t -> Obj.t t = "%identity" 66 66 - 67 67 - let debug_trace_idx (type a) (self : a t) idx = 68 68 - let rec gather = function 69 69 - | I0 -> [] 70 70 - | I1 {obj = obj1; next = I1 {obj = obj2; _}; _} 71 71 - when t_equal obj1 obj2 && ( 72 72 - let self = match self with 73 73 - | Pure _ | Root _ -> assert false 74 74 - | Impure t -> 75 75 - match t.desc with 76 76 - | Map (t1, _) -> 77 77 - Printf.sprintf "Map (%x, _)" (Obj.magic t1) 78 78 - | Map2 (t1, t2, _) -> 79 79 - Printf.sprintf "Map2 (%x, %x, _)" (Obj.magic t1) (Obj.magic t2) 80 80 - | Pair (t1, t2) -> 81 81 - Printf.sprintf "Pair (%x, %x)" (Obj.magic t1) (Obj.magic t2) 82 82 - | App (t1, t2) -> 83 83 - Printf.sprintf "App (%x, %x)" (Obj.magic t1) (Obj.magic t2) 84 84 - | Bind {child; intermediate = None; _} -> 85 85 - Printf.sprintf "Bind (%x)" (Obj.magic child) 86 86 - | Bind {child; intermediate = Some i; _} -> 87 87 - Printf.sprintf "Bind (%x, %x)" (Obj.magic child) (Obj.magic i) 88 88 - | Var _ -> "Var _" 89 89 - | Prim _ -> "Prim _" 90 90 - in 91 91 - Printf.eprintf "%x: %s\n" (Obj.magic obj1) self; 92 92 - false 93 93 - ) -> assert false 94 94 - | I1 t -> 95 95 - begin match t.obj with 96 96 - | Impure {trace = Tn {active; count; entries}; _} -> 97 97 - if not (t.idx < count) then ( 98 98 - prerr_endline 99 99 - (Printexc.raw_backtrace_to_string (Printexc.get_callstack 10)); 100 100 - assert false 101 101 - ); 102 102 - assert (entries.(t.idx) == obj_t self); 103 103 - if t.idx > active then ( 104 104 - match self with 105 105 - | Root { value = None; _ } | Impure { value = None; _} -> () 106 106 - | _ -> assert false 107 107 - ) 108 108 - | Impure {trace = T0; _} -> () (* invariant temporary broken, can't do much *) 109 109 - | _ -> 110 110 - prerr_endline 111 111 - (Printexc.raw_backtrace_to_string (Printexc.get_callstack 10)); 112 112 - assert false 113 113 - end; 114 114 - Printf.sprintf "%x@%d" (Obj.magic t.obj) t.idx :: gather t.next 115 115 - in 116 116 - Printf.eprintf "idx : [%s]\n" (String.concat "; " (gather idx)); 117 117 - idx 118 118 - 119 119 - let debug_trace = function 120 120 - | T0 -> Printf.eprintf "empty trace" 121 121 - | Tn tn -> 122 122 - Printf.eprintf "trace: {active = %d; count = %d; capacity = %d}\n" 123 123 - tn.active tn.count (Array.length tn.entries) 124 124 - 125 125 - let add_idx obj idx = function 126 126 - | Pure _ -> assert false 127 127 - | Root t' as self-> 128 128 - t'.trace_idx <- debug_trace_idx self (I1 { idx; obj; next = t'.trace_idx }) 129 129 - | Impure t' as self-> 130 130 - t'.trace_idx <- debug_trace_idx self (I1 { idx; obj; next = t'.trace_idx }) 131 131 - 132 132 - let rec rem_idx obj = function 133 133 - | I0 -> assert false 134 134 - | I1 t as self -> 135 135 - if t_equal t.obj obj 136 136 - then (t.idx, t.next) 137 137 - else 138 138 - let idx, result = rem_idx obj t.next in 139 139 - t.next <- result; 140 140 - (idx, self) 141 141 - 142 142 - let rem_idx obj = function 143 143 - | Pure _ -> assert false 144 144 - | Root t' as self -> 145 145 - let idx, trace_idx = rem_idx obj t'.trace_idx in 146 146 - t'.trace_idx <- debug_trace_idx self trace_idx; idx 147 147 - | Impure t' as self -> 148 148 - let idx, trace_idx = rem_idx obj t'.trace_idx in 149 149 - t'.trace_idx <- debug_trace_idx self trace_idx; idx 150 150 - 151 151 - let rec mov_idx obj oldidx newidx = function 152 152 - | I0 -> assert false 153 153 - | I1 t -> 154 154 - if t.idx = oldidx && t_equal t.obj obj 155 155 - then t.idx <- newidx 156 156 - else mov_idx obj oldidx newidx t.next 157 157 - 158 158 - let mov_idx obj oldidx newidx = function 159 159 - | Pure _ -> assert false 160 160 - | Root t' -> mov_idx obj oldidx newidx t'.trace_idx 161 161 - | Impure t' -> mov_idx obj oldidx newidx t'.trace_idx 162 162 - 163 163 - let rec get_idx obj = function 164 164 - | I0 -> assert false 165 165 - | I1 t -> 166 166 - if t_equal t.obj obj 167 167 - then t.idx 168 168 - else get_idx obj t.next 169 169 - 170 170 - let get_idx obj = function 171 171 - | Pure _ -> assert false 172 172 - | Root t' as self -> get_idx obj (debug_trace_idx self t'.trace_idx) 173 173 - | Impure t' as self -> get_idx obj (debug_trace_idx self t'.trace_idx) 174 174 - 175 175 - (* Propagating invalidation *) 176 176 - let rec invalidate_node : type a . a t -> unit = function 177 177 - | Pure _ -> assert false 178 178 - | Root { value = None; _ } -> () 179 179 - | Root ({ value = Some x; _ } as t) -> 180 180 - t.value <- None; 181 181 - t.on_invalidate x 182 182 - | Impure t -> 183 183 - begin match t.value with 184 184 - | None -> () 185 185 - | Some _ -> 186 186 - t.value <- None; 187 187 - debug_trace t.trace; 188 188 - invalidate_trace t.trace 189 189 - end 190 190 - 191 191 - and invalidate_trace = function 192 192 - | T0 -> () 193 193 - (*| T1 x -> invalidate_node x 194 194 - | T2 (x, y) -> 195 195 - invalidate_node x; 196 196 - invalidate_node y 197 197 - | T3 (x, y, z) -> 198 198 - invalidate_node x; 199 199 - invalidate_node y; 200 200 - invalidate_node z 201 201 - | T4 (x, y, z, w) -> 202 202 - invalidate_node x; 203 203 - invalidate_node y; 204 204 - invalidate_node z; 205 205 - invalidate_node w*) 206 206 - | Tn t -> 207 207 - let active = t.active in 208 208 - t.active <- 0; 209 209 - for i = 0 to active - 1 do 210 210 - invalidate_node t.entries.(i) 211 211 - done 212 212 - 213 213 - (* Variables *) 214 214 - type 'a var = 'a t 215 215 - let var x = impure (Var {binding = x}) 216 216 - let get x = x 217 217 - 218 218 - let set vx x = 219 219 - match vx with 220 220 - | Impure ({desc = Var v; _}) -> 221 221 - invalidate_node vx; 222 222 - v.binding <- x 223 223 - | _ -> assert false 224 224 - 225 225 - let peek = function 226 226 - | Impure ({desc = Var v; _}) -> v.binding 227 227 - | _ -> assert false 228 228 - 229 229 - (* Primitives *) 230 230 - type 'a prim = 'a t 231 231 - let prim ~acquire ~release = 232 232 - impure (Prim { acquire; release; acquired = None }) 233 233 - let get_prim x = x 234 234 - let invalidate = invalidate_node 235 235 - 236 236 - let rec sub_release : type a b . a t -> b t -> unit = fun origin -> 237 237 - function 238 238 - | Root _ -> assert false 239 239 - | Pure _ -> () 240 240 - | Impure t as self -> 241 241 - let trace = match t.trace with 242 242 - | T0 -> assert false 243 243 - (*| T1 x -> assert (t_equal x origin); T0 244 244 - | T2 (x, y) -> 245 245 - if t_equal x origin then T1 y 246 246 - else if t_equal y origin then T1 x 247 247 - else assert false 248 248 - | T3 (x, y, z) -> 249 249 - if t_equal x origin then T2 (y, z) 250 250 - else if t_equal y origin then T2 (x, z) 251 251 - else if t_equal z origin then T2 (x, y) 252 252 - else assert false 253 253 - | T4 (x, y, z, w) -> 254 254 - if t_equal x origin then T3 (y, z, w) 255 255 - else if t_equal y origin then T3 (x, z, w) 256 256 - else if t_equal z origin then T3 (x, y, w) 257 257 - else assert false*) 258 258 - | Tn tn as trace -> 259 259 - let revidx = rem_idx self origin in 260 260 - assert (t_equal tn.entries.(revidx) origin); 261 261 - let count = tn.count - 1 in 262 262 - tn.count <- count; 263 263 - if revidx < count then ( 264 264 - let obj = tn.entries.(count) in 265 265 - tn.entries.(revidx) <- obj; 266 266 - mov_idx self count revidx obj 267 267 - ); 268 268 - tn.entries.(count) <- dummy; 269 269 - if tn.active > count then tn.active <- count; 270 270 - (*if count = 4 then ( 271 271 - let a = tn.entries.(0) and b = tn.entries.(1) in 272 272 - let c = tn.entries.(2) and d = tn.entries.(3) in 273 273 - ignore (rem_idx self a : int); 274 274 - ignore (rem_idx self b : int); 275 275 - ignore (rem_idx self c : int); 276 276 - ignore (rem_idx self d : int); 277 277 - T4 (a, b, c, d)*) 278 278 - if count = 0 then ( 279 279 - T0 280 280 - ) else 281 281 - let len = Array.length tn.entries in 282 282 - if count <= len lsr 2 then 283 283 - Tn { active = tn.active; count = tn.count; 284 284 - entries = Array.sub tn.entries 0 (len lsr 1) } 285 285 - else 286 286 - trace 287 287 - in 288 288 - t.trace <- trace; 289 289 - match trace with 290 290 - | T0 -> 291 291 - t.value <- None; 292 292 - begin match t.desc with 293 293 - | Map (x, _) -> sub_release self x 294 294 - | Map2 (x, y, _) -> 295 295 - sub_release self x; 296 296 - sub_release self y 297 297 - | Pair (x, y) -> 298 298 - sub_release self x; 299 299 - sub_release self y 300 300 - | App (x, y) -> 301 301 - sub_release self x; 302 302 - sub_release self y 303 303 - | Bind ({ child; intermediate; map = _ } as t) -> 304 304 - sub_release self child; 305 305 - begin match intermediate with 306 306 - | None -> () 307 307 - | Some child' -> 308 308 - t.intermediate <- None; 309 309 - sub_release self child' 310 310 - end 311 311 - | Var _ -> () 312 312 - | Prim t -> 313 313 - let x = match t.acquired with None -> assert false | Some x -> x in 314 314 - t.acquired <- None; 315 315 - t.release x 316 316 - end 317 317 - | _ -> () 318 318 - 319 319 - let rec sub_acquire : type a b . a t -> b t -> unit = fun origin -> 320 320 - function 321 321 - | Root _ -> assert false 322 322 - | Pure _ -> () 323 323 - | Impure t as self -> 324 324 - let acquire = match t.trace with T0 -> true | _ -> false in 325 325 - let trace = match t.trace with 326 326 - (*| T0 -> T1 origin 327 327 - | T1 x -> T2 (origin, x) 328 328 - | T2 (x, y) -> T3 (origin, x, y) 329 329 - | T3 (x, y, z) -> T4 (origin, x, y, z) 330 330 - | T4 (x, y, z, w) -> 331 331 - let obj = obj_t origin in 332 332 - let entries = 333 333 - [| obj_t x; obj_t y; obj_t z; obj_t w; obj; dummy; dummy; dummy |] 334 334 - in 335 335 - for i = 0 to 4 do add_idx self i entries.(i) done; 336 336 - Tn { active = 5; count = 5; entries }*) 337 337 - | T0 -> 338 338 - let obj = obj_t origin in 339 339 - let entries = [| obj; dummy; dummy; dummy |] in 340 340 - add_idx self 0 obj; 341 341 - Tn { active = 1; count = 1; entries } 342 342 - | Tn tn as trace -> 343 343 - let index = tn.count in 344 344 - let entries, trace = 345 345 - if index < Array.length tn.entries then ( 346 346 - tn.count <- tn.count + 1; 347 347 - (tn.entries, trace) 348 348 - ) else ( 349 349 - let entries = Array.make (index * 2) dummy in 350 350 - Array.blit tn.entries 0 entries 0 index; 351 351 - (entries, Tn { active = tn.active; count = index + 1; entries }) 352 352 - ) 353 353 - in 354 354 - let obj = obj_t origin in 355 355 - entries.(index) <- obj; 356 356 - add_idx self index obj; 357 357 - trace 358 358 - in 359 359 - t.trace <- trace; 360 360 - if acquire then 361 361 - match t.desc with 362 362 - | Map (x, _) -> sub_acquire self x 363 363 - | Map2 (x, y, _) -> 364 364 - sub_acquire self x; 365 365 - sub_acquire self y 366 366 - | Pair (x, y) -> 367 367 - sub_acquire self x; 368 368 - sub_acquire self y 369 369 - | App (x, y) -> 370 370 - sub_acquire self x; 371 371 - sub_acquire self y 372 372 - | Bind { child; intermediate; map = _ } -> 373 373 - sub_acquire self child; 374 374 - begin match intermediate with 375 375 - | None -> () 376 376 - | Some _ -> assert false 377 377 - end 378 378 - | Var _ -> () 379 379 - | Prim t -> 380 380 - begin match t.acquired with 381 381 - | None -> t.acquired <- Some (t.acquire ()) 382 382 - | Some _ -> () 383 383 - end 384 384 - 385 385 - let rec sub_sample : type a b . a t -> b t -> b = fun origin -> 386 386 - function 387 387 - | Root _ -> assert false 388 388 - | Pure x -> x 389 389 - | Impure t as self -> 390 390 - begin match t.trace with 391 391 - | Tn tn -> 392 392 - let idx = get_idx self origin in 393 393 - let active = tn.active in 394 394 - if idx >= active then 395 395 - tn.active <- active + 1; 396 396 - if idx > active then ( 397 397 - let old = tn.entries.(active) in 398 398 - tn.entries.(idx) <- old; 399 399 - tn.entries.(active) <- obj_t origin; 400 400 - mov_idx self active idx old; 401 401 - mov_idx self idx active origin 402 402 - ) 403 403 - | _ -> () 404 404 - end; 405 405 - match t.value with 406 406 - | Some value -> value 407 407 - | None -> 408 408 - let value : b = match t.desc with 409 409 - | Map (x, f) -> f (sub_sample self x) 410 410 - | Map2 (x, y, f) -> f (sub_sample self x) (sub_sample self y) 411 411 - | Pair (x, y) -> (sub_sample self x, sub_sample self y) 412 412 - | App (f, x) -> (sub_sample self f) (sub_sample self x) 413 413 - | Bind x -> 414 414 - let old_intermediate = x.intermediate in 415 415 - let intermediate = x.map (sub_sample self x.child) in 416 416 - x.intermediate <- Some intermediate; 417 417 - sub_acquire self intermediate; 418 418 - let result = sub_sample self intermediate in 419 419 - begin match old_intermediate with 420 420 - | Some x' -> sub_release self x' 421 421 - | None -> () 422 422 - end; 423 423 - result 424 424 - | Var x -> x.binding 425 425 - | Prim t -> 426 426 - begin match t.acquired with 427 427 - | Some x -> x 428 428 - | None -> assert false 429 429 - end 430 430 - in 431 431 - t.value <- Some value; 432 432 - value 433 433 - 434 434 - type 'a root = 'a t 435 435 - 436 436 - let observe ?(on_invalidate=ignore) child = 437 437 - let root = Root { child; value = None; on_invalidate; trace_idx = I0 } in 438 438 - sub_acquire root child; 439 439 - root 440 440 - 441 441 - let sample = function 442 442 - | Pure _ | Impure _ -> assert false 443 443 - | Root t as self -> 444 444 - match t.value with 445 445 - | Some value -> value 446 446 - | None -> 447 447 - let value = sub_sample self t.child in 448 448 - t.value <- Some value; 449 449 - value 450 450 - 451 451 - let is_damaged = function 452 452 - | Pure _ | Impure _ -> assert false 453 453 - | Root { value = None ; _ } -> true 454 454 - | Root { value = Some _ ; _ } -> false 455 455 - 456 456 - let release = function 457 457 - | Pure _ | Impure _ -> assert false 458 458 - | Root t as self -> 459 459 - begin match t.value with 460 460 - | None -> () 461 461 - | Some _ -> t.value <- None; 462 462 - end; 463 463 - sub_release self t.child 464 464 - 465 465 - let set_on_invalidate x f = 466 466 - match x with 467 467 - | Pure _ | Impure _ -> assert false 468 468 - | Root t -> t.on_invalidate <- f 469 469 - 470 470 - module Infix = struct 471 471 - let (let$) = bind 472 472 - let (and$) = pair 473 473 - let ($=) = set 474 474 - end

-76

forks/lwd/lib/lwd/lwd_utils.ml

reviewed

··· 1 1 - 2 2 - type 'a monoid = 'a * ('a -> 'a -> 'a) 3 3 - 4 4 - let lift_monoid (zero, plus) = 5 5 - (Lwd.return zero, Lwd.map2 ~f:plus) 6 6 - 7 7 - let map_reduce inj (zero, plus) items = 8 8 - let rec cons_monoid c xs v = 9 9 - match xs with 10 10 - | (c', v') :: xs when c = c' -> 11 11 - cons_monoid (c + 1) xs (plus v' v) 12 12 - | xs -> (c, v) :: xs 13 13 - in 14 14 - let cons_monoid xs v = cons_monoid 0 xs (inj v) in 15 15 - match List.fold_left cons_monoid [] items with 16 16 - | [] -> zero 17 17 - | (_,x) :: xs -> 18 18 - List.fold_left (fun acc (_, v) -> plus v acc) x xs 19 19 - 20 20 - let reduce monoid items = map_reduce (fun x -> x) monoid items 21 21 - 22 22 - let rec cons_lwd_monoid plus c xs v = 23 23 - match xs with 24 24 - | (c', v') :: xs when c = c' -> 25 25 - cons_lwd_monoid plus (c + 1) xs (Lwd.map2 ~f:plus v' v) 26 26 - | xs -> (c, v) :: xs 27 27 - 28 28 - let pack (zero, plus) items = 29 29 - match List.fold_left (cons_lwd_monoid plus 0) [] items with 30 30 - | [] -> Lwd.return zero 31 31 - | (_,x) :: xs -> 32 32 - List.fold_left (fun acc (_, v) -> Lwd.map2 ~f:plus v acc) x xs 33 33 - 34 34 - let pack_seq (zero, plus) items = 35 35 - match Seq.fold_left (cons_lwd_monoid plus 0) [] items with 36 36 - | [] -> Lwd.return zero 37 37 - | (_,x) :: xs -> 38 38 - List.fold_left (fun acc (_, v) -> Lwd.map2 ~f:plus v acc) x xs 39 39 - 40 40 - let rec map_l (f:'a -> 'b Lwd.t) (l:'a list) : 'b list Lwd.t = 41 41 - match l with 42 42 - | [] -> Lwd.return [] 43 43 - | x :: tl -> Lwd.map2 ~f:List.cons (f x) (map_l f tl) 44 44 - 45 45 - let flatten_l (l:'a Lwd.t list) : 'a list Lwd.t = 46 46 - map_l (fun x->x) l 47 47 - 48 48 - (** {1 Miscellaneous functions} 49 49 - 50 50 - I don't know where to put these, but they are useful, especially for 51 51 - UI-related computations. 52 52 - *) 53 53 - 54 54 - let mini a b : int = if b < a then b else a 55 55 - 56 56 - let maxi a b : int = if b > a then b else a 57 57 - 58 58 - let clampi x ~min ~max : int = 59 59 - if x < min then 60 60 - min 61 61 - else if x > max then 62 62 - max 63 63 - else 64 64 - x 65 65 - 66 66 - let minf a b : float = if b < a then b else a 67 67 - 68 68 - let maxf a b : float = if b > a then b else a 69 69 - 70 70 - let clampf x ~min ~max : float = 71 71 - if x < min then 72 72 - min 73 73 - else if x > max then 74 74 - max 75 75 - else 76 76 - x

-62

forks/lwd/lib/lwd/lwd_utils.mli

reviewed

··· 1 1 - type 'a monoid = 'a * ('a -> 'a -> 'a) 2 2 - (** A monoid, defined by a default element and an associative operation *) 3 3 - 4 4 - val lift_monoid : 'a monoid -> 'a Lwd.t monoid 5 5 - (** Use a monoid inside [Lwd] *) 6 6 - 7 7 - (** {1 List reduction functions} 8 8 - 9 9 - All reductions are balanced, relying on operator associativity. 10 10 - 11 11 - [fold_left] would compute a chain like: 12 12 - [fold f [a; b; c; d] = f a (f b (f c d)] 13 13 - 14 14 - [reduce] uses tree-shaped computations like: 15 15 - [reduce f [a; b; c; d] = f (f a b) (f c d)] 16 16 - 17 17 - The depth of the computation grows in O(log n) where n is the length of the 18 18 - input sequence. 19 19 - *) 20 20 - 21 21 - val pack : 'a monoid -> 'a Lwd.t list -> 'a Lwd.t 22 22 - (** Reduce a list of elements in [Lwd] monad *) 23 23 - 24 24 - val pack_seq : 'a monoid -> 'a Lwd.t Seq.t -> 'a Lwd.t 25 25 - (** Reduce an (OCaml) [Seq.t] with a monoid *) 26 26 - 27 27 - val reduce : 'a monoid -> 'a list -> 'a 28 28 - (** Reduce a list with a monoid **) 29 29 - 30 30 - val map_reduce : ('a -> 'b) -> 'b monoid -> 'a list -> 'b 31 31 - (** Map and reduce a list with a monoid **) 32 32 - 33 33 - (** {1 Other Lwd list functions} *) 34 34 - 35 35 - val map_l : ('a -> 'b Lwd.t) -> 'a list -> 'b list Lwd.t 36 36 - 37 37 - val flatten_l : 'a Lwd.t list -> 'a list Lwd.t 38 38 - (** Commute [Lwd] and [list] *) 39 39 - 40 40 - (** {1 Miscellaneous functions} 41 41 - 42 42 - I don't know where to put these, but they are useful, especially for 43 43 - UI-related computations. 44 44 - *) 45 45 - 46 46 - val mini : int -> int -> int 47 47 - (** Minimum of two integers *) 48 48 - 49 49 - val maxi : int -> int -> int 50 50 - (** Maximum of two integers *) 51 51 - 52 52 - val clampi : int -> min:int -> max:int -> int 53 53 - (** Clamp an integer between two bounds. *) 54 54 - 55 55 - val minf : float -> float -> float 56 56 - (** Minimum of two floats *) 57 57 - 58 58 - val maxf : float -> float -> float 59 59 - (** Maximum of two floats *) 60 60 - 61 61 - val clampf : float -> min:float -> max:float -> float 62 62 - (** Clamp a float between two bounds. *)

-36

forks/lwd/lib/lwd/pp.ml

reviewed

··· 1 1 - let version = 2 2 - Scanf.sscanf Sys.ocaml_version "%d.%d" (fun major minor -> (major, minor)) 3 3 - 4 4 - let ic = 5 5 - if Array.length Sys.argv = 1 then ( 6 6 - Printf.eprintf 7 7 - "Usage: %s <input-file>\n\ 8 8 - Expecting a filename as argument.\n" 9 9 - Sys.argv.(0); 10 10 - exit 1 11 11 - ) else if not (Sys.file_exists Sys.argv.(1)) then ( 12 12 - Printf.eprintf 13 13 - "Usage: %s <input-file>\n\ 14 14 - Cannot find file %S.\n" 15 15 - Sys.argv.(0) 16 16 - Sys.argv.(1); 17 17 - exit 1 18 18 - ) else 19 19 - open_in_bin Sys.argv.(1) 20 20 - 21 21 - let () = 22 22 - let enable_output = ref true in 23 23 - let change_output v = 24 24 - print_newline (); 25 25 - enable_output := v 26 26 - in 27 27 - try 28 28 - while true do 29 29 - match input_line ic with 30 30 - | "(*BEGIN LETOP*)" -> change_output (version >= (4, 08)) 31 31 - | "(*BEGIN INJECTIVITY*)" -> change_output (version >= (4, 12)) 32 32 - | "(*ELSE*)" -> change_output (not !enable_output) 33 33 - | "(*END*)" -> change_output true 34 34 - | line -> if !enable_output then print_endline line 35 35 - done 36 36 - with End_of_file -> ()

-18

forks/lwd/lib/lwd/select_version.ml

reviewed

··· 1 1 - let () = 2 2 - let version = 3 3 - Scanf.sscanf Sys.ocaml_version "%d.%d" (fun major minor -> (major, minor)) 4 4 - in 5 5 - let basename = 6 6 - if version < (4, 08) then "lwd_infix_compat" else "lwd_infix_letop" 7 7 - in 8 8 - let file = 9 9 - match Sys.argv.(1) with 10 10 - | "intf" -> basename ^ ".mli" 11 11 - | "impl" -> basename ^ ".ml" 12 12 - | _ -> assert false 13 13 - in 14 14 - let ic = open_in_bin file in 15 15 - let length = in_channel_length ic in 16 16 - let content = really_input_string ic length in 17 17 - close_in ic; 18 18 - print_string content

forks/lwd/lib/nottui-lwt/Makefile forks/nottui/lib/nottui-lwt/Makefile

reviewed

forks/lwd/lib/nottui-lwt/dune forks/nottui/lib/nottui-lwt/dune

reviewed

forks/lwd/lib/nottui-lwt/nottui_lwt.ml forks/nottui/lib/nottui-lwt/nottui_lwt.ml

reviewed

forks/lwd/lib/nottui-lwt/nottui_lwt.mli forks/nottui/lib/nottui-lwt/nottui_lwt.mli

reviewed

forks/lwd/lib/nottui-pretty/dune forks/nottui/lib/nottui-pretty/dune

reviewed

forks/lwd/lib/nottui-pretty/nottui_pretty.ml forks/nottui/lib/nottui-pretty/nottui_pretty.ml

reviewed

forks/lwd/lib/nottui-pretty/nottui_pretty.mli forks/nottui/lib/nottui-pretty/nottui_pretty.mli

reviewed

forks/lwd/lib/nottui/Makefile forks/nottui/lib/nottui/Makefile

reviewed

+14 -1

forks/lwd/lib/nottui/README.md forks/nottui/lib/nottui/README.md

reviewed

··· 9 9 $ opam install nottui 10 10 ``` 11 11 12 12 - Here are a few examples to being using Nottui. 12 12 + you might want to 13 13 + 14 14 + ## Tutorial 15 15 + There is a tutorial for nottui which will take you through the basics of making a small application, it covers: 16 16 + - how to do layout 17 17 + - reactive values 18 18 + - handling keyboard input 19 19 + - and much more! 20 20 + 21 21 + See [tutorial](/docs/tutorial/hackernews/bin/tutorial.md) 22 22 + 23 23 + ## Examples 24 24 + 25 25 + Here are a few examples to being using Nottui 13 26 Let's start with Hello world. 14 27 15 28 #### Hello world

-5

forks/lwd/lib/nottui/dune

reviewed

··· 1 1 - (library 2 2 - (name nottui) 3 3 - (public_name nottui) 4 4 - (wrapped false) 5 5 - (libraries lwd notty notty.unix))

+34 -57

forks/lwd/lib/nottui/nottui.ml forks/nottui/lib/nottui/nottui_main.ml

reviewed

··· 8 8 val make : unit -> handle 9 9 val request : handle -> unit 10 10 val request_var : var -> unit 11 11 - val release_var : var -> unit 12 11 val release : handle -> unit 13 12 14 13 val request_reversable : handle -> unit ··· 56 55 57 56 let clock = ref 0 58 57 59 59 - let currently_focused:var ref= ref (make()|>fst) 58 58 + let currently_focused:var ref= ref (make()|>fst) 60 59 61 61 - let focus_stack:var Stack.t= Stack.create() 60 60 + let focus_stack:var Stack.t= Stack.create() 62 61 63 62 let request_var (v : var) = 64 63 incr clock; 65 64 Lwd.set v !clock; 66 65 currently_focused := v; 67 66 ;; 68 68 - let release_var (v : var) = 69 69 - incr clock; 70 70 - Lwd.set v 0 71 71 - ;; 72 67 let request ((v, _ ): handle) = 73 68 request_var v; 74 69 ;; ··· 238 233 239 234 type layout_spec = { w : int; h : int; sw : int; sh : int ; mw : int; mh : int} 240 235 241 241 - let pp_layout_spec ppf { w; h; sw; sh } = 242 242 - Format.fprintf ppf "{ w = %d; h = %d; sw = %d; sh = %d }" w h sw sh 236 236 + let pp_layout_spec ppf { w; h; sw; sh;mw;mh } = 237 237 + Format.fprintf ppf "{ w = %d; h = %d; sw = %d; sh = %d; mw= %d; mh=%d; }" w h sw sh mw mh 243 238 244 239 type flags = int 245 240 let flags_none = 0 ··· 350 345 match (w, t.w), (h, t.h), (sw, t.sw), (sh, t.sh), (mw,t.mw) ,(mh,t.mh) with 351 346 | (Some w, _ | None, w), (Some h, _ | None, h), 352 347 (Some sw, _ | None, sw), (Some sh, _ | None, sh), (Some mw, _ | None, mw),(Some mh, _ | None, mh) -> 348 348 + let mw= if w>mw then w else mw 349 349 + and mh= if h>mh then h else mh 350 350 + in 353 351 {t with w; h; sw; sh; mw; mh; desc = Resize (t, g, bg)} 354 352 355 355 - let resize_to ({w; h; sw; sh} : layout_spec) ?pad ?crop ?(bg=A.empty) t : t = 353 353 + let resize_to ({w; h; sw; sh;mw;mh} : layout_spec) ?pad ?crop ?(bg=A.empty) t : t = 356 354 let g = prepare_gravity (pad, crop) in 357 357 - {t with w; h; sw; sh; desc = Resize (t, g, bg)} 355 355 + let mw= if w>mw then w else mw 356 356 + and mh= if h>mh then h else mh 357 357 + in 358 358 + {t with w; h; sw; sh; mw; mh; desc = Resize (t, g, bg)} 358 359 359 360 let event_filter ?focus f t : t = 360 361 let focus = match focus with ··· 482 483 let flex = total - a - b in 483 484 (*if we have a stretch value and space to stretch into*) 484 485 let canStretch=stretch > 0 && flex > 0 in 485 485 - if canStretch then 486 486 + 487 487 + if canStretch then 486 488 let ratio = 487 489 if sa > sb then 488 490 flex * sa / stretch ··· 496 498 2. stretch b give the leftover to a 497 499 3. check if a is overstretched 498 500 *) 499 499 - let aRatio,bRatio= ref (a+ratio), ref (b+(flex-ratio)) in 501 501 + let aRatio,bRatio= ref (a+ratio), ref (b+flex-ratio) in 502 502 + 500 503 let aMaxed =ref false in 501 504 if !aRatio>aMax then 502 502 - ( 503 503 - bRatio:=!bRatio+(!aRatio-aMax); 504 504 - aRatio:=aMax ; 505 505 - aMaxed:=true); 505 505 + ( 506 506 + bRatio:=!bRatio+(!aRatio-aMax); 507 507 + aRatio:=aMax ; 508 508 + aMaxed:=true 509 509 + ); 506 510 if (!bRatio)>bMax then 507 511 begin 508 512 if !aMaxed then 509 513 bRatio:=bMax 510 514 else 511 515 aRatio:=!aRatio+(!bRatio-bMax); 516 516 + bRatio:=bMax; 512 517 end; 513 518 if !aRatio>aMax then 514 519 aRatio:=aMax ; ··· 524 529 if stretch > 0 && flex >= 0 && max >total then 525 530 (0, total) 526 531 else 527 527 - (* If we can stretch and we got here we must have wanted to stretch beyond the max which means we should stretch to max and recalculate the flex*) 528 528 - let (fixed,flex)=if stretch > 0 then (max,total-max) else (fixed,flex) in 532 532 + (* If we can stretch and we have space to expand into and we got here we must have wanted to stretch beyond the max which means we should stretch to max and recalculate the flex*) 533 533 + let (fixed,flex)=if stretch > 0 && total >= max then (max,total-max) else (fixed,flex) in 529 534 530 535 let gravity = if flex >= 0 then g1 else g2 in 531 536 ··· 593 598 t.size <- size; 594 599 t.view <- ui; 595 600 (* TODO:I think i need to do something here*) 596 596 - update_sensors 0 0 (fst size) (snd size) 10000 10000 ui; 601 601 + update_sensors 0 0 (fst size) (snd size) (fst size) (snd size)ui; 597 602 update_focus ui 598 603 599 604 let dispatch_mouse st x y btn w h t = ··· 640 645 begin match f (`Mouse (`Press btn, (x, y), [])) with 641 646 | `Handled -> true 642 647 | `Unhandled -> aux ox oy sw sh n 648 648 + | `Remap _ -> failwith "Cannot remap mouse events" 643 649 end 644 650 in 645 651 aux 0 0 w h t ··· 779 785 *) 780 786 (render_node 0 0 w h w h (view|>resize)).image 781 787 782 782 - let dispatch_raw_key st key = 783 783 - let rec iter (st: ui list) : [> `Unhandled] = 784 784 - match st with 788 788 + let rec dispatch_raw_key st key = 789 789 + let rec iter (sts: ui list) : [> `Unhandled] = 790 790 + match sts with 785 791 | [] -> `Unhandled 786 792 | ui :: tl -> 787 793 begin match ui.desc with ··· 815 821 begin match f (`Key key) with 816 822 | `Unhandled -> iter (t :: tl) 817 823 | `Handled -> `Handled 824 824 + | `Remap key -> 825 825 + dispatch_raw_key st key 818 826 end 819 827 end 820 828 in 821 829 iter [st.view] 822 830 823 831 exception Acquired_focus 824 824 - exception Released_focus 825 832 826 833 let grab_focus ui = 827 834 let rec aux ui = ··· 831 838 | Focus.Conflict _ -> iter aux ui 832 839 in 833 840 try aux ui; false with Acquired_focus -> true 834 834 - let release_focus ui = 835 835 - let rec aux ui = 836 836 - match ui.focus with 837 837 - | Focus.Empty -> () 838 838 - | Focus.Handle (_, v) -> Focus.release_var v; raise Released_focus 839 839 - | Focus.Conflict _ -> iter aux ui 840 840 - in 841 841 - try aux ui; false with Released_focus-> true 841 841 + 842 842 843 843 let rec dispatch_focus t dir = 844 844 match t.desc with ··· 853 853 | `Out -> 854 854 (*If my element doesn't have focus then I should let a child element take focus or grab focus for myself. 855 855 This should drill down until an element has focus and then let the next element up take the focus *) 856 856 - let write_log log= 857 857 - Out_channel.with_open_gen [Open_append;Open_text] 7777 "errLog" (fun file-> 858 858 - 859 859 - Out_channel.output_string file log; 860 860 - Out_channel.output_string file "\n-----------\n" 861 861 - )in 862 856 if (Focus.has_focus t'.focus) && (Focus.has_focus t.focus)then 863 863 - begin 864 864 - 865 865 - write_log "child has focus"; 866 866 - dispatch_focus t' dir ||grab_focus t 867 867 - end 868 868 - (* else if not (Focus.has_focus t.focus) then *) 869 869 - (* begin *) 870 870 - (* Out_channel.with_open_gen [Open_append;Open_text] 7777 "errLog" (fun file->(pp (Format.formatter_of_out_channel file) t)); *) 871 871 - (* Out_channel.with_open_gen [Open_append;Open_text] 7777 "errLog" (fun file->Out_channel.output_string file "\n----------------------------------\n"); *) 872 872 - (* dispatch_focus t' dir ||grab_focus t *) 873 873 - (* end *) 857 857 + dispatch_focus t' dir ||grab_focus t 874 858 else if not (Focus.has_focus t'.focus) then 875 875 - begin 876 876 - write_log "child doesn't have focus"; 877 877 - write_log (Format.asprintf "%a" pp t); 878 878 - 879 859 false 880 880 - end 881 881 - else begin 882 882 - write_log "exit early"; 860 860 + else 883 861 true 884 884 - end 885 862 |_-> 886 863 if Focus.has_focus t'.focus then 887 864 dispatch_focus t' dir || grab_focus t

+156 -142

forks/lwd/lib/nottui/nottui.mli forks/nottui/lib/nottui/nottui_main.mli

reviewed

··· 1 1 open Notty 2 2 3 3 - (** 4 4 - Nottui augments Notty with primitives for laying out user interfaces (in the 5 5 - terminal) and reacting to input events. 6 6 - *) 3 3 + (** Nottui augments Notty with primitives for laying out user interfaces (in the 4 4 + terminal) and reacting to input events. *) 7 5 8 6 (** {1 Focus (defining and managing active objects)} *) 9 7 10 10 - module Focus : 11 11 - sig 12 12 - 13 13 - type handle 8 8 + module Focus : sig 14 9 (** A [handle] represents a primitive area that can request, receive and lose 15 10 the focus. A visible UI is made of many handles, of which at most one can 16 11 be active. *) 12 12 + type handle 17 13 14 14 + (** Create a new handle *) 18 15 val make : unit -> handle 19 19 - (** Create a new handle *) 20 16 17 17 + (** Request the focus *) 21 18 val request : handle -> unit 22 22 - (** Request the focus *) 23 19 24 24 - val release : handle -> unit 25 20 (** Release the focus (if the handle has it) *) 21 21 + val release : handle -> unit 26 22 27 27 - type status 28 23 (** [status] represents the state in which a handle can be. 29 24 Externally we care about having or not the focus, which can be queried 30 25 with the [has_focus] function. Internally, [status] also keeps track of 31 31 - conflicts (if multiple handles [request]ed the focus). 32 32 - *) 26 26 + conflicts (if multiple handles [request]ed the focus). *) 27 27 + type status 33 28 34 34 - val empty : status 35 29 (** A status that has no focus and no conflicts *) 30 30 + val empty : status 36 31 37 37 - val status : handle -> status Lwd.t 38 32 (** Get the status of a focus [handle]. The [status] is a reactive value: 39 33 it will evolve over time, as focus is received or lost. *) 34 34 + val status : handle -> status Lwd.t 40 35 41 41 - val has_focus : status -> bool 42 36 (** Check if this [status] corresponds to an active focus *) 37 37 + val has_focus : status -> bool 43 38 44 39 (** TODO 45 40 This implements a more general concept of "reactive auction": ··· 48 43 for instance a tab component can only display a single tab among many). 49 44 50 45 - the result can evolve over time, parties can join or leave, or bid 51 51 - "more". 52 52 - *) 46 46 + "more". *) 53 47 48 48 + (** Request the focus and add to the focus stack. 49 49 + WARNING: The focus stack is global, if you render multiple nottui ui's you may not want to use this *) 54 50 val request_reversable : handle -> unit 55 55 - (** Request the focus and add to the focus stack *) 56 51 57 57 - val release_reversable : handle -> unit 58 52 (** Release the focus (if the handle has it) and restore the last focus on the stack *) 59 59 - 53 53 + val release_reversable : handle -> unit 60 54 end 61 55 62 56 (** {1 Gravity (horizontal and vertical alignments)} *) 63 57 64 64 - module Gravity : 65 65 - sig 66 66 - 67 67 - type direction = [ 68 68 - | `Negative 69 69 - | `Neutral 70 70 - | `Positive 71 71 - ] 58 58 + module Gravity : sig 72 59 (** A gravity is a pair of directions along the horizontal and vertical 73 60 axis. 74 61 ··· 76 63 bottom. 77 64 78 65 [`Negative] direction means left / top bounds, [`Neutral] means center 79 79 - and [`Positive] means right / bottom. 80 80 - *) 66 66 + and [`Positive] means right / bottom. *) 67 67 + type direction = 68 68 + [ `Negative 69 69 + | `Neutral 70 70 + | `Positive 71 71 + ] 81 72 73 73 + (** Printing directions *) 82 74 val pp_direction : Format.formatter -> direction -> unit 83 83 - (** Printing directions *) 84 75 85 85 - type t 86 76 (** The gravity type is a pair of an horizontal and a vertical gravity *) 77 77 + type t 87 78 79 79 + (** Printing gravities *) 88 80 val pp : Format.formatter -> t -> unit 89 89 - (** Printing gravities *) 90 81 82 82 + (** Make a gravity value from an [h]orizontal and a [v]ertical directions. *) 91 83 val make : h:direction -> v:direction -> t 92 92 - (** Make a gravity value from an [h]orizontal and a [v]ertical directions. *) 93 84 94 94 - val default : t 95 85 (** Default (negative, aligning to the top-left) gravity. *) 86 86 + val default : t 96 87 97 97 - val h : t -> direction 98 88 (** Get the horizontal direction *) 89 89 + val h : t -> direction 99 90 100 100 - val v : t -> direction 101 91 (** Get the vertical direction *) 102 102 - 92 92 + val v : t -> direction 103 93 end 104 94 105 95 type gravity = Gravity.t 106 96 107 97 (** {1 Primitive combinators for making user interfaces} *) 108 98 109 109 - module Ui : 110 110 - sig 111 111 - 99 99 + module Ui : sig 112 100 type t 113 101 (* Type of UI elements *) 114 102 103 103 + (** Printing UI element *) 115 104 val pp : Format.formatter -> t -> unit 116 116 - (** Printing UI element *) 117 105 118 106 (** {1 Layout specifications} *) 119 107 120 120 - type layout_spec = { w : int; h : int; sw : int; sh : int ; mw : int; mh : int} 121 108 (** The type of layout specifications. 122 109 123 110 For each axis, layout is specified as a pair of integers: 124 111 - a fixed part that is expressed as a number of columns or rows 125 112 - a stretchable part that represents a strength used to share the 126 126 - remaining space (or 0 if the UI doesn't extend over free space) 127 127 - *) 113 113 + remaining space (or 0 if the UI doesn't extend over free space) *) 114 114 + type layout_spec = 115 115 + { w : int 116 116 + ; h : int 117 117 + ; sw : int 118 118 + ; sh : int 119 119 + ; mw : int 120 120 + ; mh : int 121 121 + } 128 122 129 129 - val pp_layout_spec : Format.formatter -> layout_spec -> unit 130 123 (** Printing layout specification *) 124 124 + val pp_layout_spec : Format.formatter -> layout_spec -> unit 131 125 132 132 - val layout_spec : t -> layout_spec 133 126 (** Get the layout spec for an UI element *) 127 127 + val layout_spec : t -> layout_spec 134 128 135 135 - val layout_width : t -> int 136 129 (** Get the layout width component of an UI element *) 130 130 + val layout_width : t -> int 137 131 138 138 - val layout_stretch_width : t -> int 139 132 (** Get the layout stretch width strength of an UI element *) 133 133 + val layout_stretch_width : t -> int 140 134 135 135 + (** Get the layout height component of an UI element *) 141 136 val layout_height : t -> int 142 142 - (** Get the layout height component of an UI element *) 143 137 138 138 + (** Get the layout height strength of an UI element *) 144 139 val layout_stretch_height : t -> int 145 145 - (** Get the layout height strength of an UI element *) 146 140 147 147 - val layout_max_width :t ->int 148 141 (** Get the layout max_width of an UI element *) 142 142 + val layout_max_width : t -> int 149 143 150 150 - val layout_max_height :t ->int 151 144 (** Get the layout max_height of an UI element *) 145 145 + val layout_max_height : t -> int 152 146 153 147 (** {1 Primitive images} *) 154 148 155 155 - val empty : t 156 149 (** The empty surface: it occupies no space and does not do anything *) 150 150 + val empty : t 157 151 158 158 - val atom : image -> t 159 152 (** Primitive surface that displays a Notty image *) 153 153 + val atom : image -> t 160 154 161 161 - val space : int -> int -> t 162 155 (** Void space of dimensions [x,y]. Useful for padding and interstitial 163 156 space. *) 157 157 + val space : int -> int -> t 164 158 165 159 (** {1 Event handles} *) 166 160 167 167 - 168 168 - type mouse_handler = x:int -> y:int -> Unescape.button -> [ 169 169 - | `Handled 170 170 - |`Unhandled 171 171 - | `Grab of (x:int -> y:int -> unit) * (x:int -> y:int -> unit) 172 172 - ] 173 161 (** The type of handlers for mouse events. They receive the (absolute) 174 162 coordinates of the mouse, the button that was clicked. 175 163 ··· 181 169 the button is pressed and the [on_release] function is called when the 182 170 button is released. 183 171 184 184 - During that time, no other mouse input events can be dispatched. 185 185 - *) 172 172 + During that time, no other mouse input events can be dispatched. *) 173 173 + type mouse_handler = 174 174 + x:int 175 175 + -> y:int 176 176 + -> Unescape.button 177 177 + -> [ `Handled 178 178 + | `Unhandled 179 179 + | `Grab of (x:int -> y:int -> unit) * (x:int -> y:int -> unit) 180 180 + ] 186 181 187 187 - type semantic_key = [ 188 188 - (* Clipboard *) 189 189 - | `Copy 190 190 - | `Paste 191 191 - (* Focus management *) 192 192 - | `Focus of [`Out|`Next | `Prev | `Left | `Right | `Up | `Down] 193 193 - ] 194 182 (** Key handlers normally reacts to keyboard input but a few special keys are 195 183 defined to represent higher-level actions. 196 184 Copy and paste, as well as focus movements. *) 185 185 + type semantic_key = 186 186 + [ (* Clipboard *) 187 187 + `Copy 188 188 + | `Paste 189 189 + | (* Focus management *) 190 190 + `Focus of 191 191 + [ `Out | `Next | `Prev | `Left | `Right | `Up | `Down ] 192 192 + ] 197 193 198 198 - type key = [ 199 199 - | Unescape.special | `Uchar of Uchar.t | `ASCII of char | semantic_key 200 200 - ] * Unescape.mods 201 194 (** A key is the pair of a main key and a list of modifiers *) 195 195 + type key = 196 196 + [ Unescape.special | `Uchar of Uchar.t | `ASCII of char | semantic_key ] 197 197 + * Unescape.mods 202 198 203 203 - type may_handle = [ `Unhandled | `Handled| `Remap of key ] 204 199 (** An event is propagated until it gets handled. 205 200 Handler functions return a value of type [may_handle] to indicate 206 201 whether the event was handled, not handled, or should be remapped to aonother event. *) 202 202 + type may_handle = 203 203 + [ `Unhandled 204 204 + | `Handled 205 205 + | `Remap of key 206 206 + ] 207 207 208 208 - type mouse = Unescape.mouse 209 208 (** Specification of mouse inputs, taken from Notty *) 209 209 + type mouse = Unescape.mouse 210 210 211 211 - type event = [ `Key of key | `Mouse of mouse | `Paste of Unescape.paste ] 211 211 + type event = 212 212 + [ `Key of key 213 213 + | `Mouse of mouse 214 214 + | `Paste of Unescape.paste 215 215 + ] 212 216 (* The type of input events. *) 213 217 214 214 - val mouse_area : mouse_handler -> t -> t 215 218 (** Handle mouse events that happens over an ui. *) 219 219 + val mouse_area : mouse_handler -> t -> t 216 220 217 217 - val keyboard_area : ?focus:Focus.status -> (key -> may_handle) -> t -> t 218 221 (** Define a focus receiver, handle keyboard events over the focused area. Distinct from [event_filter] because [`Focus *] events will move focus between these areas *) 222 222 + val keyboard_area : ?focus:Focus.status -> (key -> may_handle) -> t -> t 219 223 220 220 - val has_focus : t -> bool 221 224 (** Check if this UI has focus, either directly (it is a focused 222 225 [keyboard_area]), or inherited (one of the child is a focused 223 226 [keyboard_area]). *) 227 227 + val has_focus : t -> bool 224 228 225 225 - val event_filter : 226 226 - ?focus:Focus.status -> 227 227 - ([`Key of key | `Mouse of mouse] -> may_handle) -> t -> t 228 229 (** A hook that intercepts and can interrupt events when they reach a 229 230 sub-part of the UI. *) 231 231 + val event_filter 232 232 + : ?focus:Focus.status 233 233 + -> ([ `Key of key | `Mouse of mouse ] -> may_handle) 234 234 + -> t 235 235 + -> t 230 236 231 237 (** {1 Sensors} 232 238 233 239 Sensors are used to observe the physical dimensions after layout has been 234 234 - resolved. 235 235 - *) 240 240 + resolved. *) 236 241 237 237 - type size_sensor = w:int -> h:int -> unit 238 242 (** The size sensor callback tells you the [w]idth and [h]eight of UI. 239 243 The sensor is invoked only when the UI is visible. *) 244 244 + type size_sensor = w:int -> h:int -> unit 240 245 241 241 - val size_sensor : size_sensor -> t -> t 242 246 (** Attach a size sensor to an image *) 247 247 + val size_sensor : size_sensor -> t -> t 243 248 244 244 - type frame_sensor = x:int -> y:int -> w:int -> h:int -> unit -> unit 245 249 (** The frame sensor callback gives you the whole rectangle where the widget 246 250 is displayed. 247 251 248 252 The first for components are applied during before visiting children, 249 249 - the last unit is applied after visiting children. 250 250 - *) 253 253 + the last unit is applied after visiting children. *) 254 254 + type frame_sensor = x:int -> y:int -> w:int -> h:int -> unit -> unit 251 255 252 252 - val transient_sensor : frame_sensor -> t -> t 253 256 (** Attach a transient frame sensor: the callback will be invoked only once, 254 257 on next frame. *) 258 258 + val transient_sensor : frame_sensor -> t -> t 255 259 256 256 - val permanent_sensor : frame_sensor -> t -> t 257 260 (** Attach a permanent sensor: the callback will be invoked on every frame. 258 261 Note that this can have a significant impact on performance. *) 262 262 + val permanent_sensor : frame_sensor -> t -> t 259 263 260 264 (** {1 Composite images} *) 261 265 262 262 - val resize : 263 263 - ?w:int -> ?h:int -> ?sw:int -> ?sh:int -> ?mw:int -> 264 264 - ?mh:int -> ?pad:Gravity.t -> ?crop:Gravity.t -> ?bg:attr -> t -> t 265 265 - (** Override the layout specification of an image with provided [w], [h], 266 266 - [sw] or [sh]. 266 266 + (** Override the layout specification of the ui with provided [w](width), [h](height), 267 267 + [sw](stretch width) or [sh](stretch height) 268 268 + [mw](max width) or [mh](max height). 267 269 268 270 [pad] and [crop] are used to determine how to align the UI when there is 269 271 too much or not enough space. 270 272 271 271 - [bg] is used to fill the padded background. 272 272 - *) 273 273 + [bg] is used to fill the padded background. *) 274 274 + val resize 275 275 + : ?w:int 276 276 + -> ?h:int 277 277 + -> ?sw:int 278 278 + -> ?sh:int 279 279 + -> ?mw:int 280 280 + -> ?mh:int 281 281 + -> ?pad:Gravity.t 282 282 + -> ?crop:Gravity.t 283 283 + -> ?bg:attr 284 284 + -> t 285 285 + -> t 273 286 274 274 - val resize_to : 275 275 - layout_spec -> 276 276 - ?pad:Gravity.t -> ?crop:Gravity.t -> ?bg:attr -> t -> t 287 287 + val resize_to : layout_spec -> ?pad:Gravity.t -> ?crop:Gravity.t -> ?bg:attr -> t -> t 277 288 278 278 - val shift_area : int -> int -> t -> t 279 289 (** Shift the contents of a UI by a certain amount. 280 290 Positive values crop the image while negative values pad. 281 291 282 282 - This primitive is used to implement scrolling. 283 283 - *) 292 292 + This primitive is used to implement scrolling. *) 293 293 + val shift_area : int -> int -> t -> t 284 294 285 285 - val join_x : t -> t -> t 286 295 (** Horizontally join two images *) 296 296 + val join_x : t -> t -> t 287 297 298 298 + (** Vertically join two images *) 288 299 val join_y : t -> t -> t 289 289 - (** Vertically join two images *) 290 300 291 291 - val join_z : t -> t -> t 292 301 (** Superpose two images. The right one will be on top. *) 302 302 + val join_z : t -> t -> t 293 303 304 304 + (** Horizontal concatenation monoid *) 294 305 val pack_x : t Lwd_utils.monoid 295 295 - (** Horizontal concatenation monoid *) 296 306 297 297 - val pack_y : t Lwd_utils.monoid 298 307 (** Vertical concatenation monoid *) 308 308 + val pack_y : t Lwd_utils.monoid 299 309 300 300 - val pack_z : t Lwd_utils.monoid 301 310 (** Superposition monoid *) 311 311 + val pack_z : t Lwd_utils.monoid 302 312 313 313 + (** Short-hand for horizontally joining a list of images *) 303 314 val hcat : t list -> t 304 304 - (** Short-hand for horizontally joining a list of images *) 305 315 316 316 + (** Short-hand for vertically joining a list of images *) 306 317 val vcat : t list -> t 307 307 - (** Short-hand for vertically joining a list of images *) 308 318 319 319 + (** Short-hand for superposing a list of images *) 309 320 val zcat : t list -> t 310 310 - (** Short-hand for superposing a list of images *) 311 321 end 312 322 313 323 type ui = Ui.t 314 324 315 325 (** {1 Rendering user interfaces and dispatching input events} *) 316 326 317 317 - module Renderer : 318 318 - sig 319 319 - 327 327 + module Renderer : sig 328 328 + (** The type of a renderer *) 320 329 type t 321 321 - (** The type of a renderer *) 322 330 323 323 - type size = int * int 324 331 (** Size of a rendering surface, as a pair of width and height *) 332 332 + type size = int * int 325 333 326 326 - val make : unit -> t 327 334 (** Create a new renderer. 328 335 329 336 It maintains state to update output image and to dispatch events. *) 337 337 + val make : unit -> t 330 338 331 331 - val update : t -> size -> Ui.t -> unit 332 339 (** Update the contents to be rendered to the given UI at a specific size *) 340 340 + val update : t -> size -> Ui.t -> unit 333 341 342 342 + (** Get the size of the last update *) 334 343 val size : t -> size 335 335 - (** Get the size of the last update *) 336 344 345 345 + (** Render and return actual image *) 337 346 val image : t -> image 338 338 - (** Render and return actual image *) 339 347 340 340 - val dispatch_mouse : t -> Ui.mouse -> Ui.may_handle 341 348 (** Dispatch a mouse event *) 349 349 + val dispatch_mouse : t -> Ui.mouse -> Ui.may_handle 342 350 343 343 - val dispatch_key : t -> Ui.key -> Ui.may_handle 344 351 (** Dispatch a keyboard event *) 352 352 + val dispatch_key : t -> Ui.key -> Ui.may_handle 345 353 354 354 + (** Dispatch an event *) 346 355 val dispatch_event : t -> Ui.event -> Ui.may_handle 347 347 - (** Dispatch an event *) 348 348 - 349 356 end 350 357 351 358 (** {1 Main loop} 352 359 353 353 - Outputting an interface to a TTY and interacting with it 354 354 - *) 360 360 + Outputting an interface to a TTY and interacting with it *) 355 361 356 356 - module Ui_loop : 357 357 - sig 362 362 + module Ui_loop : sig 358 363 open Notty_unix 359 364 360 360 - val step : ?process_event:bool -> ?timeout:float -> renderer:Renderer.t -> 361 361 - Term.t -> ui Lwd.root -> unit 362 365 (** Run one step of the main loop. 363 366 364 367 Update output image describe by the provided [root]. 365 368 If [process_event], wait up to [timeout] seconds for an input event, then 366 369 consume and dispatch it. *) 370 370 + val step 371 371 + : ?process_event:bool 372 372 + -> ?timeout:float 373 373 + -> renderer:Renderer.t 374 374 + -> Term.t 375 375 + -> ui Lwd.root 376 376 + -> unit 367 377 368 368 - val run : 369 369 - ?tick_period:float -> ?tick:(unit -> unit) -> 370 370 - ?term:Term.t -> ?renderer:Renderer.t -> 371 371 - ?quit:bool Lwd.var -> ?quit_on_escape:bool -> 372 372 - ?quit_on_ctrl_q:bool -> ui Lwd.t -> unit 373 378 (** Repeatedly run steps of the main loop, until either: 374 379 - [quit] becomes true, 375 380 - the ui computation raises an exception, ··· 380 385 ones will be allocated and released. 381 386 382 387 To simulate concurrency in a polling fashion, tick function and period 383 383 - can be provided. Use the [Lwt] backend for real concurrency. 384 384 - *) 388 388 + can be provided. Use the [Lwt] backend for real concurrency. *) 389 389 + val run 390 390 + : ?tick_period:float 391 391 + -> ?tick:(unit -> unit) 392 392 + -> ?term:Term.t 393 393 + -> ?renderer:Renderer.t 394 394 + -> ?quit:bool Lwd.var 395 395 + -> ?quit_on_escape:bool 396 396 + -> ?quit_on_ctrl_q:bool 397 397 + -> ui Lwd.t 398 398 + -> unit 385 399 end

-867

forks/lwd/lib/nottui/nottui_widgets.ml

reviewed

··· 1 1 - open Lwd.Infix 2 2 - open Notty 3 3 - open Nottui 4 4 - 5 5 - let empty_lwd = Lwd.return Ui.empty 6 6 - let mini, maxi, clampi = Lwd_utils.(mini, maxi, clampi) 7 7 - 8 8 - let string ?(attr = A.empty) str = 9 9 - let control_character_index str i = 10 10 - let len = String.length str in 11 11 - let i = ref i in 12 12 - while 13 13 - let i = !i in 14 14 - i < len && str.[i] >= ' ' 15 15 - do 16 16 - incr i 17 17 - done; 18 18 - if !i = len then raise Not_found; 19 19 - !i 20 20 - in 21 21 - let rec split str i = 22 22 - match control_character_index str i with 23 23 - | j -> 24 24 - let img = I.string attr (String.sub str i (j - i)) in 25 25 - img :: split str (j + 1) 26 26 - | exception Not_found -> 27 27 - [ I.string attr (if i = 0 then str else String.sub str i (String.length str - i)) ] 28 28 - in 29 29 - Ui.atom (I.vcat (split str 0)) 30 30 - ;; 31 31 - 32 32 - let int ?attr x = string ?attr (string_of_int x) 33 33 - let bool ?attr x = string ?attr (string_of_bool x) 34 34 - let float_ ?attr x = string ?attr (string_of_float x) 35 35 - let printf ?attr fmt = Printf.ksprintf (string ?attr) fmt 36 36 - let fmt ?attr fmt = Format.kasprintf (string ?attr) fmt 37 37 - let kprintf k ?attr fmt = Printf.ksprintf (fun str -> k (string ?attr str)) fmt 38 38 - let kfmt k ?attr fmt = Format.kasprintf (fun str -> k (string ?attr str)) fmt 39 39 - let attr_menu_main = A.(bg green ++ fg black) 40 40 - let attr_menu_sub = A.(bg lightgreen ++ fg black) 41 41 - let attr_clickable = A.(bg lightblue) 42 42 - 43 43 - type window_manager = 44 44 - { overlays : ui Lwd.t Lwd_table.t 45 45 - ; view : ui Lwd.t 46 46 - } 47 47 - 48 48 - let window_manager base = 49 49 - let overlays = Lwd_table.make () in 50 50 - let composition = 51 51 - Lwd.join (Lwd_table.reduce (Lwd_utils.lift_monoid Ui.pack_z) overlays) 52 52 - in 53 53 - let view = 54 54 - Lwd.map2 base composition ~f:(fun base composite -> 55 55 - Ui.join_z base (Ui.resize_to (Ui.layout_spec base) composite)) 56 56 - in 57 57 - { overlays; view } 58 58 - ;; 59 59 - 60 60 - let window_manager_view wm = wm.view 61 61 - let window_manager_overlays wm = wm.overlays 62 62 - 63 63 - let menu_overlay wm g ?(dx = 0) ?(dy = 0) body around = 64 64 - let sensor ~x ~y ~w ~h () = 65 65 - let row = Lwd_table.append (window_manager_overlays wm) in 66 66 - let h_pad = 67 67 - match Gravity.h g with 68 68 - | `Negative -> Ui.space (x + dx) 0 69 69 - | `Neutral -> Ui.space (x + dx + (w / 2)) 0 70 70 - | `Positive -> Ui.space (x + dx + w) 0 71 71 - in 72 72 - let v_pad = 73 73 - match Gravity.v g with 74 74 - | `Negative -> Ui.space 0 (y + dy) 75 75 - | `Neutral -> Ui.space 0 (y + dy + (h / 2)) 76 76 - | `Positive -> Ui.space 0 (y + dy + h) 77 77 - in 78 78 - let view = 79 79 - Lwd.map body ~f:(fun body -> 80 80 - let body = 81 81 - let pad = Ui.space 1 0 in 82 82 - Ui.join_x pad (Ui.join_x body pad) 83 83 - in 84 84 - let bg = Ui.resize_to (Ui.layout_spec body) ~bg:A.(bg lightgreen) Ui.empty in 85 85 - let catchall = 86 86 - Ui.mouse_area 87 87 - (fun ~x:_ ~y:_ -> function 88 88 - | `Left -> 89 89 - Lwd_table.remove row; 90 90 - `Handled 91 91 - | _ -> `Handled) 92 92 - (Ui.resize ~sw:1 ~sh:1 Ui.empty) 93 93 - in 94 94 - Ui.join_z catchall @@ Ui.join_y v_pad @@ Ui.join_x h_pad @@ Ui.join_z bg body) 95 95 - in 96 96 - Lwd_table.set row view 97 97 - in 98 98 - Ui.transient_sensor sensor around 99 99 - ;; 100 100 - 101 101 - (*let menu_overlay wm ?(dx=0) ?(dy=0) handler body = 102 102 - let refresh = Lwd.var () in 103 103 - let clicked = ref false in 104 104 - Lwd.map' body @@ fun body -> 105 105 - let body = let pad = Ui.space 1 0 in Ui.join_x pad (Ui.join_x body pad) in 106 106 - let bg = 107 107 - Ui.resize_to (Ui.layout_spec body) ~bg:A.(bg lightgreen) Ui.empty 108 108 - in 109 109 - let click_handler ~x:_ ~y:_ = function 110 110 - | `Left -> clicked := true; Lwd.set refresh (); `Handled 111 111 - | _ -> `Unhandled 112 112 - in 113 113 - let ui = Ui.mouse_area click_handler (Ui.join_z bg body) in 114 114 - if !clicked then ( 115 115 - clicked := false; 116 116 - let sensor ~x ~y ~w:_ ~h () = 117 117 - let row = Lwd_table.append (window_manager_overlays wm) in 118 118 - let h_pad = Ui.space (x + dx) 0 in 119 119 - let v_pad = Ui.space 0 (y + h + dy) in 120 120 - let view = Lwd.map' (handler ()) @@ fun view -> 121 121 - let catchall = 122 122 - Ui.mouse_area 123 123 - (fun ~x:_ ~y:_ -> function 124 124 - | `Left -> Lwd_table.remove row; `Handled 125 125 - | _ -> `Handled) 126 126 - (Ui.resize ~sw:1 ~sh:1 Ui.empty) 127 127 - in 128 128 - Ui.join_z catchall (Ui.join_y v_pad (Ui.join_x h_pad view)) 129 129 - in 130 130 - Lwd_table.set row view 131 131 - in 132 132 - Ui.transient_sensor sensor ui 133 133 - ) else ui*) 134 134 - 135 135 - let scroll_step = 1 136 136 - 137 137 - type scroll_state = 138 138 - { position : int 139 139 - ; bound : int 140 140 - ; visible : int 141 141 - ; total : int 142 142 - } 143 143 - 144 144 - let default_scroll_state = { position = 0; bound = 0; visible = 0; total = 0 } 145 145 - 146 146 - let vscroll_area ~state ~change t = 147 147 - let visible = ref (-1) in 148 148 - let total = ref (-1) in 149 149 - let scroll state delta = 150 150 - let position = state.position + delta in 151 151 - let position = clampi position ~min:0 ~max:state.bound in 152 152 - if position <> state.position then change `Action { state with position }; 153 153 - `Handled 154 154 - in 155 155 - let focus_handler state = function 156 156 - (*| `Arrow `Left , _ -> scroll (-scroll_step) 0*) 157 157 - (*| `Arrow `Right, _ -> scroll (+scroll_step) 0*) 158 158 - | `Arrow `Up, [] -> scroll state (-scroll_step) 159 159 - | `Arrow `Down, [] -> scroll state (+scroll_step) 160 160 - | `Page `Up, [] -> scroll state (-scroll_step * 8) 161 161 - | `Page `Down, [] -> scroll state (+scroll_step * 8) 162 162 - | _ -> `Unhandled 163 163 - in 164 164 - let scroll_handler state ~x:_ ~y:_ = function 165 165 - | `Scroll `Up -> scroll state (-scroll_step) 166 166 - | `Scroll `Down -> scroll state (+scroll_step) 167 167 - | _ -> `Unhandled 168 168 - in 169 169 - Lwd.map2 t state ~f:(fun t state -> 170 170 - t 171 171 - |> Ui.shift_area 0 state.position 172 172 - |> Ui.resize ~h:0 ~sh:1 173 173 - |> Ui.size_sensor (fun ~w:_ ~h -> 174 174 - let tchange = 175 175 - if !total <> (Ui.layout_spec t).Ui.h 176 176 - then ( 177 177 - total := (Ui.layout_spec t).Ui.h; 178 178 - true) 179 179 - else false 180 180 - in 181 181 - let vchange = 182 182 - if !visible <> h 183 183 - then ( 184 184 - visible := h; 185 185 - true) 186 186 - else false 187 187 - in 188 188 - if tchange || vchange 189 189 - then 190 190 - change 191 191 - `Content 192 192 - { state with 193 193 - visible = !visible 194 194 - ; total = !total 195 195 - ; bound = maxi 0 (!total - !visible) 196 196 - }) 197 197 - |> Ui.mouse_area (scroll_handler state) 198 198 - |> Ui.keyboard_area (focus_handler state)) 199 199 - ;; 200 200 - 201 201 - let main_menu_item wm text f = 202 202 - let text = string ~attr:attr_menu_main (" " ^ text ^ " ") in 203 203 - let refresh = Lwd.var () in 204 204 - let overlay = ref false in 205 205 - let on_click ~x:_ ~y:_ = function 206 206 - | `Left -> 207 207 - overlay := true; 208 208 - Lwd.set refresh (); 209 209 - `Handled 210 210 - | _ -> `Unhandled 211 211 - in 212 212 - Lwd.map (Lwd.get refresh) ~f:(fun () -> 213 213 - let ui = Ui.mouse_area on_click text in 214 214 - if !overlay 215 215 - then ( 216 216 - overlay := false; 217 217 - menu_overlay wm (Gravity.make ~h:`Negative ~v:`Positive) (f ()) ui) 218 218 - else ui) 219 219 - ;; 220 220 - 221 221 - let sub_menu_item wm text f = 222 222 - let text = string ~attr:attr_menu_sub text in 223 223 - let refresh = Lwd.var () in 224 224 - let overlay = ref false in 225 225 - let on_click ~x:_ ~y:_ = function 226 226 - | `Left -> 227 227 - overlay := true; 228 228 - Lwd.set refresh (); 229 229 - `Handled 230 230 - | _ -> `Unhandled 231 231 - in 232 232 - Lwd.map (Lwd.get refresh) ~f:(fun () -> 233 233 - let ui = Ui.mouse_area on_click text in 234 234 - if !overlay 235 235 - then ( 236 236 - overlay := false; 237 237 - menu_overlay wm (Gravity.make ~h:`Positive ~v:`Negative) (f ()) ui) 238 238 - else ui) 239 239 - ;; 240 240 - 241 241 - let sub_entry text f = 242 242 - let text = string ~attr:attr_menu_sub text in 243 243 - let on_click ~x:_ ~y:_ = function 244 244 - | `Left -> 245 245 - f (); 246 246 - `Handled 247 247 - | _ -> `Unhandled 248 248 - in 249 249 - Ui.mouse_area on_click text 250 250 - ;; 251 251 - 252 252 - type pane_state = 253 253 - | Split of 254 254 - { pos : int 255 255 - ; max : int 256 256 - } 257 257 - | Re_split of 258 258 - { pos : int 259 259 - ; max : int 260 260 - ; at : int 261 261 - } 262 262 - 263 263 - let h_pane ?(splitter_color = A.lightyellow) left right = 264 264 - let state_var = Lwd.var (Split { pos = 5; max = 10 }) in 265 265 - let render state (l, r) = 266 266 - let (Split { pos; max } | Re_split { pos; max; _ }) = state in 267 267 - (*make sure the panes can get infinetly wide and shrink infinitely small*) 268 268 - let l = Ui.resize ~w:0 ~h:0 ~sh:1 ~sw:pos ~mw:1000 ~mh:1000 l in 269 269 - let r = Ui.resize ~w:0 ~h:0 ~sh:1 ~sw:(max - pos) ~mw:1000 ~mh:1000 r in 270 270 - let splitter = 271 271 - Ui.resize ~bg:Notty.A.(bg splitter_color) ~w:1 ~h:0 ~sw:0 ~sh:1 Ui.empty 272 272 - in 273 273 - let splitter = 274 274 - Ui.mouse_area 275 275 - (fun ~x:_ ~y:_ -> function 276 276 - | `Left -> 277 277 - `Grab 278 278 - ( (fun ~x ~y:_ -> 279 279 - match Lwd.peek state_var with 280 280 - | Split { pos; max } -> 281 281 - Lwd.set state_var (Re_split { pos; max; at = x }) 282 282 - | Re_split { pos; max; at } -> 283 283 - if at <> x then Lwd.set state_var (Re_split { pos; max; at = x })) 284 284 - , fun ~x:_ ~y:_ -> () ) 285 285 - | _ -> `Unhandled) 286 286 - splitter 287 287 - in 288 288 - let ui = Ui.join_x l (Ui.join_x splitter r) in 289 289 - let ui = Ui.resize ~w:10 ~h:10 ~sw:1 ~sh:1 ~mh:1000 ~mw:1000 ui in 290 290 - let ui = 291 291 - match state with 292 292 - | Split _ -> ui 293 293 - | Re_split { at; _ } -> 294 294 - Ui.transient_sensor 295 295 - (fun ~x ~y:_ ~w ~h:_ () -> 296 296 - let newpos = clampi (at - x) ~min:0 ~max:w in 297 297 - Lwd.set state_var (Split { pos = newpos; max = w })) 298 298 - ui 299 299 - in 300 300 - ui 301 301 - in 302 302 - Lwd.map2 ~f:render (Lwd.get state_var) (Lwd.pair left right) 303 303 - ;; 304 304 - 305 305 - let v_pane top bot = 306 306 - let state_var = Lwd.var (Split { pos = 5; max = 10 }) in 307 307 - let render state (top, bot) = 308 308 - let (Split { pos; max } | Re_split { pos; max; _ }) = state in 309 309 - let top = Ui.resize ~w:0 ~h:0 ~sw:1 ~sh:pos top in 310 310 - let bot = Ui.resize ~w:0 ~h:0 ~sw:1 ~sh:(max - pos) bot in 311 311 - let splitter = 312 312 - Ui.resize ~bg:Notty.A.(bg lightyellow) ~w:0 ~h:1 ~sw:1 ~sh:0 Ui.empty 313 313 - in 314 314 - let splitter = 315 315 - Ui.mouse_area 316 316 - (fun ~x:_ ~y:_ -> function 317 317 - | `Left -> 318 318 - `Grab 319 319 - ( (fun ~x:_ ~y -> 320 320 - match Lwd.peek state_var with 321 321 - | Split { pos; max } -> 322 322 - Lwd.set state_var (Re_split { pos; max; at = y }) 323 323 - | Re_split { pos; max; at } -> 324 324 - if at <> y then Lwd.set state_var (Re_split { pos; max; at = y })) 325 325 - , fun ~x:_ ~y:_ -> () ) 326 326 - | _ -> `Unhandled) 327 327 - splitter 328 328 - in 329 329 - let ui = Ui.join_y top (Ui.join_y splitter bot) in 330 330 - let ui = Ui.resize ~w:10 ~h:10 ~sw:1 ~sh:1 ui in 331 331 - let ui = 332 332 - match state with 333 333 - | Split _ -> ui 334 334 - | Re_split { at; _ } -> 335 335 - Ui.transient_sensor 336 336 - (fun ~x:_ ~y ~w:_ ~h () -> 337 337 - let newpos = clampi (at - y) ~min:0 ~max:h in 338 338 - Lwd.set state_var (Split { pos = newpos; max = h })) 339 339 - ui 340 340 - in 341 341 - ui 342 342 - in 343 343 - Lwd.map2 ~f:render (Lwd.get state_var) (Lwd.pair top bot) 344 344 - ;; 345 345 - 346 346 - let sub' str p l = if p = 0 && l = String.length str then str else String.sub str p l 347 347 - 348 348 - let edit_field ?(focus = Focus.make ()) state ~on_change ~on_submit = 349 349 - let update focus_h focus (text, pos) = 350 350 - let pos = clampi pos ~min:0 ~max:(String.length text) in 351 351 - let content = 352 352 - Ui.atom 353 353 - @@ I.hcat 354 354 - @@ 355 355 - if Focus.has_focus focus 356 356 - then ( 357 357 - let attr = attr_clickable in 358 358 - let len = String.length text in 359 359 - (if pos >= len 360 360 - then [ I.string attr text ] 361 361 - else [ I.string attr (sub' text 0 pos) ]) 362 362 - @ 363 363 - if pos < String.length text 364 364 - then 365 365 - [ I.string A.(bg lightred) (sub' text pos 1) 366 366 - ; I.string attr (sub' text (pos + 1) (len - pos - 1)) 367 367 - ] 368 368 - else [ I.string A.(bg lightred) " " ]) 369 369 - else [ I.string A.(st underline) (if text = "" then " " else text) ] 370 370 - in 371 371 - let handler = function 372 372 - | `ASCII 'U', [ `Ctrl ] -> 373 373 - on_change ("", 0); 374 374 - `Handled (* clear *) 375 375 - | `Escape, [] -> 376 376 - Focus.release focus_h; 377 377 - `Handled 378 378 - | `ASCII k, _ -> 379 379 - let text = 380 380 - if pos < String.length text 381 381 - then 382 382 - String.sub text 0 pos 383 383 - ^ String.make 1 k 384 384 - ^ String.sub text pos (String.length text - pos) 385 385 - else text ^ String.make 1 k 386 386 - in 387 387 - on_change (text, pos + 1); 388 388 - `Handled 389 389 - | `Backspace, _ -> 390 390 - let text = 391 391 - if pos > 0 392 392 - then 393 393 - if pos < String.length text 394 394 - then 395 395 - String.sub text 0 (pos - 1) ^ String.sub text pos (String.length text - pos) 396 396 - else if String.length text > 0 397 397 - then String.sub text 0 (String.length text - 1) 398 398 - else text 399 399 - else text 400 400 - in 401 401 - let pos = maxi 0 (pos - 1) in 402 402 - on_change (text, pos); 403 403 - `Handled 404 404 - | `Enter, _ -> 405 405 - on_submit (text, pos); 406 406 - `Handled 407 407 - | `Arrow `Left, [] -> 408 408 - let pos = mini (String.length text) pos in 409 409 - if pos > 0 410 410 - then ( 411 411 - on_change (text, pos - 1); 412 412 - `Handled) 413 413 - else `Unhandled 414 414 - | `Arrow `Right, [] -> 415 415 - let pos = pos + 1 in 416 416 - if pos <= String.length text 417 417 - then ( 418 418 - on_change (text, pos); 419 419 - `Handled) 420 420 - else `Unhandled 421 421 - | _ -> `Unhandled 422 422 - in 423 423 - Ui.keyboard_area ~focus handler content 424 424 - in 425 425 - let node = Lwd.map2 ~f:(update focus) (Focus.status focus) state in 426 426 - let mouse_grab (text, pos) ~x ~y:_ = function 427 427 - | `Left -> 428 428 - if x <> pos then on_change (text, x); 429 429 - Nottui.Focus.request focus; 430 430 - `Handled 431 431 - | _ -> `Unhandled 432 432 - in 433 433 - Lwd.map2 state node ~f:(fun state content -> Ui.mouse_area (mouse_grab state) content) 434 434 - ;; 435 435 - 436 436 - 437 437 - (** Tab view, where exactly one element of [l] is shown at a time. *) 438 438 - let tabs (tabs : (string * (unit -> Ui.t Lwd.t)) list) : Ui.t Lwd.t = 439 439 - match tabs with 440 440 - | [] -> Lwd.return Ui.empty 441 441 - | _ -> 442 442 - let cur = Lwd.var 0 in 443 443 - Lwd.get cur 444 444 - >>= fun idx_sel -> 445 445 - let _, f = List.nth tabs idx_sel in 446 446 - let tab_bar = 447 447 - tabs 448 448 - |> List.mapi (fun i (s, _) -> 449 449 - let attr = if i = idx_sel then A.(st underline) else A.empty in 450 450 - let tab_annot = printf ~attr "[%s]" s in 451 451 - Ui.mouse_area 452 452 - (fun ~x:_ ~y:_ l -> 453 453 - if l = `Left 454 454 - then ( 455 455 - Lwd.set cur i; 456 456 - `Handled) 457 457 - else `Unhandled) 458 458 - tab_annot) 459 459 - |> Ui.hcat 460 460 - in 461 461 - f () >|= Ui.join_y tab_bar 462 462 - ;; 463 463 - 464 464 - (** Horizontal/vertical box. We fill lines until there is no room, 465 465 - and then go to the next ligne. All widgets in a line are considered to 466 466 - have the same height. 467 467 - @param width dynamic width (default 80) *) 468 468 - let flex_box ?(w = Lwd.return 80) (l : Ui.t Lwd.t list) : Ui.t Lwd.t = 469 469 - Lwd_utils.flatten_l l 470 470 - >>= fun l -> 471 471 - w 472 472 - >|= fun w_limit -> 473 473 - let rec box_render (acc : Ui.t) (i : int) l : Ui.t = 474 474 - match l with 475 475 - | [] -> acc 476 476 - | ui0 :: tl -> 477 477 - let w0 = (Ui.layout_spec ui0).Ui.w in 478 478 - if i + w0 >= w_limit 479 479 - then (* newline starting with ui0 *) 480 480 - Ui.join_y acc (box_render ui0 w0 tl) 481 481 - else (* same line *) 482 482 - box_render (Ui.join_x acc ui0) (i + w0) tl 483 483 - in 484 484 - box_render Ui.empty 0 l 485 485 - ;; 486 486 - 487 487 - (** Prints the summary, but calls [f()] to compute a sub-widget 488 488 - when clicked on. Useful for displaying deep trees. Mouse only *) 489 489 - let unfoldable ?(folded_by_default = true) summary (f : unit -> Ui.t Lwd.t) : Ui.t Lwd.t = 490 490 - let open Lwd.Infix in 491 491 - let opened = Lwd.var (not folded_by_default) in 492 492 - let fold_content = 493 493 - Lwd.get opened 494 494 - >>= function 495 495 - | true -> 496 496 - (* call [f] and pad a bit *) 497 497 - f () |> Lwd.map ~f:(Ui.join_x (string " ")) 498 498 - | false -> empty_lwd 499 499 - in 500 500 - (* pad summary with a "> " when it's opened *) 501 501 - let summary = 502 502 - Lwd.get opened 503 503 - >>= fun op -> 504 504 - summary 505 505 - >|= fun s -> 506 506 - Ui.hcat [ string ~attr:attr_clickable (if op then "v" else ">"); string " "; s ] 507 507 - in 508 508 - let cursor ~x:_ ~y:_ = function 509 509 - | `Left when Lwd.peek opened -> 510 510 - Lwd.set opened false; 511 511 - `Handled 512 512 - | `Left -> 513 513 - Lwd.set opened true; 514 514 - `Handled 515 515 - | _ -> `Unhandled 516 516 - in 517 517 - let mouse = Lwd.map ~f:(fun m -> Ui.mouse_area cursor m) summary in 518 518 - Lwd.map2 mouse fold_content ~f:(fun summary fold -> 519 519 - (* TODO: make this configurable/optional *) 520 520 - (* newline if it's too big to fit on one line nicely *) 521 521 - let spec_sum = Ui.layout_spec summary in 522 522 - let spec_fold = Ui.layout_spec fold in 523 523 - (* TODO: somehow, probe for available width here? *) 524 524 - let too_big = 525 525 - spec_fold.Ui.h > 1 || (spec_fold.Ui.h > 0 && spec_sum.Ui.w + spec_fold.Ui.w > 60) 526 526 - in 527 527 - if too_big 528 528 - then Ui.join_y summary (Ui.join_x (string " ") fold) 529 529 - else Ui.join_x summary fold) 530 530 - ;; 531 531 - 532 532 - let hbox l = Lwd_utils.pack Ui.pack_x l 533 533 - let vbox l = Lwd_utils.pack Ui.pack_y l 534 534 - let zbox l = Lwd_utils.pack Ui.pack_z l 535 535 - 536 536 - let vlist ?(bullet = "- ") (l : Ui.t Lwd.t list) : Ui.t Lwd.t = 537 537 - l 538 538 - |> List.map (fun ui -> Lwd.map ~f:(Ui.join_x (string bullet)) ui) 539 539 - |> Lwd_utils.pack Ui.pack_y 540 540 - ;; 541 541 - 542 542 - (** A list of items with a dynamic filter on the items *) 543 543 - let vlist_with 544 544 - ?(bullet = "- ") 545 545 - ?(filter = Lwd.return (fun _ -> true)) 546 546 - (f : 'a -> Ui.t Lwd.t) 547 547 - (l : 'a list Lwd.t) 548 548 - : Ui.t Lwd.t 549 549 - = 550 550 - let open Lwd.Infix in 551 551 - let rec filter_map_ acc f l = 552 552 - match l with 553 553 - | [] -> List.rev acc 554 554 - | x :: l' -> 555 555 - let acc' = 556 556 - match f x with 557 557 - | None -> acc 558 558 - | Some y -> y :: acc 559 559 - in 560 560 - filter_map_ acc' f l' 561 561 - in 562 562 - let l = l >|= List.map (fun x -> x, Lwd.map ~f:(Ui.join_x (string bullet)) @@ f x) in 563 563 - let l_filter : _ list Lwd.t = 564 564 - filter 565 565 - >>= fun filter -> 566 566 - l >|= filter_map_ [] (fun (x, ui) -> if filter x then Some ui else None) 567 567 - in 568 568 - l_filter >>= Lwd_utils.pack Ui.pack_y 569 569 - ;; 570 570 - 571 571 - let rec iterate n f x = if n = 0 then x else iterate (n - 1) f (f x) 572 572 - 573 573 - (** A grid layout, with alignment in all rows/columns. 574 574 - @param max_h maximum height of a cell 575 575 - @param max_w maximum width of a cell 576 576 - @param bg attribute for controlling background style 577 577 - @param h_space horizontal space between each cell in a row 578 578 - @param v_space vertical space between each row 579 579 - @param pad used to control padding of cells 580 580 - @param crop 581 581 - used to control cropping of cells 582 582 - TODO: control padding/alignment, vertically and horizontally 583 583 - TODO: control align left/right in cells 584 584 - TODO: horizontal rule below headers 585 585 - TODO: headers *) 586 586 - let grid 587 587 - ?max_h 588 588 - ?max_w 589 589 - ?pad 590 590 - ?crop 591 591 - ?bg 592 592 - ?(h_space = 0) 593 593 - ?(v_space = 0) 594 594 - ?(headers : Ui.t Lwd.t list option) 595 595 - (rows : Ui.t Lwd.t list list) 596 596 - : Ui.t Lwd.t 597 597 - = 598 598 - let rows = 599 599 - match headers with 600 600 - | None -> rows 601 601 - | Some r -> r :: rows 602 602 - in 603 603 - (* build a [ui list list Lwd.t] *) 604 604 - Lwd_utils.map_l (fun r -> Lwd_utils.flatten_l r) rows 605 605 - >>= fun (rows : Ui.t list list) -> 606 606 - (* determine width of each column and height of each row *) 607 607 - let n_cols = List.fold_left (fun n r -> maxi n (List.length r)) 0 rows in 608 608 - let col_widths = Array.make n_cols 1 in 609 609 - List.iter 610 610 - (fun row -> 611 611 - List.iteri 612 612 - (fun col_j cell -> 613 613 - let w = (Ui.layout_spec cell).Ui.w in 614 614 - col_widths.(col_j) <- maxi col_widths.(col_j) w) 615 615 - row) 616 616 - rows; 617 617 - (match max_w with 618 618 - | None -> () 619 619 - | Some max_w -> 620 620 - (* limit width *) 621 621 - Array.iteri (fun i x -> col_widths.(i) <- mini x max_w) col_widths); 622 622 - (* now render, with some padding *) 623 623 - let pack_pad_x = 624 624 - if h_space <= 0 625 625 - then Ui.empty, Ui.join_x 626 626 - else Ui.empty, fun x y -> Ui.hcat [ x; Ui.space h_space 0; y ] 627 627 - and pack_pad_y = 628 628 - if v_space = 0 629 629 - then Ui.empty, Ui.join_y 630 630 - else Ui.empty, fun x y -> Ui.vcat [ x; Ui.space v_space 0; y ] 631 631 - in 632 632 - let rows = 633 633 - List.map 634 634 - (fun row -> 635 635 - let row_h = List.fold_left (fun n c -> maxi n (Ui.layout_spec c).Ui.h) 0 row in 636 636 - let row_h = 637 637 - match max_h with 638 638 - | None -> row_h 639 639 - | Some max_h -> mini row_h max_h 640 640 - in 641 641 - let row = 642 642 - List.mapi (fun i c -> Ui.resize ~w:col_widths.(i) ~h:row_h ?crop ?pad ?bg c) row 643 643 - in 644 644 - Lwd_utils.reduce pack_pad_x row) 645 645 - rows 646 646 - in 647 647 - (* TODO: mouse and keyboard handling *) 648 648 - let ui = Lwd_utils.reduce pack_pad_y rows in 649 649 - Lwd.return ui 650 650 - ;; 651 651 - 652 652 - (** Turn the given [ui] into a clickable button, calls [f] when clicked. *) 653 653 - let button_of ui f = 654 654 - Ui.mouse_area 655 655 - (fun ~x:_ ~y:_ _ -> 656 656 - f (); 657 657 - `Handled) 658 658 - ui 659 659 - ;; 660 660 - 661 661 - (** A clickable button that calls [f] when clicked, labelled with a string. *) 662 662 - let button ?(attr = attr_clickable) s f = button_of (string ~attr s) f 663 663 - 664 664 - (* file explorer for selecting a file using the mouse *) 665 665 - let file_select ?(abs = false) ?filter ~(on_select : string -> unit) () : Ui.t Lwd.t = 666 666 - let rec aux ~fold path = 667 667 - try 668 668 - let p_rel = if path = "" then "." else path in 669 669 - if Sys.is_directory p_rel 670 670 - then ( 671 671 - let ui () = 672 672 - let arr = Sys.readdir p_rel in 673 673 - let l = Array.to_list arr |> List.map (Filename.concat path) in 674 674 - (* apply potential filter *) 675 675 - let l = 676 676 - match filter with 677 677 - | None -> l 678 678 - | Some f -> List.filter f l 679 679 - in 680 680 - let l = Lwd.return @@ List.sort String.compare l in 681 681 - vlist_with ~bullet:"" (aux ~fold:true) l 682 682 - in 683 683 - if fold 684 684 - then unfoldable ~folded_by_default:true (Lwd.return @@ string @@ path ^ "/") ui 685 685 - else ui ()) 686 686 - else Lwd.return @@ button ~attr:A.(st underline) path (fun () -> on_select path) 687 687 - with 688 688 - | e -> 689 689 - Lwd.return 690 690 - @@ Ui.vcat 691 691 - [ printf ~attr:A.(bg red) "cannot list directory %s" path 692 692 - ; string @@ Printexc.to_string e 693 693 - ] 694 694 - in 695 695 - let start = if abs then Sys.getcwd () else "" in 696 696 - aux ~fold:false start 697 697 - ;; 698 698 - 699 699 - let toggle, toggle' = 700 700 - let toggle_ st (lbl : string Lwd.t) (f : bool -> unit) : Ui.t Lwd.t = 701 701 - let mk_but st_v lbl_v = 702 702 - let lbl = 703 703 - Ui.hcat 704 704 - [ printf "[%s|" lbl_v 705 705 - ; string ~attr:attr_clickable (if st_v then "✔" else "×") 706 706 - ; string "]" 707 707 - ] 708 708 - in 709 709 - button_of lbl (fun () -> 710 710 - let new_st = not st_v in 711 711 - Lwd.set st new_st; 712 712 - f new_st) 713 713 - in 714 714 - Lwd.map2 ~f:mk_but (Lwd.get st) lbl 715 715 - in 716 716 - (* Similar to {!toggle}, except it directly reflects the state of a variable. *) 717 717 - let toggle' (lbl : string Lwd.t) (v : bool Lwd.var) : Ui.t Lwd.t = 718 718 - toggle_ v lbl (Lwd.set v) 719 719 - (* a toggle, with a true/false state *) 720 720 - and toggle ?(init = false) (lbl : string Lwd.t) (f : bool -> unit) : Ui.t Lwd.t = 721 721 - let st = Lwd.var init in 722 722 - toggle_ st lbl f 723 723 - in 724 724 - toggle, toggle' 725 725 - ;; 726 726 - 727 727 - type scrollbox_state = 728 728 - { w : int 729 729 - ; h : int 730 730 - ; x : int 731 731 - ; y : int 732 732 - } 733 733 - 734 734 - let adjust_offset visible total off = 735 735 - let off = if off + visible > total then total - visible else off in 736 736 - let off = if off < 0 then 0 else off in 737 737 - off 738 738 - ;; 739 739 - 740 740 - let decr_if x cond = if cond then x - 1 else x 741 741 - let scrollbar_bg = Notty.A.gray 4 742 742 - let scrollbar_fg = Notty.A.gray 7 743 743 - let scrollbar_click_step = 3 (* Clicking scrolls one third of the screen *) 744 744 - let scrollbar_wheel_step = 8 (* Wheel event scrolls 1/8th of the screen *) 745 745 - 746 746 - let hscrollbar visible total offset ~set = 747 747 - let prefix = offset * visible / total in 748 748 - let suffix = (total - offset - visible) * visible / total in 749 749 - let handle = visible - prefix - suffix in 750 750 - let render size color = Ui.atom Notty.(I.char (A.bg color) ' ' size 1) in 751 751 - let mouse_handler ~x ~y:_ = function 752 752 - | `Left -> 753 753 - if x < prefix 754 754 - then ( 755 755 - set (offset - maxi 1 (visible / scrollbar_click_step)); 756 756 - `Handled) 757 757 - else if x > prefix + handle 758 758 - then ( 759 759 - set (offset + maxi 1 (visible / scrollbar_click_step)); 760 760 - `Handled) 761 761 - else 762 762 - `Grab 763 763 - ( (fun ~x:x' ~y:_ -> set (offset + ((x' - x) * total / visible))) 764 764 - , fun ~x:_ ~y:_ -> () ) 765 765 - | `Scroll dir -> 766 766 - let dir = 767 767 - match dir with 768 768 - | `Down -> 1 769 769 - | `Up -> -1 770 770 - in 771 771 - set (offset + (dir * maxi 1 (visible / scrollbar_wheel_step))); 772 772 - `Handled 773 773 - | _ -> `Unhandled 774 774 - in 775 775 - let ( ++ ) = Ui.join_x in 776 776 - Ui.mouse_area 777 777 - mouse_handler 778 778 - (render prefix scrollbar_bg 779 779 - ++ render handle scrollbar_fg 780 780 - ++ render suffix scrollbar_bg) 781 781 - ;; 782 782 - 783 783 - let vscrollbar visible total offset ~set = 784 784 - let prefix = offset * visible / total in 785 785 - let suffix = (total - offset - visible) * visible / total in 786 786 - let handle = visible - prefix - suffix in 787 787 - let render size color = Ui.atom Notty.(I.char (A.bg color) ' ' 1 size) in 788 788 - let mouse_handler ~x:_ ~y = function 789 789 - | `Left -> 790 790 - if y < prefix 791 791 - then ( 792 792 - set (offset - maxi 1 (visible / scrollbar_click_step)); 793 793 - `Handled) 794 794 - else if y > prefix + handle 795 795 - then ( 796 796 - set (offset + maxi 1 (visible / scrollbar_click_step)); 797 797 - `Handled) 798 798 - else 799 799 - `Grab 800 800 - ( (fun ~x:_ ~y:y' -> set (offset + ((y' - y) * total / visible))) 801 801 - , fun ~x:_ ~y:_ -> () ) 802 802 - | `Scroll dir -> 803 803 - let dir = 804 804 - match dir with 805 805 - | `Down -> 1 806 806 - | `Up -> -1 807 807 - in 808 808 - set (offset + (dir * maxi 1 (visible / scrollbar_wheel_step))); 809 809 - `Handled 810 810 - | _ -> `Unhandled 811 811 - in 812 812 - let ( ++ ) = Ui.join_y in 813 813 - Ui.mouse_area 814 814 - mouse_handler 815 815 - (render prefix scrollbar_bg 816 816 - ++ render handle scrollbar_fg 817 817 - ++ render suffix scrollbar_bg) 818 818 - ;; 819 819 - 820 820 - let scrollbox t = 821 821 - (* Keep track of scroll state *) 822 822 - let state_var = Lwd.var { w = 0; h = 0; x = 0; y = 0 } in 823 823 - (* Keep track of size available for display *) 824 824 - let update_size ~w ~h = 825 825 - let state = Lwd.peek state_var in 826 826 - if state.w <> w || state.h <> h then Lwd.set state_var { state with w; h } 827 827 - in 828 828 - let measure_size body = 829 829 - Ui.size_sensor update_size (Ui.resize ~w:0 ~h:0 ~sw:1 ~sh:1 body) 830 830 - in 831 831 - (* Given body and state, composite scroll bars *) 832 832 - let compose_bars body state = 833 833 - let bw, bh = Ui.layout_width body, Ui.layout_height body in 834 834 - (* Logic to determine which scroll bar should be visible *) 835 835 - let hvisible = state.w < bw 836 836 - and vvisible = state.h < bh in 837 837 - let hvisible = hvisible || (vvisible && state.w = bw) in 838 838 - let vvisible = vvisible || (hvisible && state.h = bh) in 839 839 - (* Compute size and offsets based on visibility *) 840 840 - let state_w = decr_if state.w vvisible in 841 841 - let state_h = decr_if state.h hvisible in 842 842 - let state_x = adjust_offset state_w bw state.x in 843 843 - let state_y = adjust_offset state_h bh state.y in 844 844 - (* Composite visible scroll bars *) 845 845 - let crop b = Ui.resize ~sw:1 ~sh:1 ~w:0 ~h:0 (Ui.shift_area state_x state_y b) in 846 846 - let set_vscroll y = 847 847 - let state = Lwd.peek state_var in 848 848 - if state.y <> y then Lwd.set state_var { state with y } 849 849 - in 850 850 - let set_hscroll x = 851 851 - let state = Lwd.peek state_var in 852 852 - if state.x <> x then Lwd.set state_var { state with x } 853 853 - in 854 854 - let ( <-> ) = Ui.join_y 855 855 - and ( <|> ) = Ui.join_x in 856 856 - match hvisible, vvisible with 857 857 - | false, false -> body 858 858 - | false, true -> crop body <|> vscrollbar state_h bh state_y ~set:set_vscroll 859 859 - | true, false -> crop body <-> hscrollbar state_w bw state_x ~set:set_hscroll 860 860 - | true, true -> 861 861 - crop body 862 862 - <|> vscrollbar state_h bh state_y ~set:set_vscroll 863 863 - <-> (hscrollbar state_w bw state_x ~set:set_hscroll <|> Ui.space 1 1) 864 864 - in 865 865 - (* Render final box *) 866 866 - Lwd.map2 t (Lwd.get state_var) ~f:(fun ui size -> measure_size (compose_bars ui size)) 867 867 - ;;

-116

forks/lwd/lib/nottui/nottui_widgets.mli

reviewed

··· 1 1 - open Notty 2 2 - open Nottui 3 3 - 4 4 - val empty_lwd : ui Lwd.t 5 5 - 6 6 - (* Primitive printing *) 7 7 - 8 8 - (** Ui element from a string *) 9 9 - val string : ?attr:attr -> string -> ui 10 10 - 11 11 - (** Ui element from an int *) 12 12 - val int : ?attr:attr -> int -> ui 13 13 - 14 14 - (** Ui element from a boolean *) 15 15 - val bool : ?attr:attr -> bool -> ui 16 16 - 17 17 - (** Ui element from a float *) 18 18 - val float_ : ?attr:attr -> float -> ui 19 19 - 20 20 - (** Printf support *) 21 21 - val printf : ?attr:attr -> ('a, unit, string, ui) format4 -> 'a 22 22 - val kprintf : (ui -> 'a) -> ?attr:attr -> ('b, unit, string, 'a) format4 -> 'b 23 23 - 24 24 - val fmt : ?attr:attr -> ('a, Format.formatter, unit, ui) format4 -> 'a 25 25 - val kfmt : (ui -> 'a) -> ?attr:attr -> ('b, Format.formatter, unit, 'a) format4 -> 'b 26 26 - 27 27 - (* window manager *) 28 28 - type window_manager 29 29 - val window_manager : ui Lwd.t -> window_manager 30 30 - val window_manager_view : window_manager -> ui Lwd.t 31 31 - val window_manager_overlays : window_manager -> ui Lwd.t Lwd_table.t 32 32 - 33 33 - (* FIXME Menu *) 34 34 - val menu_overlay : window_manager -> gravity -> ?dx:int -> ?dy:int -> ui Lwd.t -> ui -> ui 35 35 - val main_menu_item : window_manager -> string -> (unit -> ui Lwd.t) -> ui Lwd.t 36 36 - val sub_menu_item : window_manager -> string -> (unit -> ui Lwd.t) -> ui Lwd.t 37 37 - val sub_entry : string -> (unit -> unit) -> ui 38 38 - 39 39 - (* FIXME Explain how scrolling works *) 40 40 - val scroll_step : int 41 41 - type scroll_state = { position : int; bound : int; visible : int; total : int } 42 42 - val default_scroll_state : scroll_state 43 43 - 44 44 - val vscroll_area : 45 45 - state:scroll_state Lwd.t -> 46 46 - change:([> `Action | `Content ] -> scroll_state -> unit) -> 47 47 - ui Lwd.t -> ui Lwd.t 48 48 - 49 49 - (** A scrollable area that supports *) 50 50 - val scrollbox: ui Lwd.t -> ui Lwd.t 51 51 - 52 52 - (** Vertical pane that can be dragged to be bigger or smaller *) 53 53 - val v_pane : ui Lwd.t -> ui Lwd.t -> ui Lwd.t 54 54 - (** horizontal pane that can be dragged to be bigger or smaller *) 55 55 - val h_pane : ?splitter_color:(Notty.A.color)-> ui Lwd.t -> ui Lwd.t -> ui Lwd.t 56 56 - 57 57 - (** An editable text field. 58 58 - Supports navigating with arrow keys *) 59 59 - val edit_field : 60 60 - ?focus:Focus.handle -> 61 61 - (string * int) Lwd.t -> 62 62 - on_change:(string * int -> unit) -> 63 63 - on_submit:(string * int -> unit) -> ui Lwd.t 64 64 - 65 65 - (* FIXME Tabs *) 66 66 - 67 67 - val tabs : (string * (unit -> ui Lwd.t)) list -> ui Lwd.t 68 68 - 69 69 - (* FIXME Flex box *) 70 70 - 71 71 - val flex_box : ?w:int Lwd.t -> ui Lwd.t list -> ui Lwd.t 72 72 - 73 73 - (** Shows the summary when folded, calls [f()] to compute a sub-widget when clicked on. Useful for displaying deep trees. Mouse only *) 74 74 - val unfoldable : 75 75 - ?folded_by_default:bool -> 76 76 - ui Lwd.t -> (unit -> ui Lwd.t) -> ui Lwd.t 77 77 - 78 78 - (** Horizontally stacks Ui elements *) 79 79 - val hbox : ui Lwd.t list -> ui Lwd.t 80 80 - (** Horizontally stacks ui elements *) 81 81 - val vbox : ui Lwd.t list -> ui Lwd.t 82 82 - (** Stacks Ui elements infront of one another *) 83 83 - val zbox : ui Lwd.t list -> ui Lwd.t 84 84 - 85 85 - (* FIXME List *) 86 86 - val vlist : ?bullet:string -> ui Lwd.t list -> ui Lwd.t 87 87 - 88 88 - val vlist_with : 89 89 - ?bullet:string -> 90 90 - ?filter:('a -> bool) Lwd.t -> 91 91 - ('a -> ui Lwd.t) -> 'a list Lwd.t -> ui Lwd.t 92 92 - 93 93 - (* FIXME This should probably go somewhere else *) 94 94 - val iterate :int -> ('a -> 'a) -> 'a -> 'a 95 95 - 96 96 - val grid : 97 97 - ?max_h:int -> ?max_w:int -> 98 98 - ?pad:gravity -> ?crop:gravity -> ?bg:attr -> 99 99 - ?h_space:int -> ?v_space:int -> 100 100 - ?headers:ui Lwd.t list -> 101 101 - ui Lwd.t list list -> ui Lwd.t 102 102 - 103 103 - (** A clickable button that calls [f] when clicked, labelled with a string. *) 104 104 - val button : ?attr:attr -> string -> (unit -> unit) -> ui 105 105 - 106 106 - (** A mouse_based file selection widget that opens at the current path *) 107 107 - val file_select : 108 108 - ?abs:bool -> 109 109 - ?filter:(String.t -> bool) -> 110 110 - on_select:(string -> unit) -> unit -> ui Lwd.t 111 111 - 112 112 - (** A toggle button that invokes the callback when toggled*) 113 113 - val toggle : ?init:bool -> string Lwd.t -> (bool -> unit) -> ui Lwd.t 114 114 - 115 115 - (** A toggle button that changes the state of the Lwd.var when toggled*) 116 116 - val toggle' : string Lwd.t -> bool Lwd.var -> ui Lwd.t

-2

forks/lwd/lib/tyxml-lwd/Makefile

reviewed

··· 1 1 - all: 2 2 - dune build @all

-8

forks/lwd/lib/tyxml-lwd/dune

reviewed

··· 1 1 - (library 2 2 - (name tyxml_lwd) 3 3 - (wrapped false) 4 4 - (public_name tyxml-lwd) 5 5 - (modes byte) 6 6 - (preprocess 7 7 - (pps js_of_ocaml-ppx)) 8 8 - (libraries tyxml.functor js_of_ocaml lwd))

-1911

forks/lwd/lib/tyxml-lwd/tyxml_lwd.ml

reviewed

··· 1 1 - open Js_of_ocaml 2 2 - 3 3 - type raw_node = Dom.node Js.t 4 4 - type 'a live = 'a Lwd_seq.t Lwd.t 5 5 - type 'a attr = 'a option Lwd.t 6 6 - 7 7 - let some x = Some x 8 8 - let empty = Lwd.pure Lwd_seq.empty 9 9 - 10 10 - module W : Xml_wrap.T 11 11 - with type 'a t = 'a Lwd.t 12 12 - with type ('a, 'b) ft = 'a -> 'b 13 13 - with type 'a tlist = 'a Lwd.t list 14 14 - = 15 15 - struct 16 16 - type 'a t = 'a Lwd.t 17 17 - type (-'a, 'b) ft = 'a -> 'b 18 18 - type 'a tlist = 'a Lwd.t list 19 19 - 20 20 - let return = Lwd.pure 21 21 - let fmap f x = Lwd.map ~f x 22 22 - let nil () = [] 23 23 - let singleton x = [x] 24 24 - let append = (@) 25 25 - let cons x xs = x :: xs 26 26 - let map f xs = List.map (fun x -> Lwd.map ~f x) xs 27 27 - end 28 28 - 29 29 - type child_tree = 30 30 - | Leaf of raw_node 31 31 - | Inner of { mutable bound: raw_node Js.opt; 32 32 - left: child_tree; right: child_tree; } 33 33 - 34 34 - let child_node node = Leaf node 35 35 - 36 36 - let child_join left right = Inner { bound = Js.null; left; right } 37 37 - 38 38 - let js_lwd_to_remove = 39 39 - Js.string "lwd-to-remove" (* HACK Could be turned into a Javascript symbol *) 40 40 - 41 41 - let contains_focus node = 42 42 - Js.to_bool (Js.Unsafe.meth_call (node : raw_node) "contains" 43 43 - [|Js.Unsafe.inject Dom_html.document##.activeElement|]) 44 44 - 45 45 - let update_children (self : raw_node) (children : raw_node live) : unit Lwd.t = 46 46 - let reducer = 47 47 - ref (Lwd_seq.Reducer.make ~map:child_node ~reduce:child_join) 48 48 - in 49 49 - Lwd.map children ~f:begin fun children -> 50 50 - let dropped, reducer' = 51 51 - Lwd_seq.Reducer.update_and_get_dropped !reducer children in 52 52 - reducer := reducer'; 53 53 - let schedule_for_removal child () = match child with 54 54 - | Leaf node -> Js.Unsafe.set node js_lwd_to_remove Js._true 55 55 - | Inner _ -> () 56 56 - in 57 57 - Lwd_seq.Reducer.fold_dropped `Map schedule_for_removal dropped (); 58 58 - let preserve_focus = contains_focus self in 59 59 - begin match Lwd_seq.Reducer.reduce reducer' with 60 60 - | None -> () 61 61 - | Some tree -> 62 62 - let rec update acc = function 63 63 - | Leaf x -> 64 64 - Js.Unsafe.delete x js_lwd_to_remove; 65 65 - if x##.parentNode != Js.some self then 66 66 - ignore (self##insertBefore x acc) 67 67 - else if x##.nextSibling != acc then begin 68 68 - (* Parent is correct but sibling is not: swap nodes, but be 69 69 - cautious with focus *) 70 70 - if preserve_focus && contains_focus x then ( 71 71 - let rec shift_siblings () = 72 72 - let sibling = x##.nextSibling in 73 73 - if sibling == acc then 74 74 - true 75 75 - else match Js.Opt.to_option sibling with 76 76 - | None -> false 77 77 - | Some sibling -> 78 78 - ignore (self##insertBefore sibling (Js.some x)); 79 79 - shift_siblings () 80 80 - in 81 81 - if not (shift_siblings ()) then 82 82 - ignore (self##insertBefore x acc) 83 83 - ) 84 84 - else 85 85 - ignore (self##insertBefore x acc) 86 86 - end; 87 87 - Js.some x 88 88 - | Inner t -> 89 89 - if Js.Opt.test t.bound then t.bound else ( 90 90 - let acc = update acc t.right in 91 91 - let acc = update acc t.left in 92 92 - t.bound <- acc; 93 93 - acc 94 94 - ) 95 95 - in 96 96 - ignore (update Js.null tree) 97 97 - end; 98 98 - let remove_child child () = match child with 99 99 - | Leaf node -> 100 100 - if Js.Opt.test (Js.Unsafe.get node js_lwd_to_remove) then 101 101 - ignore (self##removeChild node) 102 102 - | Inner _ -> () 103 103 - in 104 104 - Lwd_seq.Reducer.fold_dropped `Map remove_child dropped (); 105 105 - end 106 106 - 107 107 - let update_children_list self children = 108 108 - update_children self (Lwd.join (Lwd_utils.pack Lwd_seq.lwd_monoid children)) 109 109 - 110 110 - module Attrib = struct 111 111 - type t = 112 112 - | Event of 113 113 - { name: string; value: (Dom_html.event Js.t -> bool) attr } 114 114 - | Event_mouse of 115 115 - { name: string; value: (Dom_html.mouseEvent Js.t -> bool) attr } 116 116 - | Event_keyboard of 117 117 - { name: string; value: (Dom_html.keyboardEvent Js.t -> bool) attr } 118 118 - | Event_touch of 119 119 - { name: string; value: (Dom_html.touchEvent Js.t -> bool) attr } 120 120 - | Attrib of 121 121 - { name: string; value: Js.js_string Js.t attr } 122 122 - end 123 123 - 124 124 - module Xml : 125 125 - sig 126 126 - include Xml_sigs.T 127 127 - with module W = W 128 128 - and type uri = string 129 129 - and type elt = raw_node live 130 130 - and type attrib = Attrib.t 131 131 - and type event_handler = (Dom_html.event Js.t -> bool) attr 132 132 - and type mouse_event_handler = (Dom_html.mouseEvent Js.t -> bool) attr 133 133 - and type keyboard_event_handler = (Dom_html.keyboardEvent Js.t -> bool) attr 134 134 - and type touch_event_handler = (Dom_html.touchEvent Js.t -> bool) attr 135 135 - 136 136 - end 137 137 - = struct 138 138 - 139 139 - module W = W 140 140 - 141 141 - type elt = raw_node live 142 142 - type 'a wrap = 'a W.t 143 143 - type 'a list_wrap = 'a W.tlist 144 144 - 145 145 - type uri = string 146 146 - let uri_of_string s = s 147 147 - let string_of_uri s = s 148 148 - 149 149 - type aname = string 150 150 - 151 151 - type event_handler = (Dom_html.event Js.t -> bool) attr 152 152 - type mouse_event_handler = (Dom_html.mouseEvent Js.t -> bool) attr 153 153 - type keyboard_event_handler = (Dom_html.keyboardEvent Js.t -> bool) attr 154 154 - type touch_event_handler = (Dom_html.touchEvent Js.t -> bool) attr 155 155 - 156 156 - type attrib = Attrib.t 157 157 - 158 158 - let attrib name value f = Attrib.Attrib {name; value = Lwd.map ~f value} 159 159 - 160 160 - let js_string_of_float f = (Js.number_of_float f)##toString 161 161 - let js_string_of_int i = (Js.number_of_float (float_of_int i))##toString 162 162 - 163 163 - let float_attrib n v = attrib n v 164 164 - (fun v -> Some (js_string_of_float v)) 165 165 - let int_attrib n v = attrib n v 166 166 - (fun v -> Some (js_string_of_int v)) 167 167 - let string_attrib n v = attrib n v 168 168 - (fun v -> Some (Js.string v)) 169 169 - let space_sep_attrib n v = attrib n v 170 170 - (fun v -> Some (Js.string (String.concat " " v))) 171 171 - let comma_sep_attrib n v = attrib n v 172 172 - (fun v -> Some (Js.string (String.concat "," v))) 173 173 - 174 174 - let event_handler_attrib n v = 175 175 - Attrib.Event {name = n; value = v} 176 176 - 177 177 - let mouse_event_handler_attrib n v = 178 178 - Attrib.Event_mouse {name = n; value = v} 179 179 - 180 180 - let keyboard_event_handler_attrib n v = 181 181 - Attrib.Event_keyboard {name = n; value = v} 182 182 - 183 183 - let touch_event_handler_attrib n v = 184 184 - Attrib.Event_touch {name = n; value = v} 185 185 - 186 186 - let uri_attrib n v = attrib n v 187 187 - (fun v -> Some (Js.string v)) 188 188 - 189 189 - let uris_attrib n v = attrib n v 190 190 - (fun v -> Some (Js.string (String.concat " " v))) 191 191 - 192 192 - let attach_attrib (node: #Dom.element Js.t) name value = 193 193 - let f = match name with 194 194 - | "style" -> (function 195 195 - | None -> node##.style##.cssText := Js.string "" 196 196 - | Some v -> node##.style##.cssText := v 197 197 - ) 198 198 - | "value" -> (function 199 199 - | None -> (Obj.magic node : _ Js.t)##.value := Js.string "" 200 200 - | Some v -> (Obj.magic node : _ Js.t)##.value := v 201 201 - ) 202 202 - | name -> let name = Js.string name in (function 203 203 - | None -> node##removeAttribute name 204 204 - | Some v -> node##setAttribute name v 205 205 - ) 206 206 - in 207 207 - Lwd.map ~f value 208 208 - 209 209 - let attach_event (node: #Dom.element Js.t) name value = 210 210 - let name = Js.string name in 211 211 - Lwd.map ~f:(function 212 212 - | None -> Js.Unsafe.set node name Js.null 213 213 - | Some v -> Js.Unsafe.set node name (fun ev -> Js.bool (v ev)) 214 214 - ) value 215 215 - 216 216 - (** Element *) 217 217 - 218 218 - type data = raw_node 219 219 - 220 220 - type ename = string 221 221 - 222 222 - let pure x = Lwd.pure (Lwd_seq.element x) 223 223 - let as_node (x : #Dom.node Js.t) = (x :> Dom.node Js.t) 224 224 - let pure_node x = pure (as_node x) 225 225 - 226 226 - let empty () = empty 227 227 - 228 228 - let comment c = pure_node (Dom_html.document##createComment (Js.string c)) 229 229 - 230 230 - let pcdata (text : string Lwd.t) : elt = 231 231 - let node = 232 232 - Lwd_seq.element (Dom_html.document##createTextNode (Js.string "")) 233 233 - in 234 234 - Lwd.map text ~f:(fun text -> 235 235 - begin match Lwd_seq.view node with 236 236 - | Lwd_seq.Element elt -> elt##.data := Js.string text; 237 237 - | _ -> assert false 238 238 - end; 239 239 - (node : Dom.text Js.t Lwd_seq.t :> raw_node Lwd_seq.t) 240 240 - ) 241 241 - 242 242 - let encodedpcdata = pcdata 243 243 - 244 244 - let entity = 245 245 - let string_fold s ~pos ~init ~f = 246 246 - let r = ref init in 247 247 - for i = pos to String.length s - 1 do 248 248 - let c = s.[i] in 249 249 - r := f !r c 250 250 - done; 251 251 - !r 252 252 - in 253 253 - let invalid_entity e = failwith (Printf.sprintf "Invalid entity %S" e) in 254 254 - let int_of_char = function 255 255 - | '0' .. '9' as x -> Some (Char.code x - Char.code '0') 256 256 - | 'a' .. 'f' as x -> Some (Char.code x - Char.code 'a' + 10) 257 257 - | 'A' .. 'F' as x -> Some (Char.code x - Char.code 'A' + 10) 258 258 - | _ -> None 259 259 - in 260 260 - let parse_int ~pos ~base e = 261 261 - string_fold e ~pos ~init:0 ~f:(fun acc x -> 262 262 - match int_of_char x with 263 263 - | Some d when d < base -> (acc * base) + d 264 264 - | Some _ | None -> invalid_entity e) 265 265 - in 266 266 - let is_alpha_num = function 267 267 - | '0' .. '9' | 'a' .. 'z' | 'A' .. 'Z' -> true 268 268 - | _ -> false 269 269 - in 270 270 - fun e -> 271 271 - let len = String.length e in 272 272 - let str = 273 273 - if len >= 1 && Char.equal e.[0] '#' 274 274 - then 275 275 - let i = 276 276 - if len >= 2 && (Char.equal e.[1] 'x' || Char.equal e.[1] 'X') 277 277 - then parse_int ~pos:2 ~base:16 e 278 278 - else parse_int ~pos:1 ~base:10 e 279 279 - in 280 280 - Js.string_constr##fromCharCode i 281 281 - else if string_fold e ~pos:0 ~init:true ~f:(fun acc x -> 282 282 - (* This is not quite right according to 283 283 - https://www.xml.com/axml/target.html#NT-Name. 284 284 - but it seems to cover all html5 entities 285 285 - https://dev.w3.org/html5/html-author/charref *) 286 286 - acc && is_alpha_num x) 287 287 - then 288 288 - match e with 289 289 - | "quot" -> Js.string "\"" 290 290 - | "amp" -> Js.string "&" 291 291 - | "apos" -> Js.string "'" 292 292 - | "lt" -> Js.string "<" 293 293 - | "gt" -> Js.string ">" 294 294 - | "" -> invalid_entity e 295 295 - | _ -> Dom_html.decode_html_entities (Js.string ("&" ^ e ^ ";")) 296 296 - else invalid_entity e 297 297 - in 298 298 - pure_node (Dom_html.document##createTextNode str) 299 299 - 300 300 - let attach_attribs node l = 301 301 - Lwd_utils.pack ((), fun () () -> ()) 302 302 - (List.map (function 303 303 - | Attrib.Attrib {name; value} -> attach_attrib node name value 304 304 - | Event {name; value} -> attach_event node name value 305 305 - | Event_mouse {name; value} -> attach_event node name value 306 306 - | Event_keyboard {name; value} -> attach_event node name value 307 307 - | Event_touch {name; value} -> attach_event node name value 308 308 - ) l) 309 309 - 310 310 - let rec find_ns : attrib list -> Js.js_string Js.t option = function 311 311 - | [] -> None 312 312 - | Attrib {name = "xmlns"; value} :: _ -> 313 313 - begin 314 314 - (* The semantics should not differ whether an Lwd value is pure or not, 315 315 - but let's do an exception for xml namespaces (those are managed 316 316 - differently from other and can't be changed at runtime). *) 317 317 - match Lwd.is_pure value with 318 318 - | None -> 319 319 - prerr_endline "xmlns attribute should be static"; 320 320 - None 321 321 - | Some x -> x 322 322 - end 323 323 - | _ :: rest -> find_ns rest 324 324 - 325 325 - let createElement ~ns name = 326 326 - let name = Js.string name in 327 327 - match ns with 328 328 - | None -> Dom_html.document##createElement name 329 329 - | Some ns -> Dom_html.document##createElementNS ns name 330 330 - 331 331 - let leaf ?(a = []) name : elt = 332 332 - let e = createElement ~ns:(find_ns a) name in 333 333 - let e' = Lwd_seq.element (e : Dom_html.element Js.t :> data) in 334 334 - Lwd.map (attach_attribs e a) ~f:(fun () -> e') 335 335 - 336 336 - let node ?(a = []) name (children : elt list_wrap) : elt = 337 337 - let e = createElement ~ns:(find_ns a) name in 338 338 - let e' = Lwd_seq.element e in 339 339 - Lwd.map2 340 340 - (update_children_list (e :> data) children) 341 341 - (attach_attribs e a) 342 342 - ~f:(fun () () -> (e' :> data Lwd_seq.t)) 343 343 - 344 344 - let cdata s = pure_node (Dom_html.document##createTextNode (Js.string s)) 345 345 - 346 346 - let cdata_script s = cdata s 347 347 - 348 348 - let cdata_style s = cdata s 349 349 - end 350 350 - 351 351 - type +'a node = raw_node 352 352 - type +'a attrib = Xml.attrib 353 353 - 354 354 - module Raw_svg = Svg_f.Make(struct 355 355 - include Xml 356 356 - 357 357 - let svg_xmlns = Attrib.Attrib { 358 358 - name = "xmlns"; 359 359 - value = Lwd.pure (Some (Js.string "http://www.w3.org/2000/svg")); 360 360 - } 361 361 - 362 362 - let leaf ?(a = []) name = 363 363 - leaf ~a:(svg_xmlns :: a) name 364 364 - 365 365 - let node ?(a = []) name (children : elt list_wrap) = 366 366 - node ~a:(svg_xmlns :: a) name children 367 367 - end) 368 368 - 369 369 - open Svg_types 370 370 - module Svg : sig 371 371 - type +'a elt = 'a node live 372 372 - type doc = [`Svg] elt 373 373 - type nonrec +'a attrib = 'a attrib 374 374 - 375 375 - module Xml = Xml 376 376 - type ('a, 'b) nullary = ?a:'a attrib list -> unit -> 'b elt 377 377 - type ('a, 'b, 'c) unary = ?a:'a attrib list -> 'b elt -> 'c elt 378 378 - type ('a, 'b, 'c) star = ?a:'a attrib list -> 'b elt list -> 'c elt 379 379 - 380 380 - module Info : Xml_sigs.Info 381 381 - type uri = string 382 382 - val string_of_uri : uri -> string 383 383 - val uri_of_string : string -> uri 384 384 - 385 385 - val a_x : Unit.length Lwd.t -> [>`X] attrib 386 386 - val a_y : Unit.length Lwd.t -> [>`Y] attrib 387 387 - val a_width : Unit.length Lwd.t -> [>`Width] attrib 388 388 - val a_height : Unit.length Lwd.t -> [>`Height] attrib 389 389 - val a_preserveAspectRatio : uri Lwd.t -> [>`PreserveAspectRatio] attrib 390 390 - val a_zoomAndPan : [<`Disable|`Magnify] Lwd.t -> [>`ZoomAndSpan] attrib 391 391 - val a_href : uri Lwd.t -> [>`Xlink_href] attrib 392 392 - val a_requiredExtensions : spacestrings Lwd.t -> [>`RequiredExtension] attrib 393 393 - val a_systemLanguage : 394 394 - commastrings Lwd.t -> [>`SystemLanguage] attrib 395 395 - val a_externalRessourcesRequired : 396 396 - bool Lwd.t -> [>`ExternalRessourcesRequired] attrib 397 397 - val a_id : uri Lwd.t -> [>`Id] attrib 398 398 - val a_user_data : uri -> uri Lwd.t -> [>`User_data] attrib 399 399 - val a_xml_lang : uri Lwd.t -> [>`Xml_Lang] attrib 400 400 - val a_type : uri Lwd.t -> [>`Type] attrib 401 401 - val a_media : commastrings Lwd.t -> [>`Media] attrib 402 402 - val a_class : spacestrings Lwd.t -> [>`Class] attrib 403 403 - val a_style : uri Lwd.t -> [>`Style] attrib 404 404 - val a_transform : transforms Lwd.t -> [>`Transform] attrib 405 405 - val a_viewBox : fourfloats Lwd.t -> [>`ViewBox] attrib 406 406 - val a_d : uri Lwd.t -> [>`D] attrib 407 407 - val a_pathLength : float Lwd.t -> [>`PathLength] attrib 408 408 - val a_rx : Unit.length Lwd.t -> [>`Rx] attrib 409 409 - val a_ry : Unit.length Lwd.t -> [>`Ry] attrib 410 410 - val a_cx : Unit.length Lwd.t -> [>`Cx] attrib 411 411 - val a_cy : Unit.length Lwd.t -> [>`Cy] attrib 412 412 - val a_r : Unit.length Lwd.t -> [>`R] attrib 413 413 - val a_x1 : Unit.length Lwd.t -> [>`X1] attrib 414 414 - val a_y1 : Unit.length Lwd.t -> [>`Y1] attrib 415 415 - val a_x2 : Unit.length Lwd.t -> [>`X2] attrib 416 416 - val a_y2 : Unit.length Lwd.t -> [>`Y2] attrib 417 417 - val a_points : coords Lwd.t -> [>`Points] attrib 418 418 - val a_x_list : lengths Lwd.t -> [>`X_list] attrib 419 419 - val a_y_list : lengths Lwd.t -> [>`Y_list] attrib 420 420 - val a_dx : float Lwd.t -> [>`Dx] attrib 421 421 - val a_dy : float Lwd.t -> [>`Dy] attrib 422 422 - val a_dx_list : lengths Lwd.t -> [>`Dx_list] attrib 423 423 - val a_dy_list : lengths Lwd.t -> [>`Dy_list] attrib 424 424 - val a_lengthAdjust : 425 425 - [<`Spacing|`SpacingAndGlyphs] Lwd.t -> [>`LengthAdjust] attrib 426 426 - val a_textLength : Unit.length Lwd.t -> [>`TextLength] attrib 427 427 - val a_text_anchor : 428 428 - [<`End|`Inherit|`Middle|`Start] Lwd.t -> [>`Text_Anchor] attrib 429 429 - val a_text_decoration : 430 430 - [<`Blink|`Inherit|`Line_through|`None|`Overline|`Underline] Lwd.t -> 431 431 - [>`Text_Decoration] attrib 432 432 - val a_text_rendering : 433 433 - [<`Auto|`GeometricPrecision|`Inherit 434 434 - |`OptimizeLegibility|`OptimizeSpeed] Lwd.t -> 435 435 - [>`Text_Rendering] attrib 436 436 - val a_rotate : numbers Lwd.t -> [>`Rotate] attrib 437 437 - val a_startOffset : Unit.length Lwd.t -> [>`StartOffset] attrib 438 438 - val a_method : [<`Align | `Stretch] Lwd.t -> [>`Method] attrib 439 439 - val a_spacing : [<`Auto | `Exact] Lwd.t -> [>`Spacing] attrib 440 440 - val a_glyphRef : uri Lwd.t -> [>`GlyphRef] attrib 441 441 - val a_format : uri Lwd.t -> [>`Format] attrib 442 442 - val a_markerUnits : 443 443 - [<`StrokeWidth | `UserSpaceOnUse] Lwd.t -> [>`MarkerUnits] attrib 444 444 - val a_refX : Unit.length Lwd.t -> [>`RefX] attrib 445 445 - val a_refY : Unit.length Lwd.t -> [>`RefY] attrib 446 446 - val a_markerWidth : Unit.length Lwd.t -> [>`MarkerWidth] attrib 447 447 - val a_markerHeight : 448 448 - Unit.length Lwd.t -> [>`MarkerHeight] attrib 449 449 - val a_orient : Unit.angle option Lwd.t -> [>`Orient] attrib 450 450 - val a_local : uri Lwd.t -> [>`Local] attrib 451 451 - val a_rendering_intent : 452 452 - [<`Absolute_colorimetric|`Auto|`Perceptual 453 453 - |`Relative_colorimetric|`Saturation] Lwd.t -> 454 454 - [>`Rendering_Indent] attrib 455 455 - val a_gradientUnits : 456 456 - [<`ObjectBoundingBox|`UserSpaceOnUse] Lwd.t -> [`GradientUnits] attrib 457 457 - val a_gradientTransform : transforms Lwd.t -> [>`Gradient_Transform] attrib 458 458 - val a_spreadMethod : [<`Pad|`Reflect|`Repeat] Lwd.t -> [>`SpreadMethod] attrib 459 459 - val a_fx : Unit.length Lwd.t -> [>`Fx] attrib 460 460 - val a_fy : Unit.length Lwd.t -> [>`Fy] attrib 461 461 - val a_offset : [<`Number of float | `Percentage of float] Lwd.t -> 462 462 - [>`Offset] attrib 463 463 - val a_patternUnits : [<`ObjectBoundingBox|`UserSpaceOnUse] Lwd.t -> 464 464 - [>`PatternUnits] attrib 465 465 - val a_patternContentUnits : [<`ObjectBoundingBox|`UserSpaceOnUse] Lwd.t -> 466 466 - [>`PatternContentUnits] attrib 467 467 - val a_patternTransform : transforms Lwd.t -> [>`PatternTransform] attrib 468 468 - val a_clipPathUnits : [<`ObjectBoundingBox|`UserSpaceOnUse] Lwd.t -> 469 469 - [>`ClipPathUnits] attrib 470 470 - val a_maskUnits : [<`ObjectBoundingBox|`UserSpaceOnUse] Lwd.t -> 471 471 - [>`MaskUnits] attrib 472 472 - val a_maskContentUnits : [<`ObjectBoundingBox|`UserSpaceOnUse] Lwd.t -> 473 473 - [>`MaskContentUnits] attrib 474 474 - val a_primitiveUnits : [<`ObjectBoundingBox|`UserSpaceOnUse] Lwd.t -> 475 475 - [>`PrimitiveUnits] attrib 476 476 - val a_filterRes : number_optional_number Lwd.t -> [>`FilterResUnits] attrib 477 477 - val a_result : uri Lwd.t -> [>`Result] attrib 478 478 - val a_in : 479 479 - [<`BackgroundAlpha|`BackgroundImage|`FillPaint|`Ref of uri 480 480 - |`SourceAlpha|`SourceGraphic|`StrokePaint] Lwd.t -> [>`In] attrib 481 481 - val a_in2 : 482 482 - [<`BackgroundAlpha|`BackgroundImage|`FillPaint|`Ref of uri 483 483 - |`SourceAlpha|`SourceGraphic|`StrokePaint] Lwd.t -> [>`In2] attrib 484 484 - val a_azimuth : float Lwd.t -> [>`Azimuth] attrib 485 485 - val a_elevation : float Lwd.t -> [>`Elevation] attrib 486 486 - val a_pointsAtX : float Lwd.t -> [>`PointsAtX] attrib 487 487 - val a_pointsAtY : float Lwd.t -> [>`PointsAtY] attrib 488 488 - val a_pointsAtZ : float Lwd.t -> [>`PointsAtZ] attrib 489 489 - val a_specularExponent : float Lwd.t -> [>`SpecularExponent] attrib 490 490 - val a_specularConstant : float Lwd.t -> [>`SpecularConstant] attrib 491 491 - val a_limitingConeAngle : float Lwd.t -> [>`LimitingConeAngle] attrib 492 492 - val a_mode : 493 493 - [<`Darken|`Lighten|`Multiply|`Normal|`Screen] Lwd.t -> [>`Mode] attrib 494 494 - val a_feColorMatrix_type : 495 495 - [<`HueRotate|`LuminanceToAlpha|`Matrix|`Saturate] Lwd.t -> 496 496 - [>`Typefecolor] attrib 497 497 - val a_values : numbers Lwd.t -> [>`Values] attrib 498 498 - val a_transfer_type : [<`Discrete|`Gamma|`Identity|`Linear|`Table] Lwd.t -> 499 499 - [>`Type_transfert] attrib 500 500 - val a_tableValues : numbers Lwd.t -> [>`TableValues] attrib 501 501 - val a_intercept : float Lwd.t -> [>`Intercept] attrib 502 502 - val a_amplitude : float Lwd.t -> [>`Amplitude] attrib 503 503 - val a_exponent : float Lwd.t -> [>`Exponent] attrib 504 504 - val a_transfer_offset : float Lwd.t -> [>`Offset_transfer] attrib 505 505 - val a_feComposite_operator : [<`Arithmetic|`Atop|`In|`Out|`Over|`Xor] Lwd.t -> 506 506 - [>`OperatorComposite] attrib 507 507 - val a_k1 : float Lwd.t -> [>`K1] attrib 508 508 - val a_k2 : float Lwd.t -> [>`K2] attrib 509 509 - val a_k3 : float Lwd.t -> [>`K3] attrib 510 510 - val a_k4 : float Lwd.t -> [>`K4] attrib 511 511 - val a_order : number_optional_number Lwd.t -> [>`Order] attrib 512 512 - val a_kernelMatrix : numbers Lwd.t -> [>`KernelMatrix] attrib 513 513 - val a_divisor : float Lwd.t -> [>`Divisor] attrib 514 514 - val a_bias : float Lwd.t -> [>`Bias] attrib 515 515 - val a_kernelUnitLength : 516 516 - number_optional_number Lwd.t -> [>`KernelUnitLength] attrib 517 517 - val a_targetX : int Lwd.t -> [>`TargetX] attrib 518 518 - val a_targetY : int Lwd.t -> [>`TargetY] attrib 519 519 - val a_edgeMode : [<`Duplicate|`None|`Wrap] Lwd.t -> [>`TargetY] attrib 520 520 - val a_preserveAlpha : bool Lwd.t -> [>`TargetY] attrib 521 521 - val a_surfaceScale : float Lwd.t -> [>`SurfaceScale] attrib 522 522 - val a_diffuseConstant : float Lwd.t -> [>`DiffuseConstant] attrib 523 523 - val a_scale : float Lwd.t -> [>`Scale] attrib 524 524 - val a_xChannelSelector : [<`A|`B|`G|`R] Lwd.t -> [>`XChannelSelector] attrib 525 525 - val a_yChannelSelector : [<`A|`B|`G|`R] Lwd.t -> [>`YChannelSelector] attrib 526 526 - val a_stdDeviation : number_optional_number Lwd.t -> [>`StdDeviation] attrib 527 527 - val a_feMorphology_operator : [<`Dilate|`Erode] Lwd.t -> [>`OperatorMorphology] attrib 528 528 - val a_radius : number_optional_number Lwd.t -> [>`Radius] attrib 529 529 - val a_baseFrenquency : number_optional_number Lwd.t -> [>`BaseFrequency] attrib 530 530 - val a_numOctaves : int Lwd.t -> [>`NumOctaves] attrib 531 531 - val a_seed : float Lwd.t -> [>`Seed] attrib 532 532 - val a_stitchTiles : [<`NoStitch|`Stitch] Lwd.t -> [>`StitchTiles] attrib 533 533 - val a_feTurbulence_type : [<`FractalNoise|`Turbulence] Lwd.t -> [>`TypeStitch] attrib 534 534 - val a_target : uri Lwd.t -> [>`Xlink_target] attrib 535 535 - val a_attributeName : uri Lwd.t -> [>`AttributeName] attrib 536 536 - val a_attributeType : [<`Auto|`CSS|`XML] Lwd.t -> [>`AttributeType] attrib 537 537 - val a_begin : uri Lwd.t -> [>`Begin] attrib 538 538 - val a_dur : uri Lwd.t -> [>`Dur] attrib 539 539 - val a_min : uri Lwd.t -> [>`Min] attrib 540 540 - val a_max : uri Lwd.t -> [>`Max] attrib 541 541 - val a_restart : [<`Always|`Never|`WhenNotActive] Lwd.t -> [>`Restart] attrib 542 542 - val a_repeatCount : uri Lwd.t -> [>`RepeatCount] attrib 543 543 - val a_repeatDur : uri Lwd.t -> [>`RepeatDur] attrib 544 544 - val a_fill : paint Lwd.t -> [>`Fill] attrib 545 545 - val a_animation_fill : [<`Freeze|`Remove] Lwd.t -> [>`Fill_Animation] attrib 546 546 - val a_calcMode : [<`Discrete|`Linear|`Paced|`Spline] Lwd.t -> [>`CalcMode] attrib 547 547 - val a_animation_values : strings Lwd.t -> [>`Valuesanim] attrib 548 548 - val a_keyTimes : strings Lwd.t -> [>`KeyTimes] attrib 549 549 - val a_keySplines : strings Lwd.t -> [>`KeySplines] attrib 550 550 - val a_from : uri Lwd.t -> [>`From] attrib 551 551 - val a_to : uri Lwd.t -> [>`To] attrib 552 552 - val a_by : uri Lwd.t -> [>`By] attrib 553 553 - val a_additive : [<`Replace|`Sum] Lwd.t -> [>`Additive] attrib 554 554 - val a_accumulate : [<`None|`Sum] Lwd.t -> [>`Accumulate] attrib 555 555 - val a_keyPoints : numbers_semicolon Lwd.t -> [>`KeyPoints] attrib 556 556 - val a_path : uri Lwd.t -> [>`Path] attrib 557 557 - val a_animateTransform_type : 558 558 - [`Rotate|`Scale|`SkewX|`SkewY|`Translate] Lwd.t -> 559 559 - [`Typeanimatetransform] attrib 560 560 - val a_horiz_origin_x : float Lwd.t -> [>`HorizOriginX] attrib 561 561 - val a_horiz_origin_y : float Lwd.t -> [>`HorizOriginY] attrib 562 562 - val a_horiz_adv_x : float Lwd.t -> [>`HorizAdvX] attrib 563 563 - val a_vert_origin_x : float Lwd.t -> [>`VertOriginX] attrib 564 564 - val a_vert_origin_y : float Lwd.t -> [>`VertOriginY] attrib 565 565 - val a_vert_adv_y : float Lwd.t -> [>`VertAdvY] attrib 566 566 - val a_unicode : uri Lwd.t -> [>`Unicode] attrib 567 567 - val a_glyph_name : uri Lwd.t -> [>`glyphname] attrib 568 568 - val a_orientation : [<`H | `V] Lwd.t -> [>`Orientation] attrib 569 569 - val a_arabic_form : [<`Initial|`Isolated|`Medial|`Terminal] Lwd.t -> 570 570 - [>`Arabicform] attrib 571 571 - val a_lang : uri Lwd.t -> [>`Lang] attrib 572 572 - val a_u1 : uri Lwd.t -> [>`U1] attrib 573 573 - val a_u2 : uri Lwd.t -> [>`U2] attrib 574 574 - val a_g1 : uri Lwd.t -> [>`G1] attrib 575 575 - val a_g2 : uri Lwd.t -> [>`G2] attrib 576 576 - val a_k : uri Lwd.t -> [>`K] attrib 577 577 - val a_font_family : uri Lwd.t -> [>`Font_Family] attrib 578 578 - val a_font_style : uri Lwd.t -> [>`Font_Style] attrib 579 579 - val a_font_variant : uri Lwd.t -> [>`Font_Variant] attrib 580 580 - val a_font_weight : uri Lwd.t -> [>`Font_Weight] attrib 581 581 - val a_font_stretch : uri Lwd.t -> [>`Font_Stretch] attrib 582 582 - val a_font_size : uri Lwd.t -> [>`Font_Size] attrib 583 583 - val a_unicode_range : uri Lwd.t -> [>`UnicodeRange] attrib 584 584 - val a_units_per_em : uri Lwd.t -> [>`UnitsPerEm] attrib 585 585 - val a_stemv : float Lwd.t -> [>`Stemv] attrib 586 586 - val a_stemh : float Lwd.t -> [>`Stemh] attrib 587 587 - val a_slope : float Lwd.t -> [>`Slope] attrib 588 588 - val a_cap_height : float Lwd.t -> [>`CapHeight] attrib 589 589 - val a_x_height : float Lwd.t -> [>`XHeight] attrib 590 590 - val a_accent_height : float Lwd.t -> [>`AccentHeight] attrib 591 591 - val a_ascent : float Lwd.t -> [>`Ascent] attrib 592 592 - val a_widths : uri Lwd.t -> [>`Widths] attrib 593 593 - val a_bbox : uri Lwd.t -> [>`Bbox] attrib 594 594 - val a_ideographic : float Lwd.t -> [>`Ideographic] attrib 595 595 - val a_alphabetic : float Lwd.t -> [>`Alphabetic] attrib 596 596 - val a_mathematical : float Lwd.t -> [>`Mathematical] attrib 597 597 - val a_hanging : float Lwd.t -> [>`Hanging] attrib 598 598 - val a_videographic : float Lwd.t -> [>`VIdeographic] attrib 599 599 - val a_v_alphabetic : float Lwd.t -> [>`VAlphabetic] attrib 600 600 - val a_v_mathematical : float Lwd.t -> [>`VMathematical] attrib 601 601 - val a_v_hanging : float Lwd.t -> [>`VHanging] attrib 602 602 - val a_underline_position : float Lwd.t -> [>`UnderlinePosition] attrib 603 603 - val a_underline_thickness : float Lwd.t -> [>`UnderlineThickness] attrib 604 604 - val a_strikethrough_position : float Lwd.t -> [>`StrikethroughPosition] attrib 605 605 - val a_strikethrough_thickness : float Lwd.t -> [>`StrikethroughThickness] attrib 606 606 - val a_overline_position : float Lwd.t -> [>`OverlinePosition] attrib 607 607 - val a_overline_thickness : float Lwd.t -> [>`OverlineThickness] attrib 608 608 - val a_string : uri Lwd.t -> [>`String] attrib 609 609 - val a_name : uri Lwd.t -> [>`Name] attrib 610 610 - val a_alignment_baseline : 611 611 - [<`After_edge|`Alphabetic|`Auto|`Baseline|`Before_edge|`Central|`Hanging 612 612 - |`Ideographic|`Inherit|`Mathematical|`Middle 613 613 - |`Text_after_edge|`Text_before_edge] Lwd.t -> [>`Alignment_Baseline] attrib 614 614 - val a_dominant_baseline : 615 615 - [<`Alphabetic|`Auto|`Central|`Hanging|`Ideographic|`Inherit 616 616 - |`Mathematical|`Middle|`No_change|`Reset_size|`Text_after_edge 617 617 - |`Text_before_edge|`Use_script] Lwd.t -> [>`Dominant_Baseline] attrib 618 618 - val a_stop_color : uri Lwd.t -> [>`Stop_Color] attrib 619 619 - val a_stop_opacity : float Lwd.t -> [>`Stop_Opacity] attrib 620 620 - val a_stroke : paint Lwd.t -> [>`Stroke] attrib 621 621 - val a_stroke_width : Unit.length Lwd.t -> [>`Stroke_Width] attrib 622 622 - val a_stroke_linecap : [<`Butt|`Round|`Square] Lwd.t -> [>`Stroke_Linecap] attrib 623 623 - val a_stroke_linejoin : [<`Bever|`Miter|`Round] Lwd.t -> [>`Stroke_Linejoin] attrib 624 624 - val a_stroke_miterlimit : float Lwd.t -> [>`Stroke_Miterlimit] attrib 625 625 - val a_stroke_dasharray : Unit.length list Lwd.t -> [>`Stroke_Dasharray] attrib 626 626 - val a_stroke_dashoffset : Unit.length Lwd.t -> [>`Stroke_Dashoffset] attrib 627 627 - val a_stroke_opacity : float Lwd.t -> [>`Stroke_Opacity] attrib 628 628 - val a_onabort : Xml.event_handler -> [>`OnAbort] attrib 629 629 - val a_onactivate : Xml.event_handler -> [>`OnActivate] attrib 630 630 - val a_onbegin : Xml.event_handler -> [>`OnBegin] attrib 631 631 - val a_onend : Xml.event_handler -> [>`OnEnd] attrib 632 632 - val a_onerror : Xml.event_handler -> [>`OnError] attrib 633 633 - val a_onfocusin : Xml.event_handler -> [>`OnFocusIn] attrib 634 634 - val a_onfocusout : Xml.event_handler -> [>`OnFocusOut] attrib 635 635 - val a_onrepeat : Xml.event_handler -> [>`OnRepeat] attrib 636 636 - val a_onresize : Xml.event_handler -> [>`OnResize] attrib 637 637 - val a_onscroll : Xml.event_handler -> [>`OnScroll] attrib 638 638 - val a_onunload : Xml.event_handler -> [>`OnUnload] attrib 639 639 - val a_onzoom : Xml.event_handler -> [>`OnZoom] attrib 640 640 - val a_onclick : Xml.mouse_event_handler -> [>`OnClick] attrib 641 641 - val a_onmousedown : Xml.mouse_event_handler -> [>`OnMouseDown] attrib 642 642 - val a_onmouseup : Xml.mouse_event_handler -> [>`OnMouseUp] attrib 643 643 - val a_onmouseover : Xml.mouse_event_handler -> [>`OnMouseOver] attrib 644 644 - val a_onmouseout : Xml.mouse_event_handler -> [>`OnMouseOut] attrib 645 645 - val a_onmousemove : Xml.mouse_event_handler -> [>`OnMouseMove] attrib 646 646 - val a_ontouchstart : Xml.touch_event_handler -> [>`OnTouchStart] attrib 647 647 - val a_ontouchend : Xml.touch_event_handler -> [>`OnTouchEnd] attrib 648 648 - val a_ontouchmove : Xml.touch_event_handler -> [>`OnTouchMove] attrib 649 649 - val a_ontouchcancel : Xml.touch_event_handler -> [>`OnTouchCancel] attrib 650 650 - val txt : uri Lwd.t -> [>txt] elt 651 651 - val svg : ([<svg_attr], [<svg_content], [>svg]) star 652 652 - val g : ([<g_attr], [<g_content], [>g]) star 653 653 - val defs : ([<defs_attr], [<defs_content], [>defs]) star 654 654 - val desc : ([<desc_attr], [<desc_content], [>desc]) unary 655 655 - val title : ([<desc_attr], [<title_content], [>title]) unary 656 656 - val symbol : ([<symbol_attr], [<symbol_content], [>symbol]) star 657 657 - val use : ([<use_attr], [<use_content], [>use]) star 658 658 - val image : ([<image_attr], [<image_content], [>image]) star 659 659 - val switch : ([<switch_attr], [<switch_content], [>switch]) star 660 660 - val style : ([<style_attr], [<style_content], [>style]) unary 661 661 - val path : ([<path_attr], [<path_content], [>path]) star 662 662 - val rect : ([<rect_attr], [<rect_content], [>rect]) star 663 663 - val circle : ([<circle_attr], [<circle_content], [>circle]) star 664 664 - val ellipse : ([<ellipse_attr], [<ellipse_content], [>ellipse]) star 665 665 - val line : ([<line_attr], [<line_content], [>line]) star 666 666 - val polyline : ([<polyline_attr], [<polyline_content], [>polyline]) star 667 667 - val polygon : ([<polygon_attr], [<polygon_content], [>polygon]) star 668 668 - val text : ([<text_attr], [<text_content], [>text]) star 669 669 - val tspan : ([<tspan_attr], [<tspan_content], [>tspan]) star 670 670 - val textPath : ([<textpath_attr], [<textpath_content], [>textpath]) star 671 671 - val marker : ([<marker_attr], [<marker_content], [>marker]) star 672 672 - val linearGradient : 673 673 - ([<lineargradient_attr], [<lineargradient_content], [>lineargradient]) star 674 674 - val radialGradient : 675 675 - ([<radialgradient_attr], [<radialgradient_content], [>radialgradient]) star 676 676 - val stop : ([<stop_attr], [<stop_content], [>stop]) star 677 677 - val pattern : ([<pattern_attr], [<pattern_content], [>pattern]) star 678 678 - val clipPath : ([<clippath_attr], [<clippath_content], [>clippath]) star 679 679 - val filter : ([<filter_attr], [<filter_content], [>filter]) star 680 680 - val feDistantLight : 681 681 - ([<fedistantlight_attr], [<fedistantlight_content], [>fedistantlight]) star 682 682 - val fePointLight : 683 683 - ([<fepointlight_attr], [<fepointlight_content], [>fepointlight]) star 684 684 - val feSpotLight : 685 685 - ([<fespotlight_attr], [<fespotlight_content], [>fespotlight]) star 686 686 - val feBlend : ([<feblend_attr], [<feblend_content], [>feblend]) star 687 687 - val feColorMatrix : 688 688 - ([<fecolormatrix_attr], [<fecolormatrix_content], [>fecolormatrix]) star 689 689 - val feComponentTransfer : 690 690 - ([<fecomponenttransfer_attr], [<fecomponenttransfer_content], 691 691 - [>fecomponenttransfer]) star 692 692 - val feFuncA : ([<fefunca_attr], [<fefunca_content], [>fefunca]) star 693 693 - val feFuncG : ([<fefuncg_attr], [<fefuncg_content], [>fefuncg]) star 694 694 - val feFuncB : ([<fefuncb_attr], [<fefuncb_content], [>fefuncb]) star 695 695 - val feFuncR : ([<fefuncr_attr], [<fefuncr_content], [>fefuncr]) star 696 696 - val feComposite : 697 697 - ([<fecomposite_attr], [<fecomposite_content], [>fecomposite]) star 698 698 - val feConvolveMatrix : 699 699 - ([<feconvolvematrix_attr], [<feconvolvematrix_content], 700 700 - [>feconvolvematrix]) star 701 701 - val feDiffuseLighting : 702 702 - ([<fediffuselighting_attr], [<fediffuselighting_content], 703 703 - [>fediffuselighting]) star 704 704 - val feDisplacementMap : 705 705 - ([<fedisplacementmap_attr], [<fedisplacementmap_content], 706 706 - [>fedisplacementmap]) star 707 707 - val feFlood : ([<feflood_attr], [<feflood_content], [>feflood]) star 708 708 - val feGaussianBlur : 709 709 - ([<fegaussianblur_attr], [<fegaussianblur_content], [>fegaussianblur]) star 710 710 - val feImage : ([<feimage_attr], [<feimage_content], [>feimage]) star 711 711 - val feMerge : ([<femerge_attr], [<femerge_content], [>femerge]) star 712 712 - val feMorphology : 713 713 - ([<femorphology_attr], [<femorphology_content], [>femorphology]) star 714 714 - val feOffset : 715 715 - ([<feoffset_attr], [<feoffset_content], [>feoffset]) star 716 716 - val feSpecularLighting : 717 717 - ([<fespecularlighting_attr], [<fespecularlighting_content], 718 718 - [>fespecularlighting]) star 719 719 - val feTile : ([<fetile_attr], [<fetile_content], [>fetile]) star 720 720 - val feTurbulence : 721 721 - ([<feturbulence_attr], [<feturbulence_content], [>feturbulence]) star 722 722 - val cursor : 723 723 - ([<cursor_attr], [<descriptive_element], [>cursor]) star 724 724 - val a : ([<a_attr], [<a_content], [>a]) star 725 725 - val view : ([<view_attr], [<descriptive_element], [>view]) star 726 726 - val script : ([<script_attr], [<script_content], [>script]) unary 727 727 - val animate : ([<animate_attr], [<descriptive_element], [>animate]) star 728 728 - val animation : ([<animation_attr], [<descriptive_element], [>animation]) star 729 729 - [@@ocaml.warning "-3"] 730 730 - val set : ([<set_attr], [<descriptive_element], [>set]) star 731 731 - val animateMotion : 732 732 - ([<animatemotion_attr], [<animatemotion_content], [>animatemotion]) star 733 733 - val mpath : 734 734 - ([<mpath_attr], [<descriptive_element], [>mpath]) star 735 735 - val animateColor : 736 736 - ([<animatecolor_attr], [<descriptive_element], [>animatecolor]) star 737 737 - val animateTransform : 738 738 - ([<animatetransform_attr], [<descriptive_element], 739 739 - [>animatetransform]) star 740 740 - val metadata : ?a:metadata_attr attrib list -> Xml.elt list -> [>metadata] elt 741 741 - val foreignObject : ?a:foreignobject_attr attrib list -> Xml.elt list -> [>foreignobject] elt 742 742 - 743 743 - 744 744 - (* val pcdata : string Lwd.t -> [>txt] elt *) 745 745 - (* val of_seq : Xml_stream.signal Seq.t -> 'a elt list *) 746 746 - val tot : Xml.elt -> 'a elt 747 747 - (* val totl : Xml.elt list -> 'a elt list *) 748 748 - val toelt : 'a elt -> Xml.elt 749 749 - (* val toeltl : 'a elt list -> Xml.elt list *) 750 750 - val doc_toelt : doc -> Xml.elt 751 751 - val to_xmlattribs : 'a attrib list -> Xml.attrib list 752 752 - val to_attrib : Xml.attrib -> 'a attrib 753 753 - 754 754 - (*module Unsafe : sig 755 755 - val data : string Lwd.t -> 'a elt 756 756 - val node : string -> ?a:'a attrib list -> 'b elt list -> 'c elt 757 757 - val leaf : string -> ?a:'a attrib list -> unit -> 'b elt 758 758 - val coerce_elt : 'a elt -> 'b elt 759 759 - val string_attrib : string -> string Lwd.t -> 'a attrib 760 760 - val float_attrib : string -> float Lwd.t -> 'a attrib 761 761 - val int_attrib : string -> int Lwd.t -> 'a attrib 762 762 - val uri_attrib : string -> Xml.uri Lwd.t -> 'a attrib 763 763 - val space_sep_attrib : string -> string list Lwd.t -> 'a attrib 764 764 - val comma_sep_attrib : string -> string list Lwd.t -> 'a attrib 765 765 - end*) 766 766 - end = struct 767 767 - type +'a elt = 'a node live 768 768 - type doc = [`Svg] elt 769 769 - type nonrec +'a attrib = 'a attrib 770 770 - 771 771 - module Xml = Xml 772 772 - type ('a, 'b) nullary = ?a:'a attrib list -> unit -> 'b elt 773 773 - type ('a, 'b, 'c) unary = ?a:'a attrib list -> 'b elt -> 'c elt 774 774 - type ('a, 'b, 'c) star = ?a:'a attrib list -> 'b elt list -> 'c elt 775 775 - 776 776 - module Info = Raw_svg.Info 777 777 - 778 778 - type uri = string 779 779 - 780 780 - let string_of_uri = Raw_svg.string_of_uri 781 781 - let uri_of_string = Raw_svg.uri_of_string 782 782 - let a_x = Raw_svg.a_x 783 783 - let a_y = Raw_svg.a_y 784 784 - let a_width = Raw_svg.a_width 785 785 - let a_height = Raw_svg.a_height 786 786 - let a_preserveAspectRatio = Raw_svg.a_preserveAspectRatio 787 787 - let a_zoomAndPan = Raw_svg.a_zoomAndPan 788 788 - let a_href = Raw_svg.a_href 789 789 - let a_requiredExtensions = Raw_svg.a_requiredExtensions 790 790 - let a_systemLanguage = Raw_svg.a_systemLanguage 791 791 - let a_externalRessourcesRequired = Raw_svg.a_externalRessourcesRequired 792 792 - let a_id = Raw_svg.a_id 793 793 - let a_user_data = Raw_svg.a_user_data 794 794 - let a_xml_lang = Raw_svg.a_xml_lang 795 795 - let a_type = Raw_svg.a_type 796 796 - let a_media = Raw_svg.a_media 797 797 - let a_class = Raw_svg.a_class 798 798 - let a_style = Raw_svg.a_style 799 799 - let a_transform = Raw_svg.a_transform 800 800 - let a_viewBox = Raw_svg.a_viewBox 801 801 - let a_d = Raw_svg.a_d 802 802 - let a_pathLength = Raw_svg.a_pathLength 803 803 - let a_rx = Raw_svg.a_rx 804 804 - let a_ry = Raw_svg.a_ry 805 805 - let a_cx = Raw_svg.a_cx 806 806 - let a_cy = Raw_svg.a_cy 807 807 - let a_r = Raw_svg.a_r 808 808 - let a_x1 = Raw_svg.a_x1 809 809 - let a_y1 = Raw_svg.a_y1 810 810 - let a_x2 = Raw_svg.a_x2 811 811 - let a_y2 = Raw_svg.a_y2 812 812 - let a_points = Raw_svg.a_points 813 813 - let a_x_list = Raw_svg.a_x_list 814 814 - let a_y_list = Raw_svg.a_y_list 815 815 - let a_dx = Raw_svg.a_dx 816 816 - let a_dy = Raw_svg.a_dy 817 817 - let a_dx_list = Raw_svg.a_dx_list 818 818 - let a_dy_list = Raw_svg.a_dy_list 819 819 - let a_lengthAdjust = Raw_svg.a_lengthAdjust 820 820 - let a_textLength = Raw_svg.a_textLength 821 821 - let a_text_anchor = Raw_svg.a_text_anchor 822 822 - let a_text_decoration = Raw_svg.a_text_decoration 823 823 - let a_text_rendering = Raw_svg.a_text_rendering 824 824 - let a_rotate = Raw_svg.a_rotate 825 825 - let a_startOffset = Raw_svg.a_startOffset 826 826 - let a_method = Raw_svg.a_method 827 827 - let a_spacing = Raw_svg.a_spacing 828 828 - let a_glyphRef = Raw_svg.a_glyphRef 829 829 - let a_format = Raw_svg.a_format 830 830 - let a_markerUnits = Raw_svg.a_markerUnits 831 831 - let a_refX = Raw_svg.a_refX 832 832 - let a_refY = Raw_svg.a_refY 833 833 - let a_markerWidth = Raw_svg.a_markerWidth 834 834 - let a_markerHeight = Raw_svg.a_markerHeight 835 835 - let a_orient = Raw_svg.a_orient 836 836 - let a_local = Raw_svg.a_local 837 837 - let a_rendering_intent = Raw_svg.a_rendering_intent 838 838 - let a_gradientUnits = Raw_svg.a_gradientUnits 839 839 - let a_gradientTransform = Raw_svg.a_gradientTransform 840 840 - let a_spreadMethod = Raw_svg.a_spreadMethod 841 841 - let a_fx = Raw_svg.a_fx 842 842 - let a_fy = Raw_svg.a_fy 843 843 - let a_offset = Raw_svg.a_offset 844 844 - let a_patternUnits = Raw_svg.a_patternUnits 845 845 - let a_patternContentUnits = Raw_svg.a_patternContentUnits 846 846 - let a_patternTransform = Raw_svg.a_patternTransform 847 847 - let a_clipPathUnits = Raw_svg.a_clipPathUnits 848 848 - let a_maskUnits = Raw_svg.a_maskUnits 849 849 - let a_maskContentUnits = Raw_svg.a_maskContentUnits 850 850 - let a_primitiveUnits = Raw_svg.a_primitiveUnits 851 851 - let a_filterRes = Raw_svg.a_filterRes 852 852 - let a_result = Raw_svg.a_result 853 853 - let a_in = Raw_svg.a_in 854 854 - let a_in2 = Raw_svg.a_in2 855 855 - let a_azimuth = Raw_svg.a_azimuth 856 856 - let a_elevation = Raw_svg.a_elevation 857 857 - let a_pointsAtX = Raw_svg.a_pointsAtX 858 858 - let a_pointsAtY = Raw_svg.a_pointsAtY 859 859 - let a_pointsAtZ = Raw_svg.a_pointsAtZ 860 860 - let a_specularExponent = Raw_svg.a_specularExponent 861 861 - let a_specularConstant = Raw_svg.a_specularConstant 862 862 - let a_limitingConeAngle = Raw_svg.a_limitingConeAngle 863 863 - let a_mode = Raw_svg.a_mode 864 864 - let a_feColorMatrix_type = Raw_svg.a_feColorMatrix_type 865 865 - let a_values = Raw_svg.a_values 866 866 - let a_transfer_type = Raw_svg.a_transfer_type 867 867 - let a_tableValues = Raw_svg.a_tableValues 868 868 - let a_intercept = Raw_svg.a_intercept 869 869 - let a_amplitude = Raw_svg.a_amplitude 870 870 - let a_exponent = Raw_svg.a_exponent 871 871 - let a_transfer_offset = Raw_svg.a_transfer_offset 872 872 - let a_feComposite_operator = Raw_svg.a_feComposite_operator 873 873 - let a_k1 = Raw_svg.a_k1 874 874 - let a_k2 = Raw_svg.a_k2 875 875 - let a_k3 = Raw_svg.a_k3 876 876 - let a_k4 = Raw_svg.a_k4 877 877 - let a_order = Raw_svg.a_order 878 878 - let a_kernelMatrix = Raw_svg.a_kernelMatrix 879 879 - let a_divisor = Raw_svg.a_divisor 880 880 - let a_bias = Raw_svg.a_bias 881 881 - let a_kernelUnitLength = Raw_svg.a_kernelUnitLength 882 882 - let a_targetX = Raw_svg.a_targetX 883 883 - let a_targetY = Raw_svg.a_targetY 884 884 - let a_edgeMode = Raw_svg.a_edgeMode 885 885 - let a_preserveAlpha = Raw_svg.a_preserveAlpha 886 886 - let a_surfaceScale = Raw_svg.a_surfaceScale 887 887 - let a_diffuseConstant = Raw_svg.a_diffuseConstant 888 888 - let a_scale = Raw_svg.a_scale 889 889 - let a_xChannelSelector = Raw_svg.a_xChannelSelector 890 890 - let a_yChannelSelector = Raw_svg.a_yChannelSelector 891 891 - let a_stdDeviation = Raw_svg.a_stdDeviation 892 892 - let a_feMorphology_operator = Raw_svg.a_feMorphology_operator 893 893 - let a_radius = Raw_svg.a_radius 894 894 - let a_baseFrenquency = Raw_svg.a_baseFrenquency 895 895 - let a_numOctaves = Raw_svg.a_numOctaves 896 896 - let a_seed = Raw_svg.a_seed 897 897 - let a_stitchTiles = Raw_svg.a_stitchTiles 898 898 - let a_feTurbulence_type = Raw_svg.a_feTurbulence_type 899 899 - let a_target = Raw_svg.a_target 900 900 - let a_attributeName = Raw_svg.a_attributeName 901 901 - let a_attributeType = Raw_svg.a_attributeType 902 902 - let a_begin = Raw_svg.a_begin 903 903 - let a_dur = Raw_svg.a_dur 904 904 - let a_min = Raw_svg.a_min 905 905 - let a_max = Raw_svg.a_max 906 906 - let a_restart = Raw_svg.a_restart 907 907 - let a_repeatCount = Raw_svg.a_repeatCount 908 908 - let a_repeatDur = Raw_svg.a_repeatDur 909 909 - let a_fill = Raw_svg.a_fill 910 910 - let a_animation_fill = Raw_svg.a_animation_fill 911 911 - let a_calcMode = Raw_svg.a_calcMode 912 912 - let a_animation_values = Raw_svg.a_animation_values 913 913 - let a_keyTimes = Raw_svg.a_keyTimes 914 914 - let a_keySplines = Raw_svg.a_keySplines 915 915 - let a_from = Raw_svg.a_from 916 916 - let a_to = Raw_svg.a_to 917 917 - let a_by = Raw_svg.a_by 918 918 - let a_additive = Raw_svg.a_additive 919 919 - let a_accumulate = Raw_svg.a_accumulate 920 920 - let a_keyPoints = Raw_svg.a_keyPoints 921 921 - let a_path = Raw_svg.a_path 922 922 - let a_animateTransform_type = Raw_svg.a_animateTransform_type 923 923 - let a_horiz_origin_x = Raw_svg.a_horiz_origin_x 924 924 - let a_horiz_origin_y = Raw_svg.a_horiz_origin_y 925 925 - let a_horiz_adv_x = Raw_svg.a_horiz_adv_x 926 926 - let a_vert_origin_x = Raw_svg.a_vert_origin_x 927 927 - let a_vert_origin_y = Raw_svg.a_vert_origin_y 928 928 - let a_vert_adv_y = Raw_svg.a_vert_adv_y 929 929 - let a_unicode = Raw_svg.a_unicode 930 930 - let a_glyph_name = Raw_svg.a_glyph_name 931 931 - let a_orientation = Raw_svg.a_orientation 932 932 - let a_arabic_form = Raw_svg.a_arabic_form 933 933 - let a_lang = Raw_svg.a_lang 934 934 - let a_u1 = Raw_svg.a_u1 935 935 - let a_u2 = Raw_svg.a_u2 936 936 - let a_g1 = Raw_svg.a_g1 937 937 - let a_g2 = Raw_svg.a_g2 938 938 - let a_k = Raw_svg.a_k 939 939 - let a_font_family = Raw_svg.a_font_family 940 940 - let a_font_style = Raw_svg.a_font_style 941 941 - let a_font_variant = Raw_svg.a_font_variant 942 942 - let a_font_weight = Raw_svg.a_font_weight 943 943 - let a_font_stretch = Raw_svg.a_font_stretch 944 944 - let a_font_size = Raw_svg.a_font_size 945 945 - let a_unicode_range = Raw_svg.a_unicode_range 946 946 - let a_units_per_em = Raw_svg.a_units_per_em 947 947 - let a_stemv = Raw_svg.a_stemv 948 948 - let a_stemh = Raw_svg.a_stemh 949 949 - let a_slope = Raw_svg.a_slope 950 950 - let a_cap_height = Raw_svg.a_cap_height 951 951 - let a_x_height = Raw_svg.a_x_height 952 952 - let a_accent_height = Raw_svg.a_accent_height 953 953 - let a_ascent = Raw_svg.a_ascent 954 954 - let a_widths = Raw_svg.a_widths 955 955 - let a_bbox = Raw_svg.a_bbox 956 956 - let a_ideographic = Raw_svg.a_ideographic 957 957 - let a_alphabetic = Raw_svg.a_alphabetic 958 958 - let a_mathematical = Raw_svg.a_mathematical 959 959 - let a_hanging = Raw_svg.a_hanging 960 960 - let a_videographic = Raw_svg.a_videographic 961 961 - let a_v_alphabetic = Raw_svg.a_v_alphabetic 962 962 - let a_v_mathematical = Raw_svg.a_v_mathematical 963 963 - let a_v_hanging = Raw_svg.a_v_hanging 964 964 - let a_underline_position = Raw_svg.a_underline_position 965 965 - let a_underline_thickness = Raw_svg.a_underline_thickness 966 966 - let a_strikethrough_position = Raw_svg.a_strikethrough_position 967 967 - let a_strikethrough_thickness = Raw_svg.a_strikethrough_thickness 968 968 - let a_overline_position = Raw_svg.a_overline_position 969 969 - let a_overline_thickness = Raw_svg.a_overline_thickness 970 970 - let a_string = Raw_svg.a_string 971 971 - let a_name = Raw_svg.a_name 972 972 - let a_alignment_baseline = Raw_svg.a_alignment_baseline 973 973 - let a_dominant_baseline = Raw_svg.a_dominant_baseline 974 974 - let a_stop_color = Raw_svg.a_stop_color 975 975 - let a_stop_opacity = Raw_svg.a_stop_opacity 976 976 - let a_stroke = Raw_svg.a_stroke 977 977 - let a_stroke_width = Raw_svg.a_stroke_width 978 978 - let a_stroke_linecap = Raw_svg.a_stroke_linecap 979 979 - let a_stroke_linejoin = Raw_svg.a_stroke_linejoin 980 980 - let a_stroke_miterlimit = Raw_svg.a_stroke_miterlimit 981 981 - let a_stroke_dasharray = Raw_svg.a_stroke_dasharray 982 982 - let a_stroke_dashoffset = Raw_svg.a_stroke_dashoffset 983 983 - let a_stroke_opacity = Raw_svg.a_stroke_opacity 984 984 - let a_onabort = Raw_svg.a_onabort 985 985 - let a_onactivate = Raw_svg.a_onactivate 986 986 - let a_onbegin = Raw_svg.a_onbegin 987 987 - let a_onend = Raw_svg.a_onend 988 988 - let a_onerror = Raw_svg.a_onerror 989 989 - let a_onfocusin = Raw_svg.a_onfocusin 990 990 - let a_onfocusout = Raw_svg.a_onfocusout 991 991 - let a_onrepeat = Raw_svg.a_onrepeat 992 992 - let a_onresize = Raw_svg.a_onresize 993 993 - let a_onscroll = Raw_svg.a_onscroll 994 994 - let a_onunload = Raw_svg.a_onunload 995 995 - let a_onzoom = Raw_svg.a_onzoom 996 996 - let a_onclick = Raw_svg.a_onclick 997 997 - let a_onmousedown = Raw_svg.a_onmousedown 998 998 - let a_onmouseup = Raw_svg.a_onmouseup 999 999 - let a_onmouseover = Raw_svg.a_onmouseover 1000 1000 - let a_onmouseout = Raw_svg.a_onmouseout 1001 1001 - let a_onmousemove = Raw_svg.a_onmousemove 1002 1002 - let a_ontouchstart = Raw_svg.a_ontouchstart 1003 1003 - let a_ontouchend = Raw_svg.a_ontouchend 1004 1004 - let a_ontouchmove = Raw_svg.a_ontouchmove 1005 1005 - let a_ontouchcancel = Raw_svg.a_ontouchcancel 1006 1006 - 1007 1007 - let unary (f: ('a, 'b, 'c) Raw_svg.unary) : ('a, 'b, 'c) unary = 1008 1008 - fun ?a elt -> f ?a (Lwd.pure elt) 1009 1009 - 1010 1010 - let star (f: ('a, 'b, 'c) Raw_svg.star) : ('a, 'b, 'c) star = 1011 1011 - fun ?a elts -> f ?a (List.map Lwd.pure elts) 1012 1012 - 1013 1013 - let txt = Raw_svg.txt 1014 1014 - let svg = star Raw_svg.svg 1015 1015 - let g = star Raw_svg.g 1016 1016 - let defs = star Raw_svg.defs 1017 1017 - let desc = unary Raw_svg.desc 1018 1018 - let title = unary Raw_svg.title 1019 1019 - let symbol = star Raw_svg.symbol 1020 1020 - let use = star Raw_svg.use 1021 1021 - let image = star Raw_svg.image 1022 1022 - let switch = star Raw_svg.switch 1023 1023 - let style = unary Raw_svg.style 1024 1024 - let path = star Raw_svg.path 1025 1025 - let rect = star Raw_svg.rect 1026 1026 - let circle = star Raw_svg.circle 1027 1027 - let ellipse = star Raw_svg.ellipse 1028 1028 - let line = star Raw_svg.line 1029 1029 - let polyline = star Raw_svg.polyline 1030 1030 - let polygon = star Raw_svg.polygon 1031 1031 - let text = star Raw_svg.text 1032 1032 - let tspan = star Raw_svg.tspan 1033 1033 - let textPath = star Raw_svg.textPath 1034 1034 - let marker = star Raw_svg.marker 1035 1035 - let linearGradient = star Raw_svg.linearGradient 1036 1036 - let radialGradient = star Raw_svg.radialGradient 1037 1037 - let stop = star Raw_svg.stop 1038 1038 - let pattern = star Raw_svg.pattern 1039 1039 - let clipPath = star Raw_svg.clipPath 1040 1040 - let filter = star Raw_svg.filter 1041 1041 - let feDistantLight = star Raw_svg.feDistantLight 1042 1042 - let fePointLight = star Raw_svg.fePointLight 1043 1043 - let feSpotLight = star Raw_svg.feSpotLight 1044 1044 - let feBlend = star Raw_svg.feBlend 1045 1045 - let feColorMatrix = star Raw_svg.feColorMatrix 1046 1046 - let feComponentTransfer = star Raw_svg.feComponentTransfer 1047 1047 - let feFuncA = star Raw_svg.feFuncA 1048 1048 - let feFuncG = star Raw_svg.feFuncG 1049 1049 - let feFuncB = star Raw_svg.feFuncB 1050 1050 - let feFuncR = star Raw_svg.feFuncR 1051 1051 - let feComposite = star Raw_svg.feComposite 1052 1052 - let feConvolveMatrix = star Raw_svg.feConvolveMatrix 1053 1053 - let feDiffuseLighting = star Raw_svg.feDiffuseLighting 1054 1054 - let feDisplacementMap = star Raw_svg.feDisplacementMap 1055 1055 - let feFlood = star Raw_svg.feFlood 1056 1056 - let feGaussianBlur = star Raw_svg.feGaussianBlur 1057 1057 - let feImage = star Raw_svg.feImage 1058 1058 - let feMerge = star Raw_svg.feMerge 1059 1059 - let feMorphology = star Raw_svg.feMorphology 1060 1060 - let feOffset = star Raw_svg.feOffset 1061 1061 - let feSpecularLighting = star Raw_svg.feSpecularLighting 1062 1062 - let feTile = star Raw_svg.feTile 1063 1063 - let feTurbulence = star Raw_svg.feTurbulence 1064 1064 - let cursor = star Raw_svg.cursor 1065 1065 - let a = star Raw_svg.a 1066 1066 - let view = star Raw_svg.view 1067 1067 - let script = unary Raw_svg.script 1068 1068 - let animate = star Raw_svg.animate 1069 1069 - let animation = star Raw_svg.animation 1070 1070 - [@@ocaml.warning "-3"] 1071 1071 - let set = star Raw_svg.set 1072 1072 - let animateMotion = star Raw_svg.animateMotion 1073 1073 - let mpath = star Raw_svg.mpath 1074 1074 - let animateColor = star Raw_svg.animateColor 1075 1075 - let animateTransform = star Raw_svg.animateTransform 1076 1076 - let metadata = star Raw_svg.metadata 1077 1077 - let foreignObject = star Raw_svg.foreignObject 1078 1078 - (* let of_seq = Raw_svg.of_seq *) 1079 1079 - let tot = Raw_svg.tot 1080 1080 - (* let totl = Raw_svg.totl *) 1081 1081 - let toelt = Raw_svg.toelt 1082 1082 - (* let toeltl = Raw_svg.toeltl *) 1083 1083 - let doc_toelt = Raw_svg.doc_toelt 1084 1084 - let to_xmlattribs = Raw_svg.to_xmlattribs 1085 1085 - let to_attrib = Raw_svg.to_attrib 1086 1086 - end 1087 1087 - 1088 1088 - module Raw_html = Html_f.Make(Xml)(Raw_svg) 1089 1089 - 1090 1090 - open Html_types 1091 1091 - module Html : sig 1092 1092 - type 'a elt = 'a node live 1093 1093 - type doc = html elt 1094 1094 - type nonrec +'a attrib = 'a attrib 1095 1095 - type ('a, 'b) nullary = ?a:'a attrib list -> unit -> 'b elt 1096 1096 - type ('a, 'b, 'c) unary = ?a:'a attrib list -> 'b elt -> 'c elt 1097 1097 - type ('a, 'b, 'c) star = ?a:'a attrib list -> 'b elt list -> 'c elt 1098 1098 - module Info : Xml_sigs.Info 1099 1099 - 1100 1100 - val string_of_uri : Xml.uri -> string 1101 1101 - val uri_of_string : string -> Xml.uri 1102 1102 - val a_class : nmtokens Lwd.t -> [>`Class] attrib 1103 1103 - val a_user_data : string -> string Lwd.t -> [>`User_data] attrib 1104 1104 - val a_id : string Lwd.t -> [>`Id] attrib 1105 1105 - val a_title : string Lwd.t -> [>`Title] attrib 1106 1106 - val a_xml_lang : string Lwd.t -> [>`XML_lang] attrib 1107 1107 - val a_lang : string Lwd.t -> [>`Lang] attrib 1108 1108 - val a_onabort : Xml.event_handler -> [>`OnAbort] attrib 1109 1109 - val a_onafterprint : Xml.event_handler -> [>`OnAfterPrint] attrib 1110 1110 - val a_onbeforeprint : Xml.event_handler -> [>`OnBeforePrint] attrib 1111 1111 - val a_onbeforeunload : Xml.event_handler -> [>`OnBeforeUnload] attrib 1112 1112 - val a_onblur : Xml.event_handler -> [>`OnBlur] attrib 1113 1113 - val a_oncanplay : Xml.event_handler -> [>`OnCanPlay] attrib 1114 1114 - val a_oncanplaythrough : Xml.event_handler -> [>`OnCanPlayThrough] attrib 1115 1115 - val a_onchange : Xml.event_handler -> [>`OnChange] attrib 1116 1116 - val a_ondurationchange : Xml.event_handler -> [>`OnDurationChange] attrib 1117 1117 - val a_onemptied : Xml.event_handler -> [>`OnEmptied] attrib 1118 1118 - val a_onended : Xml.event_handler -> [>`OnEnded] attrib 1119 1119 - val a_onerror : Xml.event_handler -> [>`OnError] attrib 1120 1120 - val a_onfocus : Xml.event_handler -> [>`OnFocus] attrib 1121 1121 - val a_onformchange : Xml.event_handler -> [>`OnFormChange] attrib 1122 1122 - val a_onforminput : Xml.event_handler -> [>`OnFormInput] attrib 1123 1123 - val a_onhashchange : Xml.event_handler -> [>`OnHashChange] attrib 1124 1124 - val a_oninput : Xml.event_handler -> [>`OnInput] attrib 1125 1125 - val a_oninvalid : Xml.event_handler -> [>`OnInvalid] attrib 1126 1126 - val a_onmousewheel : Xml.event_handler -> [>`OnMouseWheel] attrib 1127 1127 - val a_onoffline : Xml.event_handler -> [>`OnOffLine] attrib 1128 1128 - val a_ononline : Xml.event_handler -> [>`OnOnLine] attrib 1129 1129 - val a_onpause : Xml.event_handler -> [>`OnPause] attrib 1130 1130 - val a_onplay : Xml.event_handler -> [>`OnPlay] attrib 1131 1131 - val a_onplaying : Xml.event_handler -> [>`OnPlaying] attrib 1132 1132 - val a_onpagehide : Xml.event_handler -> [>`OnPageHide] attrib 1133 1133 - val a_onpageshow : Xml.event_handler -> [>`OnPageShow] attrib 1134 1134 - val a_onpopstate : Xml.event_handler -> [>`OnPopState] attrib 1135 1135 - val a_onprogress : Xml.event_handler -> [>`OnProgress] attrib 1136 1136 - val a_onratechange : Xml.event_handler -> [>`OnRateChange] attrib 1137 1137 - val a_onreadystatechange : Xml.event_handler -> [>`OnReadyStateChange] attrib 1138 1138 - val a_onredo : Xml.event_handler -> [>`OnRedo] attrib 1139 1139 - val a_onresize : Xml.event_handler -> [>`OnResize] attrib 1140 1140 - val a_onscroll : Xml.event_handler -> [>`OnScroll] attrib 1141 1141 - val a_onseeked : Xml.event_handler -> [>`OnSeeked] attrib 1142 1142 - val a_onseeking : Xml.event_handler -> [>`OnSeeking] attrib 1143 1143 - val a_onselect : Xml.event_handler -> [>`OnSelect] attrib 1144 1144 - val a_onshow : Xml.event_handler -> [>`OnShow] attrib 1145 1145 - val a_onstalled : Xml.event_handler -> [>`OnStalled] attrib 1146 1146 - val a_onstorage : Xml.event_handler -> [>`OnStorage] attrib 1147 1147 - val a_onsubmit : Xml.event_handler -> [>`OnSubmit] attrib 1148 1148 - val a_onsuspend : Xml.event_handler -> [>`OnSuspend] attrib 1149 1149 - val a_ontimeupdate : Xml.event_handler -> [>`OnTimeUpdate] attrib 1150 1150 - val a_onundo : Xml.event_handler -> [>`OnUndo] attrib 1151 1151 - val a_onunload : Xml.event_handler -> [>`OnUnload] attrib 1152 1152 - val a_onvolumechange : Xml.event_handler -> [>`OnVolumeChange] attrib 1153 1153 - val a_onwaiting : Xml.event_handler -> [>`OnWaiting] attrib 1154 1154 - val a_onload : Xml.event_handler -> [>`OnLoad] attrib 1155 1155 - val a_onloadeddata : Xml.event_handler -> [>`OnLoadedData] attrib 1156 1156 - val a_onloadedmetadata : Xml.event_handler -> [>`OnLoadedMetaData] attrib 1157 1157 - val a_onloadstart : Xml.event_handler -> [>`OnLoadStart] attrib 1158 1158 - val a_onmessage : Xml.event_handler -> [>`OnMessage] attrib 1159 1159 - val a_onclick : Xml.mouse_event_handler -> [>`OnClick] attrib 1160 1160 - val a_oncontextmenu : Xml.mouse_event_handler -> [>`OnContextMenu] attrib 1161 1161 - val a_ondblclick : Xml.mouse_event_handler -> [>`OnDblClick] attrib 1162 1162 - val a_ondrag : Xml.mouse_event_handler -> [>`OnDrag] attrib 1163 1163 - val a_ondragend : Xml.mouse_event_handler -> [>`OnDragEnd] attrib 1164 1164 - val a_ondragenter : Xml.mouse_event_handler -> [>`OnDragEnter] attrib 1165 1165 - val a_ondragleave : Xml.mouse_event_handler -> [>`OnDragLeave] attrib 1166 1166 - val a_ondragover : Xml.mouse_event_handler -> [>`OnDragOver] attrib 1167 1167 - val a_ondragstart : Xml.mouse_event_handler -> [>`OnDragStart] attrib 1168 1168 - val a_ondrop : Xml.mouse_event_handler -> [>`OnDrop] attrib 1169 1169 - val a_onmousedown : Xml.mouse_event_handler -> [>`OnMouseDown] attrib 1170 1170 - val a_onmouseup : Xml.mouse_event_handler -> [>`OnMouseUp] attrib 1171 1171 - val a_onmouseover : Xml.mouse_event_handler -> [>`OnMouseOver] attrib 1172 1172 - val a_onmousemove : Xml.mouse_event_handler -> [>`OnMouseMove] attrib 1173 1173 - val a_onmouseout : Xml.mouse_event_handler -> [>`OnMouseOut] attrib 1174 1174 - val a_ontouchstart : Xml.touch_event_handler -> [>`OnTouchStart] attrib 1175 1175 - val a_ontouchend : Xml.touch_event_handler -> [>`OnTouchEnd] attrib 1176 1176 - val a_ontouchmove : Xml.touch_event_handler -> [>`OnTouchMove] attrib 1177 1177 - val a_ontouchcancel : Xml.touch_event_handler -> [>`OnTouchCancel] attrib 1178 1178 - val a_onkeypress : Xml.keyboard_event_handler -> [>`OnKeyPress] attrib 1179 1179 - val a_onkeydown : Xml.keyboard_event_handler -> [>`OnKeyDown] attrib 1180 1180 - val a_onkeyup : Xml.keyboard_event_handler -> [>`OnKeyUp] attrib 1181 1181 - val a_allowfullscreen : unit -> [>`Allowfullscreen] attrib 1182 1182 - val a_allowpaymentrequest : unit -> [>`Allowpaymentrequest] attrib 1183 1183 - val a_autocomplete : autocomplete_option Lwd.t -> [>`Autocomplete] attrib 1184 1184 - val a_async : unit -> [>`Async] attrib 1185 1185 - val a_autofocus : unit -> [>`Autofocus] attrib 1186 1186 - val a_autoplay : unit -> [>`Autoplay] attrib 1187 1187 - val a_muted : unit -> [>`Muted] attrib 1188 1188 - val a_crossorigin : 1189 1189 - [<`Anonymous|`Use_credentials] Lwd.t -> [>`Crossorigin] attrib 1190 1190 - val a_integrity : string Lwd.t -> [>`Integrity] attrib 1191 1191 - val a_mediagroup : string Lwd.t -> [>`Mediagroup] attrib 1192 1192 - val a_challenge : string Lwd.t -> [>`Challenge] attrib 1193 1193 - val a_contenteditable : bool Lwd.t -> [>`Contenteditable] attrib 1194 1194 - val a_contextmenu : string Lwd.t -> [>`Contextmenu] attrib 1195 1195 - val a_controls : unit -> [>`Controls] attrib 1196 1196 - val a_dir : [<`Ltr|`Rtl] Lwd.t -> [>`Dir] attrib 1197 1197 - val a_draggable : bool Lwd.t -> [>`Draggable] attrib 1198 1198 - val a_form : string Lwd.t -> [>`Form] attrib 1199 1199 - val a_formaction : Xml.uri Lwd.t -> [>`Formaction] attrib 1200 1200 - val a_formenctype : string Lwd.t -> [>`Formenctype] attrib 1201 1201 - val a_formnovalidate : unit -> [>`Formnovalidate] attrib 1202 1202 - val a_formtarget : string Lwd.t -> [>`Formtarget] attrib 1203 1203 - val a_hidden : unit -> [>`Hidden] attrib 1204 1204 - val a_high : float Lwd.t -> [>`High] attrib 1205 1205 - val a_icon : Xml.uri Lwd.t -> [>`Icon] attrib 1206 1206 - val a_ismap : unit -> [>`Ismap] attrib 1207 1207 - val a_keytype : string Lwd.t -> [>`Keytype] attrib 1208 1208 - val a_list : string Lwd.t -> [>`List] attrib 1209 1209 - val a_loop : unit -> [>`Loop] attrib 1210 1210 - val a_low : float Lwd.t -> [>`High] attrib 1211 1211 - val a_max : float Lwd.t -> [>`Max] attrib 1212 1212 - val a_input_max : number_or_datetime Lwd.t -> [>`Input_Max] attrib 1213 1213 - val a_min : float Lwd.t -> [>`Min] attrib 1214 1214 - val a_input_min : number_or_datetime Lwd.t -> [>`Input_Min] attrib 1215 1215 - val a_inputmode : 1216 1216 - [<`Decimal|`Email|`None|`Numeric|`Search|`Tel|`Text|`Url] Lwd.t -> 1217 1217 - [>`Inputmode] attrib 1218 1218 - val a_novalidate : unit -> [>`Novalidate] attrib 1219 1219 - val a_open : unit -> [>`Open] attrib 1220 1220 - val a_optimum : float Lwd.t -> [>`Optimum] attrib 1221 1221 - val a_pattern : string Lwd.t -> [>`Pattern] attrib 1222 1222 - val a_placeholder : string Lwd.t -> [>`Placeholder] attrib 1223 1223 - val a_poster : Xml.uri Lwd.t -> [>`Poster] attrib 1224 1224 - val a_preload : [<`Audio|`Metadata|`None] Lwd.t -> [>`Preload] attrib 1225 1225 - val a_pubdate : unit -> [>`Pubdate] attrib 1226 1226 - val a_radiogroup : string Lwd.t -> [>`Radiogroup] attrib 1227 1227 - val a_referrerpolicy : referrerpolicy Lwd.t -> [>`Referrerpolicy] attrib 1228 1228 - val a_required : unit -> [>`Required] attrib 1229 1229 - val a_reversed : unit -> [>`Reversed] attrib 1230 1230 - val a_sandbox : [<sandbox_token] list Lwd.t -> [>`Sandbox] attrib 1231 1231 - val a_spellcheck : bool Lwd.t -> [>`Spellcheck] attrib 1232 1232 - val a_scoped : unit -> [>`Scoped] attrib 1233 1233 - val a_seamless : unit -> [>`Seamless] attrib 1234 1234 - val a_sizes : (int * int) list option Lwd.t -> [>`Sizes] attrib 1235 1235 - val a_span : int Lwd.t -> [>`Span] attrib 1236 1236 - 1237 1237 - type image_candidate = [ 1238 1238 - | `Url of Xml.uri 1239 1239 - | `Url_pixel of Xml.uri * float 1240 1240 - | `Url_width of Xml.uri * int 1241 1241 - ] 1242 1242 - val a_srcset : image_candidate list Lwd.t -> [>`Srcset] attrib 1243 1243 - val a_img_sizes : string list Lwd.t -> [>`Img_sizes] attrib 1244 1244 - val a_start : int Lwd.t -> [>`Start] attrib 1245 1245 - val a_step : float option Lwd.t -> [>`Step] attrib 1246 1246 - val a_wrap : [<`Hard | `Soft] Lwd.t -> [>`Wrap] attrib 1247 1247 - val a_version : string Lwd.t -> [>`Version] attrib 1248 1248 - val a_xmlns : [<`W3_org_1999_xhtml] Lwd.t -> [>`XMLns] attrib 1249 1249 - val a_manifest : Xml.uri Lwd.t -> [>`Manifest] attrib 1250 1250 - val a_cite : Xml.uri Lwd.t -> [>`Cite] attrib 1251 1251 - val a_xml_space : [<`Default | `Preserve] Lwd.t -> [>`XML_space] attrib 1252 1252 - val a_accesskey : char Lwd.t -> [>`Accesskey] attrib 1253 1253 - val a_charset : string Lwd.t -> [>`Charset] attrib 1254 1254 - val a_accept_charset : charsets Lwd.t -> [>`Accept_charset] attrib 1255 1255 - val a_accept : contenttypes Lwd.t -> [>`Accept] attrib 1256 1256 - val a_href : Xml.uri Lwd.t -> [>`Href] attrib 1257 1257 - val a_hreflang : string Lwd.t -> [>`Hreflang] attrib 1258 1258 - val a_download : string option Lwd.t -> [>`Download] attrib 1259 1259 - val a_rel : linktypes Lwd.t -> [>`Rel] attrib 1260 1260 - val a_tabindex : int Lwd.t -> [>`Tabindex] attrib 1261 1261 - val a_mime_type : string Lwd.t -> [>`Mime_type] attrib 1262 1262 - val a_datetime : string Lwd.t -> [>`Datetime] attrib 1263 1263 - val a_action : Xml.uri Lwd.t -> [>`Action] attrib 1264 1264 - val a_checked : unit -> [>`Checked] attrib 1265 1265 - val a_cols : int Lwd.t -> [>`Cols] attrib 1266 1266 - val a_enctype : string Lwd.t -> [>`Enctype] attrib 1267 1267 - val a_label_for : string Lwd.t -> [>`Label_for] attrib 1268 1268 - val a_output_for : idrefs Lwd.t -> [>`Output_for] attrib 1269 1269 - val a_maxlength : int Lwd.t -> [>`Maxlength] attrib 1270 1270 - val a_minlength : int Lwd.t -> [>`Minlength] attrib 1271 1271 - val a_method : [<`Get | `Post] Lwd.t -> [>`Method] attrib 1272 1272 - val a_multiple : unit -> [>`Multiple] attrib 1273 1273 - val a_name : string Lwd.t -> [>`Name] attrib 1274 1274 - val a_rows : int Lwd.t -> [>`Rows] attrib 1275 1275 - val a_selected : unit -> [>`Selected] attrib 1276 1276 - val a_size : int Lwd.t -> [>`Size] attrib 1277 1277 - val a_src : Xml.uri Lwd.t -> [>`Src] attrib 1278 1278 - val a_input_type : 1279 1279 - [<`Button|`Checkbox|`Color|`Date|`Datetime|`Datetime_local|`Email|`File 1280 1280 - |`Hidden|`Image|`Month|`Number|`Password|`Radio|`Range|`Reset|`Search 1281 1281 - |`Submit|`Tel|`Text|`Time|`Url|`Week] Lwd.t -> 1282 1282 - [>`Input_Type] attrib 1283 1283 - val a_text_value : string Lwd.t -> [>`Text_Value] attrib 1284 1284 - val a_int_value : int Lwd.t -> [>`Int_Value] attrib 1285 1285 - val a_value : string Lwd.t -> [>`Value] attrib 1286 1286 - val a_float_value : float Lwd.t -> [>`Float_Value] attrib 1287 1287 - val a_disabled : unit -> [>`Disabled] attrib 1288 1288 - val a_readonly : unit -> [>`ReadOnly] attrib 1289 1289 - val a_button_type : [<`Button|`Reset|`Submit] Lwd.t -> [>`Button_Type] attrib 1290 1290 - val a_command_type : [<`Checkbox|`Command|`Radio] Lwd.t -> [>`Command_Type] attrib 1291 1291 - val a_menu_type : [<`Context|`Toolbar] Lwd.t -> [>`Menu_Type] attrib 1292 1292 - val a_label : string Lwd.t -> [>`Label] attrib 1293 1293 - val a_colspan : int Lwd.t -> [>`Colspan] attrib 1294 1294 - val a_headers : idrefs Lwd.t -> [>`Headers] attrib 1295 1295 - val a_rowspan : int Lwd.t -> [>`Rowspan] attrib 1296 1296 - val a_alt : string Lwd.t -> [>`Alt] attrib 1297 1297 - val a_height : int Lwd.t -> [>`Height] attrib 1298 1298 - val a_width : int Lwd.t -> [>`Width] attrib 1299 1299 - 1300 1300 - type shape = [ `Circle | `Default | `Poly | `Rect] 1301 1301 - val a_shape : shape Lwd.t -> [>`Shape] attrib 1302 1302 - val a_coords : numbers Lwd.t -> [>`Coords] attrib 1303 1303 - val a_usemap : string Lwd.t -> [>`Usemap] attrib 1304 1304 - val a_data : Xml.uri Lwd.t -> [>`Data] attrib 1305 1305 - val a_scrolling : [<`Auto | `No | `Yes] Lwd.t -> [>`Scrolling] attrib 1306 1306 - val a_target : string Lwd.t -> [>`Target] attrib 1307 1307 - val a_content : string Lwd.t -> [>`Content] attrib 1308 1308 - val a_http_equiv : string Lwd.t -> [>`Http_equiv] attrib 1309 1309 - val a_defer : unit -> [>`Defer] attrib 1310 1310 - val a_media : mediadesc Lwd.t -> [>`Media] attrib 1311 1311 - val a_style : string Lwd.t -> [>`Style_Attr] attrib 1312 1312 - val a_property : string Lwd.t -> [>`Property] attrib 1313 1313 - val a_role : string list Lwd.t -> [>`Role] attrib 1314 1314 - val a_aria : string -> string list Lwd.t -> [>`Aria] attrib 1315 1315 - val txt : string Lwd.t -> [>txt] elt 1316 1316 - val html : ?a:html_attrib attrib list -> [<head] elt -> 1317 1317 - [<body] elt -> [>html] elt 1318 1318 - val head : ?a:head_attrib attrib list -> [<title] elt -> 1319 1319 - head_content_fun elt list -> [>head] elt 1320 1320 - val base : ([<base_attrib], [>base]) nullary 1321 1321 - val title : (noattrib, [<title_content_fun], [>title]) unary 1322 1322 - val body : ([<body_attrib], [<flow5], [>body]) star 1323 1323 - val svg : ?a:[<Svg_types.svg_attr] Svg.attrib list -> 1324 1324 - [<svg_content] Svg.elt list -> [>svg] elt 1325 1325 - val footer : ([<footer_attrib], [<footer_content_fun], [>footer]) star 1326 1326 - val header : ([<header_attrib], [<header_content_fun], [>header]) star 1327 1327 - val section : ([<section_attrib], [<section_content_fun], [>section]) star 1328 1328 - val nav : ([<nav_attrib], [<nav_content_fun], [>nav]) star 1329 1329 - val h1 : ([<h1_attrib], [<h1_content_fun], [>h1]) star 1330 1330 - val h2 : ([<h2_attrib], [<h2_content_fun], [>h2]) star 1331 1331 - val h3 : ([<h3_attrib], [<h3_content_fun], [>h3]) star 1332 1332 - val h4 : ([<h4_attrib], [<h4_content_fun], [>h4]) star 1333 1333 - val h5 : ([<h5_attrib], [<h5_content_fun], [>h5]) star 1334 1334 - val h6 : ([<h6_attrib], [<h6_content_fun], [>h6]) star 1335 1335 - val hgroup : ([<hgroup_attrib], [<hgroup_content_fun], [>hgroup]) star 1336 1336 - val address : ([<address_attrib], [<address_content_fun], [>address]) star 1337 1337 - val article : ([<article_attrib], [<article_content_fun], [>article]) star 1338 1338 - val aside : ([<aside_attrib], [<aside_content_fun], [>aside]) star 1339 1339 - val main : ([<main_attrib], [<main_content_fun], [>main]) star 1340 1340 - val p : ([<p_attrib], [<p_content_fun], [>p]) star 1341 1341 - val pre : ([<pre_attrib], [<pre_content_fun], [>pre]) star 1342 1342 - val blockquote : 1343 1343 - ([<blockquote_attrib], [<blockquote_content_fun], [>blockquote]) star 1344 1344 - val div : ([<div_attrib], [<div_content_fun], [>div]) star 1345 1345 - val dl : ([<dl_attrib], [<dl_content_fun], [>dl]) star 1346 1346 - val ol : ([<ol_attrib], [<ol_content_fun], [>ol]) star 1347 1347 - val ul : ([<ul_attrib], [<ul_content_fun], [>ul]) star 1348 1348 - val dd : ([<dd_attrib], [<dd_content_fun], [>dd]) star 1349 1349 - val dt : ([<dt_attrib], [<dt_content_fun], [>dt]) star 1350 1350 - val li : ([<li_attrib], [<li_content_fun], [>li]) star 1351 1351 - val figcaption : 1352 1352 - ([<figcaption_attrib], [<figcaption_content_fun], [>figcaption]) star 1353 1353 - val figure : 1354 1354 - ?figcaption:[`Bottom of [<figcaption] elt |`Top of [<figcaption] elt] -> 1355 1355 - ([<figure_attrib], [<figure_content_fun], [>figure]) star 1356 1356 - val hr : ([<hr_attrib], [>hr]) nullary 1357 1357 - val b : ([<b_attrib], [<b_content_fun], [>b]) star 1358 1358 - val i : ([<i_attrib], [<i_content_fun], [>i]) star 1359 1359 - val u : ([<u_attrib], [<u_content_fun], [>u]) star 1360 1360 - val small : ([<small_attrib], [<small_content_fun], [>small]) star 1361 1361 - val sub : ([<sub_attrib], [<sub_content_fun], [>sub]) star 1362 1362 - val sup : ([<sup_attrib], [<sup_content_fun], [>sup]) star 1363 1363 - val mark : ([<mark_attrib], [<mark_content_fun], [>mark]) star 1364 1364 - val wbr : ([<wbr_attrib], [>wbr]) nullary 1365 1365 - val bdo : dir:[<`Ltr | `Rtl] Lwd.t -> 1366 1366 - ([<bdo_attrib], [<bdo_content_fun], [>bdo]) star 1367 1367 - val abbr : ([<abbr_attrib], [<abbr_content_fun], [>abbr]) star 1368 1368 - val br : ([<br_attrib], [>br]) nullary 1369 1369 - val cite : ([<cite_attrib], [<cite_content_fun], [>cite]) star 1370 1370 - val code : ([<code_attrib], [<code_content_fun], [>code]) star 1371 1371 - val dfn : ([<dfn_attrib], [<dfn_content_fun], [>dfn]) star 1372 1372 - val em : ([<em_attrib], [<em_content_fun], [>em]) star 1373 1373 - val kbd : ([<kbd_attrib], [<kbd_content_fun], [>kbd]) star 1374 1374 - val q : ([<q_attrib], [<q_content_fun], [>q]) star 1375 1375 - val samp : ([<samp_attrib], [<samp_content_fun], [>samp]) star 1376 1376 - val span : ([<span_attrib], [<span_content_fun], [>span]) star 1377 1377 - val strong : ([<strong_attrib], [<strong_content_fun], [>strong]) star 1378 1378 - val time : ([<time_attrib], [<time_content_fun], [>time]) star 1379 1379 - val var : ([<var_attrib], [<var_content_fun], [>var]) star 1380 1380 - val a : ([<a_attrib], 'a, [>'a a]) star 1381 1381 - val del : ([<del_attrib], 'a, [>'a del]) star 1382 1382 - val ins : ([<ins_attrib], 'a, [>'a ins]) star 1383 1383 - val img : src:Xml.uri Lwd.t -> alt:string Lwd.t -> 1384 1384 - ([<img_attrib], [>img]) nullary 1385 1385 - val iframe : ([<iframe_attrib], [<iframe_content_fun], [>iframe]) star 1386 1386 - val object_ : ?params:[<param] elt list -> 1387 1387 - ([<object__attrib], 'a, [>`Object of 'a]) star 1388 1388 - val param : ([<param_attrib], [>param]) nullary 1389 1389 - val embed : ([<embed_attrib], [>embed]) nullary 1390 1390 - val audio : ?src:Xml.uri Lwd.t -> ?srcs:[<source] elt list -> 1391 1391 - ([<audio_attrib], 'a, [>'a audio]) star 1392 1392 - val video : ?src:Xml.uri Lwd.t -> ?srcs:[<source] elt list -> 1393 1393 - ([<video_attrib], 'a, [>'a video]) star 1394 1394 - val canvas : ([<canvas_attrib], 'a, [>'a canvas]) star 1395 1395 - val source : ([<source_attrib], [>source]) nullary 1396 1396 - val area : alt:string Lwd.t -> 1397 1397 - ([<`Accesskey|`Alt|`Aria|`Class|`Contenteditable|`Contextmenu|`Coords 1398 1398 - |`Dir|`Draggable|`Hidden|`Hreflang|`Id|`Lang |`Media|`Mime_type 1399 1399 - |`OnAbort|`OnBlur|`OnCanPlay|`OnCanPlayThrough|`OnChange|`OnClick 1400 1400 - |`OnContextMenu|`OnDblClick|`OnDrag|`OnDragEnd|`OnDragEnter 1401 1401 - |`OnDragLeave|`OnDragOver|`OnDragStart|`OnDrop|`OnDurationChange 1402 1402 - |`OnEmptied|`OnEnded|`OnError|`OnFocus|`OnFormChange|`OnFormInput 1403 1403 - |`OnInput|`OnInvalid|`OnKeyDown|`OnKeyPress|`OnKeyUp|`OnLoad 1404 1404 - |`OnLoadStart|`OnLoadedData|`OnLoadedMetaData|`OnMouseDown 1405 1405 - |`OnMouseMove|`OnMouseOut|`OnMouseOver|`OnMouseUp|`OnMouseWheel 1406 1406 - |`OnPause|`OnPlay|`OnPlaying|`OnProgress|`OnRateChange 1407 1407 - |`OnReadyStateChange|`OnScroll|`OnSeeked|`OnSeeking|`OnSelect 1408 1408 - |`OnShow|`OnStalled|`OnSubmit|`OnSuspend|`OnTimeUpdate|`OnTouchCancel 1409 1409 - |`OnTouchEnd|`OnTouchMove|`OnTouchStart|`OnVolumeChange|`OnWaiting 1410 1410 - |`Rel|`Role|`Shape|`Spellcheck|`Style_Attr|`Tabindex|`Target 1411 1411 - |`Title|`User_data|`XML_lang|`XMLns], [>area]) nullary 1412 1412 - val map : ([<map_attrib], 'a, [>'a map]) star 1413 1413 - val caption : ([<caption_attrib], [<caption_content_fun], [>caption]) star 1414 1414 - val table : 1415 1415 - ?caption:[<caption] elt -> ?columns:[<colgroup] elt list -> 1416 1416 - ?thead:[<thead] elt -> ?tfoot:[<tfoot] elt -> 1417 1417 - ([<table_attrib], [<table_content_fun], [>table]) star 1418 1418 - val tablex : 1419 1419 - ?caption:[<caption] elt -> ?columns:[<colgroup] elt list -> 1420 1420 - ?thead:[<thead] elt -> ?tfoot:[<tfoot] elt -> 1421 1421 - ([<tablex_attrib], [<tablex_content_fun], [>tablex]) star 1422 1422 - val colgroup : 1423 1423 - ([<colgroup_attrib], [<colgroup_content_fun], [>colgroup]) star 1424 1424 - val col : ([<col_attrib], [>col]) nullary 1425 1425 - val thead : ([<thead_attrib], [<thead_content_fun], [>thead]) star 1426 1426 - val tbody : ([<tbody_attrib], [<tbody_content_fun], [>tbody]) star 1427 1427 - val tfoot : ([<tfoot_attrib], [<tfoot_content_fun], [>tfoot]) star 1428 1428 - val td : ([<td_attrib], [<td_content_fun], [>td]) star 1429 1429 - val th : ([<th_attrib], [<th_content_fun], [>th]) star 1430 1430 - val tr : ([<tr_attrib], [<tr_content_fun], [>tr]) star 1431 1431 - val form : ([<form_attrib], [<form_content_fun], [>form]) star 1432 1432 - val fieldset : ?legend:[<legend] elt -> 1433 1433 - ([<fieldset_attrib], [<fieldset_content_fun], [>fieldset]) star 1434 1434 - val legend : ([<legend_attrib], [<legend_content_fun], [>legend]) star 1435 1435 - val label : ([<label_attrib], [<label_content_fun], [>label]) star 1436 1436 - val input : ([<input_attrib], [>input]) nullary 1437 1437 - val button : ([<button_attrib], [<button_content_fun], [>button]) star 1438 1438 - val select : ([<select_attrib], [<select_content_fun], [>select]) star 1439 1439 - val datalist : ?children:[<`Options of [<selectoption] elt list 1440 1440 - | `Phras of [<phrasing] elt list] -> 1441 1441 - ([<datalist_attrib], [>datalist]) nullary 1442 1442 - val optgroup : label:string Lwd.t -> 1443 1443 - ([<optgroup_attrib], [<optgroup_content_fun], [>optgroup]) star 1444 1444 - val option : 1445 1445 - ([<option_attrib], [<option_content_fun], [>selectoption]) unary 1446 1446 - val textarea : ?a:[<textarea_attrib] attrib list -> string Lwd.t -> [>textarea] elt 1447 1447 - (* Textarea syntactically looks like it takes its content from its children 1448 1448 - nodes, but dynamic semantics use the value attribute :-( *) 1449 1449 - val keygen : 1450 1450 - ([<keygen_attrib], [>keygen]) nullary 1451 1451 - val progress : 1452 1452 - ([<progress_attrib], [<progress_content_fun], [>progress]) star 1453 1453 - val meter : 1454 1454 - ([<meter_attrib], [<meter_content_fun], [>meter]) star 1455 1455 - val output_elt : 1456 1456 - ([<output_elt_attrib], [<output_elt_content_fun], [>output_elt]) star 1457 1457 - val entity : string -> [>txt] elt 1458 1458 - val space : unit -> [>txt] elt 1459 1459 - val cdata : string -> [>txt] elt 1460 1460 - val cdata_script : string -> [>txt] elt 1461 1461 - val cdata_style : string -> [>txt] elt 1462 1462 - val details : [<summary] elt -> 1463 1463 - ([<details_attrib], [<details_content_fun], [>details]) star 1464 1464 - val summary : ([<summary_attrib], [<summary_content_fun], [>summary]) star 1465 1465 - val command : label:string Lwd.t -> ([<command_attrib], [>command]) nullary 1466 1466 - val menu : ?children:[<`Flows of [<flow5] elt list 1467 1467 - | `Lis of [<`Li of [<common]] elt list] -> 1468 1468 - ([<menu_attrib], [>menu]) nullary 1469 1469 - val script : 1470 1470 - ([<script_attrib], [<script_content_fun], [>script]) unary 1471 1471 - val noscript : 1472 1472 - ([<noscript_attrib], [<flow5_without_noscript], [>noscript]) star 1473 1473 - val template : 1474 1474 - ([<template_attrib], [<template_content_fun], [>template]) star 1475 1475 - val meta : ([<meta_attrib], [>meta]) nullary 1476 1476 - val style : ([<style_attrib], [<style_content_fun], [>style]) star 1477 1477 - val link : rel:linktypes Lwd.t -> href:Xml.uri Lwd.t -> 1478 1478 - ([<link_attrib], [>link]) nullary 1479 1479 - val rt : ([<rt_attrib], [<rt_content_fun], [>rt]) star 1480 1480 - val rp : ([<rp_attrib], [<rp_content_fun], [>rp]) star 1481 1481 - val ruby : ([<ruby_attrib], [<ruby_content_fun], [>ruby]) star 1482 1482 - 1483 1483 - (* val pcdata : string Lwd.t -> [>pcdata] elt *) 1484 1484 - (* val of_seq : Xml_stream.signal Seq.t -> 'a elt list *) 1485 1485 - val tot : Xml.elt -> 'a elt 1486 1486 - (* val totl : Xml.elt list -> 'a elt list *) 1487 1487 - val toelt : 'a elt -> Xml.elt 1488 1488 - (* val toeltl : 'a elt list -> Xml.elt list *) 1489 1489 - val doc_toelt : doc -> Xml.elt 1490 1490 - val to_xmlattribs : 'a attrib list -> Xml.attrib list 1491 1491 - val to_attrib : Xml.attrib -> 'a attrib 1492 1492 - 1493 1493 - (* module Unsafe : sig 1494 1494 - val data : string Lwd.t -> 'a elt 1495 1495 - val node : string -> ?a:'a attrib list -> 'b elt list -> 'c elt 1496 1496 - val leaf : string -> ?a:'a attrib list -> unit -> 'b elt 1497 1497 - val coerce_elt : 'a elt -> 'b elt 1498 1498 - val string_attrib : string -> string Lwd.t -> 'a attrib 1499 1499 - val float_attrib : string -> float Lwd.t -> 'a attrib 1500 1500 - val int_attrib : string -> int Lwd.t -> 'a attrib 1501 1501 - val uri_attrib : string -> Xml.uri Lwd.t -> 'a attrib 1502 1502 - val space_sep_attrib : string -> string list Lwd.t -> 'a attrib 1503 1503 - val comma_sep_attrib : string -> string list Lwd.t -> 'a attrib 1504 1504 - end *) 1505 1505 - end = struct 1506 1506 - type 'a elt = 'a Raw_html.elt 1507 1507 - type doc = Raw_html.doc 1508 1508 - type nonrec +'a attrib = 'a attrib 1509 1509 - type ('a, 'b) nullary = ?a:'a attrib list -> unit -> 'b elt 1510 1510 - type ('a, 'b, 'c) unary = ?a:'a attrib list -> 'b elt -> 'c elt 1511 1511 - type ('a, 'b, 'c) star = ?a:'a attrib list -> 'b elt list -> 'c elt 1512 1512 - module Info = Raw_html.Info 1513 1513 - 1514 1514 - let string_of_uri = Raw_html.string_of_uri 1515 1515 - let uri_of_string = Raw_html.uri_of_string 1516 1516 - let a_class = Raw_html.a_class 1517 1517 - let a_user_data = Raw_html.a_user_data 1518 1518 - let a_id = Raw_html.a_id 1519 1519 - let a_title = Raw_html.a_title 1520 1520 - let a_xml_lang = Raw_html.a_xml_lang 1521 1521 - let a_lang = Raw_html.a_lang 1522 1522 - let a_onabort = Raw_html.a_onabort 1523 1523 - let a_onafterprint = Raw_html.a_onafterprint 1524 1524 - let a_onbeforeprint = Raw_html.a_onbeforeprint 1525 1525 - let a_onbeforeunload = Raw_html.a_onbeforeunload 1526 1526 - let a_onblur = Raw_html.a_onblur 1527 1527 - let a_oncanplay = Raw_html.a_oncanplay 1528 1528 - let a_oncanplaythrough = Raw_html.a_oncanplaythrough 1529 1529 - let a_onchange = Raw_html.a_onchange 1530 1530 - let a_ondurationchange = Raw_html.a_ondurationchange 1531 1531 - let a_onemptied = Raw_html.a_onemptied 1532 1532 - let a_onended = Raw_html.a_onended 1533 1533 - let a_onerror = Raw_html.a_onerror 1534 1534 - let a_onfocus = Raw_html.a_onfocus 1535 1535 - let a_onformchange = Raw_html.a_onformchange 1536 1536 - let a_onforminput = Raw_html.a_onforminput 1537 1537 - let a_onhashchange = Raw_html.a_onhashchange 1538 1538 - let a_oninput = Raw_html.a_oninput 1539 1539 - let a_oninvalid = Raw_html.a_oninvalid 1540 1540 - let a_onmousewheel = Raw_html.a_onmousewheel 1541 1541 - let a_onoffline = Raw_html.a_onoffline 1542 1542 - let a_ononline = Raw_html.a_ononline 1543 1543 - let a_onpause = Raw_html.a_onpause 1544 1544 - let a_onplay = Raw_html.a_onplay 1545 1545 - let a_onplaying = Raw_html.a_onplaying 1546 1546 - let a_onpagehide = Raw_html.a_onpagehide 1547 1547 - let a_onpageshow = Raw_html.a_onpageshow 1548 1548 - let a_onpopstate = Raw_html.a_onpopstate 1549 1549 - let a_onprogress = Raw_html.a_onprogress 1550 1550 - let a_onratechange = Raw_html.a_onratechange 1551 1551 - let a_onreadystatechange = Raw_html.a_onreadystatechange 1552 1552 - let a_onredo = Raw_html.a_onredo 1553 1553 - let a_onresize = Raw_html.a_onresize 1554 1554 - let a_onscroll = Raw_html.a_onscroll 1555 1555 - let a_onseeked = Raw_html.a_onseeked 1556 1556 - let a_onseeking = Raw_html.a_onseeking 1557 1557 - let a_onselect = Raw_html.a_onselect 1558 1558 - let a_onshow = Raw_html.a_onshow 1559 1559 - let a_onstalled = Raw_html.a_onstalled 1560 1560 - let a_onstorage = Raw_html.a_onstorage 1561 1561 - let a_onsubmit = Raw_html.a_onsubmit 1562 1562 - let a_onsuspend = Raw_html.a_onsuspend 1563 1563 - let a_ontimeupdate = Raw_html.a_ontimeupdate 1564 1564 - let a_onundo = Raw_html.a_onundo 1565 1565 - let a_onunload = Raw_html.a_onunload 1566 1566 - let a_onvolumechange = Raw_html.a_onvolumechange 1567 1567 - let a_onwaiting = Raw_html.a_onwaiting 1568 1568 - let a_onload = Raw_html.a_onload 1569 1569 - let a_onloadeddata = Raw_html.a_onloadeddata 1570 1570 - let a_onloadedmetadata = Raw_html.a_onloadedmetadata 1571 1571 - let a_onloadstart = Raw_html.a_onloadstart 1572 1572 - let a_onmessage = Raw_html.a_onmessage 1573 1573 - let a_onclick = Raw_html.a_onclick 1574 1574 - let a_oncontextmenu = Raw_html.a_oncontextmenu 1575 1575 - let a_ondblclick = Raw_html.a_ondblclick 1576 1576 - let a_ondrag = Raw_html.a_ondrag 1577 1577 - let a_ondragend = Raw_html.a_ondragend 1578 1578 - let a_ondragenter = Raw_html.a_ondragenter 1579 1579 - let a_ondragleave = Raw_html.a_ondragleave 1580 1580 - let a_ondragover = Raw_html.a_ondragover 1581 1581 - let a_ondragstart = Raw_html.a_ondragstart 1582 1582 - let a_ondrop = Raw_html.a_ondrop 1583 1583 - let a_onmousedown = Raw_html.a_onmousedown 1584 1584 - let a_onmouseup = Raw_html.a_onmouseup 1585 1585 - let a_onmouseover = Raw_html.a_onmouseover 1586 1586 - let a_onmousemove = Raw_html.a_onmousemove 1587 1587 - let a_onmouseout = Raw_html.a_onmouseout 1588 1588 - let a_ontouchstart = Raw_html.a_ontouchstart 1589 1589 - let a_ontouchend = Raw_html.a_ontouchend 1590 1590 - let a_ontouchmove = Raw_html.a_ontouchmove 1591 1591 - let a_ontouchcancel = Raw_html.a_ontouchcancel 1592 1592 - let a_onkeypress = Raw_html.a_onkeypress 1593 1593 - let a_onkeydown = Raw_html.a_onkeydown 1594 1594 - let a_onkeyup = Raw_html.a_onkeyup 1595 1595 - let a_allowfullscreen = Raw_html.a_allowfullscreen 1596 1596 - let a_allowpaymentrequest = Raw_html.a_allowpaymentrequest 1597 1597 - let a_autocomplete = Raw_html.a_autocomplete 1598 1598 - let a_async = Raw_html.a_async 1599 1599 - let a_autofocus = Raw_html.a_autofocus 1600 1600 - let a_autoplay = Raw_html.a_autoplay 1601 1601 - let a_muted = Raw_html.a_muted 1602 1602 - let a_crossorigin = Raw_html.a_crossorigin 1603 1603 - let a_integrity = Raw_html.a_integrity 1604 1604 - let a_mediagroup = Raw_html.a_mediagroup 1605 1605 - let a_challenge = Raw_html.a_challenge 1606 1606 - let a_contenteditable = Raw_html.a_contenteditable 1607 1607 - let a_contextmenu = Raw_html.a_contextmenu 1608 1608 - let a_controls = Raw_html.a_controls 1609 1609 - let a_dir = Raw_html.a_dir 1610 1610 - let a_draggable = Raw_html.a_draggable 1611 1611 - let a_form = Raw_html.a_form 1612 1612 - let a_formaction = Raw_html.a_formaction 1613 1613 - let a_formenctype = Raw_html.a_formenctype 1614 1614 - let a_formnovalidate = Raw_html.a_formnovalidate 1615 1615 - let a_formtarget = Raw_html.a_formtarget 1616 1616 - let a_hidden = Raw_html.a_hidden 1617 1617 - let a_high = Raw_html.a_high 1618 1618 - let a_icon = Raw_html.a_icon 1619 1619 - let a_ismap = Raw_html.a_ismap 1620 1620 - let a_keytype = Raw_html.a_keytype 1621 1621 - let a_list = Raw_html.a_list 1622 1622 - let a_loop = Raw_html.a_loop 1623 1623 - let a_low = Raw_html.a_low 1624 1624 - let a_max = Raw_html.a_max 1625 1625 - let a_input_max = Raw_html.a_input_max 1626 1626 - let a_min = Raw_html.a_min 1627 1627 - let a_input_min = Raw_html.a_input_min 1628 1628 - let a_inputmode = Raw_html.a_inputmode 1629 1629 - let a_novalidate = Raw_html.a_novalidate 1630 1630 - let a_open = Raw_html.a_open 1631 1631 - let a_optimum = Raw_html.a_optimum 1632 1632 - let a_pattern = Raw_html.a_pattern 1633 1633 - let a_placeholder = Raw_html.a_placeholder 1634 1634 - let a_poster = Raw_html.a_poster 1635 1635 - let a_preload = Raw_html.a_preload 1636 1636 - let a_pubdate = Raw_html.a_pubdate 1637 1637 - let a_radiogroup = Raw_html.a_radiogroup 1638 1638 - let a_referrerpolicy = Raw_html.a_referrerpolicy 1639 1639 - let a_required = Raw_html.a_required 1640 1640 - let a_reversed = Raw_html.a_reversed 1641 1641 - let a_sandbox = Raw_html.a_sandbox 1642 1642 - let a_spellcheck = Raw_html.a_spellcheck 1643 1643 - let a_scoped = Raw_html.a_scoped 1644 1644 - let a_seamless = Raw_html.a_seamless 1645 1645 - let a_sizes = Raw_html.a_sizes 1646 1646 - let a_span = Raw_html.a_span 1647 1647 - type image_candidate = [ 1648 1648 - | `Url of Xml.uri 1649 1649 - | `Url_pixel of Xml.uri * float 1650 1650 - | `Url_width of Xml.uri * int 1651 1651 - ] 1652 1652 - let a_srcset = Raw_html.a_srcset 1653 1653 - let a_img_sizes = Raw_html.a_img_sizes 1654 1654 - let a_start = Raw_html.a_start 1655 1655 - let a_step = Raw_html.a_step 1656 1656 - let a_wrap = Raw_html.a_wrap 1657 1657 - let a_version = Raw_html.a_version 1658 1658 - let a_xmlns = Raw_html.a_xmlns 1659 1659 - let a_manifest = Raw_html.a_manifest 1660 1660 - let a_cite = Raw_html.a_cite 1661 1661 - let a_xml_space = Raw_html.a_xml_space 1662 1662 - let a_accesskey = Raw_html.a_accesskey 1663 1663 - let a_charset = Raw_html.a_charset 1664 1664 - let a_accept_charset = Raw_html.a_accept_charset 1665 1665 - let a_accept = Raw_html.a_accept 1666 1666 - let a_href = Raw_html.a_href 1667 1667 - let a_hreflang = Raw_html.a_hreflang 1668 1668 - let a_download = Raw_html.a_download 1669 1669 - let a_rel = Raw_html.a_rel 1670 1670 - let a_tabindex = Raw_html.a_tabindex 1671 1671 - let a_mime_type = Raw_html.a_mime_type 1672 1672 - let a_datetime = Raw_html.a_datetime 1673 1673 - let a_action = Raw_html.a_action 1674 1674 - let a_checked = Raw_html.a_checked 1675 1675 - let a_cols = Raw_html.a_cols 1676 1676 - let a_enctype = Raw_html.a_enctype 1677 1677 - let a_label_for = Raw_html.a_label_for 1678 1678 - let a_output_for = Raw_html.a_output_for 1679 1679 - let a_maxlength = Raw_html.a_maxlength 1680 1680 - let a_minlength = Raw_html.a_minlength 1681 1681 - let a_method = Raw_html.a_method 1682 1682 - let a_multiple = Raw_html.a_multiple 1683 1683 - let a_name = Raw_html.a_name 1684 1684 - let a_rows = Raw_html.a_rows 1685 1685 - let a_selected = Raw_html.a_selected 1686 1686 - let a_size = Raw_html.a_size 1687 1687 - let a_src = Raw_html.a_src 1688 1688 - let a_input_type = Raw_html.a_input_type 1689 1689 - let a_text_value = Raw_html.a_text_value 1690 1690 - let a_int_value = Raw_html.a_int_value 1691 1691 - let a_value = Raw_html.a_value 1692 1692 - let a_float_value = Raw_html.a_float_value 1693 1693 - let a_disabled = Raw_html.a_disabled 1694 1694 - let a_readonly = Raw_html.a_readonly 1695 1695 - let a_button_type = Raw_html.a_button_type 1696 1696 - let a_command_type = Raw_html.a_command_type 1697 1697 - let a_menu_type = Raw_html.a_menu_type 1698 1698 - let a_label = Raw_html.a_label 1699 1699 - let a_colspan = Raw_html.a_colspan 1700 1700 - let a_headers = Raw_html.a_headers 1701 1701 - let a_rowspan = Raw_html.a_rowspan 1702 1702 - let a_alt = Raw_html.a_alt 1703 1703 - let a_height = Raw_html.a_height 1704 1704 - let a_width = Raw_html.a_width 1705 1705 - type shape = [ `Circle | `Default | `Poly | `Rect] 1706 1706 - let a_shape = Raw_html.a_shape 1707 1707 - let a_coords = Raw_html.a_coords 1708 1708 - let a_usemap = Raw_html.a_usemap 1709 1709 - let a_data = Raw_html.a_data 1710 1710 - let a_scrolling = Raw_html.a_scrolling 1711 1711 - let a_target = Raw_html.a_target 1712 1712 - let a_content = Raw_html.a_content 1713 1713 - let a_http_equiv = Raw_html.a_http_equiv 1714 1714 - let a_defer = Raw_html.a_defer 1715 1715 - let a_media = Raw_html.a_media 1716 1716 - let a_style = Raw_html.a_style 1717 1717 - let a_property = Raw_html.a_property 1718 1718 - let a_role = Raw_html.a_role 1719 1719 - let a_aria = Raw_html.a_aria 1720 1720 - 1721 1721 - let unary (f: ('a, 'b, 'c) Raw_html.unary) : ('a, 'b, 'c) unary = 1722 1722 - fun ?a elt -> f ?a (Lwd.pure elt) 1723 1723 - 1724 1724 - let star (f: ('a, 'b, 'c) Raw_html.star) : ('a, 'b, 'c) star = 1725 1725 - fun ?a elts -> f ?a (List.map Lwd.pure elts) 1726 1726 - 1727 1727 - let pure_opt = function None -> None | Some x -> Some (Lwd.pure x) 1728 1728 - let pures xs = List.map Lwd.pure xs 1729 1729 - let pures_opt = function None -> None | Some xs -> Some (pures xs) 1730 1730 - 1731 1731 - let txt = Raw_html.txt 1732 1732 - let html ?a e1 e2 = Raw_html.html ?a (Lwd.pure e1) (Lwd.pure e2) 1733 1733 - let head ?a e1 elts = Raw_html.head ?a (Lwd.pure e1) (pures elts) 1734 1734 - let base = Raw_html.base 1735 1735 - let title = unary Raw_html.title 1736 1736 - let body = star Raw_html.body 1737 1737 - let svg = star Raw_html.svg 1738 1738 - let footer = star Raw_html.footer 1739 1739 - let header = star Raw_html.header 1740 1740 - let section = star Raw_html.section 1741 1741 - let nav = star Raw_html.nav 1742 1742 - let h1 = star Raw_html.h1 1743 1743 - let h2 = star Raw_html.h2 1744 1744 - let h3 = star Raw_html.h3 1745 1745 - let h4 = star Raw_html.h4 1746 1746 - let h5 = star Raw_html.h5 1747 1747 - let h6 = star Raw_html.h6 1748 1748 - let hgroup = star Raw_html.hgroup 1749 1749 - let address = star Raw_html.address 1750 1750 - let article = star Raw_html.article 1751 1751 - let aside = star Raw_html.aside 1752 1752 - let main = star Raw_html.main 1753 1753 - let p = star Raw_html.p 1754 1754 - let pre = star Raw_html.pre 1755 1755 - let blockquote = star Raw_html.blockquote 1756 1756 - let div = star Raw_html.div 1757 1757 - let dl = star Raw_html.dl 1758 1758 - let ol = star Raw_html.ol 1759 1759 - let ul = star Raw_html.ul 1760 1760 - let dd = star Raw_html.dd 1761 1761 - let dt = star Raw_html.dt 1762 1762 - let li = star Raw_html.li 1763 1763 - let figcaption = star Raw_html.figcaption 1764 1764 - let figure ?figcaption ?a elts = 1765 1765 - let figcaption = match figcaption with 1766 1766 - | None -> None 1767 1767 - | Some (`Bottom elt) -> Some (`Bottom (Lwd.pure elt)) 1768 1768 - | Some (`Top elt) -> Some (`Top (Lwd.pure elt)) 1769 1769 - in 1770 1770 - Raw_html.figure ?figcaption ?a (pures elts) 1771 1771 - let hr = Raw_html.hr 1772 1772 - let b = star Raw_html.b 1773 1773 - let i = star Raw_html.i 1774 1774 - let u = star Raw_html.u 1775 1775 - let small = star Raw_html.small 1776 1776 - let sub = star Raw_html.sub 1777 1777 - let sup = star Raw_html.sup 1778 1778 - let mark = star Raw_html.mark 1779 1779 - let wbr = Raw_html.wbr 1780 1780 - let bdo ~dir = star (Raw_html.bdo ~dir) 1781 1781 - let abbr = star Raw_html.abbr 1782 1782 - let br = Raw_html.br 1783 1783 - let cite = star Raw_html.cite 1784 1784 - let code = star Raw_html.code 1785 1785 - let dfn = star Raw_html.dfn 1786 1786 - let em = star Raw_html.em 1787 1787 - let kbd = star Raw_html.kbd 1788 1788 - let q = star Raw_html.q 1789 1789 - let samp = star Raw_html.samp 1790 1790 - let span = star Raw_html.span 1791 1791 - let strong = star Raw_html.strong 1792 1792 - let time = star Raw_html.time 1793 1793 - let var = star Raw_html.var 1794 1794 - let a = star Raw_html.a 1795 1795 - let del = star Raw_html.del 1796 1796 - let ins = star Raw_html.ins 1797 1797 - let img = Raw_html.img 1798 1798 - let iframe = star Raw_html.iframe 1799 1799 - let object_ ?params ?a elts = 1800 1800 - Raw_html.object_ ?params:(pures_opt params) ?a (pures elts) 1801 1801 - let param = Raw_html.param 1802 1802 - let embed = Raw_html.embed 1803 1803 - let audio ?src ?srcs ?a elts = 1804 1804 - Raw_html.audio ?src ?srcs:(pures_opt srcs) ?a (pures elts) 1805 1805 - let video ?src ?srcs ?a elts = 1806 1806 - Raw_html.video ?src ?srcs:(pures_opt srcs) ?a (pures elts) 1807 1807 - let canvas = star Raw_html.canvas 1808 1808 - let source = Raw_html.source 1809 1809 - let area = Raw_html.area 1810 1810 - let map = star Raw_html.map 1811 1811 - let caption = star Raw_html.caption 1812 1812 - let table ?caption ?columns ?thead ?tfoot ?a elts = 1813 1813 - Raw_html.table ?caption:(pure_opt caption) ?columns:(pures_opt columns) 1814 1814 - ?thead:(pure_opt thead) ?tfoot:(pure_opt tfoot) ?a (pures elts) 1815 1815 - let tablex ?caption ?columns ?thead ?tfoot ?a elts = 1816 1816 - Raw_html.tablex ?caption:(pure_opt caption) ?columns:(pures_opt columns) 1817 1817 - ?thead:(pure_opt thead) ?tfoot:(pure_opt tfoot) ?a (pures elts) 1818 1818 - let colgroup = star Raw_html.colgroup 1819 1819 - let col = Raw_html.col 1820 1820 - let thead = star Raw_html.thead 1821 1821 - let tbody = star Raw_html.tbody 1822 1822 - let tfoot = star Raw_html.tfoot 1823 1823 - let td = star Raw_html.td 1824 1824 - let th = star Raw_html.th 1825 1825 - let tr = star Raw_html.tr 1826 1826 - let form = star Raw_html.form 1827 1827 - let fieldset ?legend ?a elts = 1828 1828 - Raw_html.fieldset ?legend:(pure_opt legend) ?a (pures elts) 1829 1829 - let legend = star Raw_html.legend 1830 1830 - let label = star Raw_html.label 1831 1831 - let input = Raw_html.input 1832 1832 - let button = star Raw_html.button 1833 1833 - let select = star Raw_html.select 1834 1834 - let datalist ?children ?a () = 1835 1835 - let children = match children with 1836 1836 - | None -> None 1837 1837 - | Some (`Options elts) -> Some (`Options (pures elts)) 1838 1838 - | Some (`Phras elts) -> Some (`Phras (pures elts)) 1839 1839 - in 1840 1840 - Raw_html.datalist ?children ?a () 1841 1841 - let optgroup ~label ?a elts = Raw_html.optgroup ~label ?a (pures elts) 1842 1842 - let option = unary Raw_html.option 1843 1843 - let textarea ?(a=[]) txt = 1844 1844 - let value = Lwd.map ~f:(fun txt -> Some (Js.string txt)) txt in 1845 1845 - let attrib = Attrib.Attrib {name="value"; value} in 1846 1846 - Raw_html.textarea ~a:(attrib :: a) 1847 1847 - (Lwd.pure (Lwd.pure Lwd_seq.empty)) 1848 1848 - (*(Lwd.pure (Xml.pcdata txt))*) 1849 1849 - let keygen = Raw_html.keygen 1850 1850 - let progress = star Raw_html.progress 1851 1851 - let meter = star Raw_html.meter 1852 1852 - let output_elt = star Raw_html.output_elt 1853 1853 - let entity = Raw_html.entity 1854 1854 - let space = Raw_html.space 1855 1855 - let cdata = Raw_html.cdata 1856 1856 - let cdata_script = Raw_html.cdata_script 1857 1857 - let cdata_style = Raw_html.cdata_style 1858 1858 - let details elt ?a elts = Raw_html.details (Lwd.pure elt) ?a (pures elts) 1859 1859 - let summary = star Raw_html.summary 1860 1860 - let command = Raw_html.command 1861 1861 - let menu ?children ?a () = 1862 1862 - let children = match children with 1863 1863 - | None -> None 1864 1864 - | Some (`Flows elts) -> Some (`Flows (pures elts)) 1865 1865 - | Some (`Lis elts) -> Some (`Lis (pures elts)) 1866 1866 - in 1867 1867 - Raw_html.menu ?children ?a () 1868 1868 - let script = unary Raw_html.script 1869 1869 - let noscript = star Raw_html.noscript 1870 1870 - let template = star Raw_html.template 1871 1871 - let meta = Raw_html.meta 1872 1872 - let style = star Raw_html.style 1873 1873 - let link = Raw_html.link 1874 1874 - let rt = star Raw_html.rt 1875 1875 - let rp = star Raw_html.rp 1876 1876 - let ruby = star Raw_html.ruby 1877 1877 - (* let of_seq = Raw_html.of_seq *) 1878 1878 - let tot = Raw_html.tot 1879 1879 - (* let totl = Raw_html.totl *) 1880 1880 - let toelt = Raw_html.toelt 1881 1881 - (* let toeltl = Raw_html.toeltl *) 1882 1882 - let doc_toelt = Raw_html.doc_toelt 1883 1883 - let to_xmlattribs = Raw_html.to_xmlattribs 1884 1884 - let to_attrib = Raw_html.to_attrib 1885 1885 - end 1886 1886 - 1887 1887 - module Lwdom = struct 1888 1888 - type 'a elt = 'a Lwd_seq.t Lwd.t 1889 1889 - 1890 1890 - let elt x = Lwd.pure (Lwd_seq.element x) 1891 1891 - let attr x : _ attr = Lwd.pure (Some x) 1892 1892 - let rattr x : _ attr = Lwd.map ~f:some x 1893 1893 - 1894 1894 - (*let to_fragment (elts : _ node elt) = 1895 1895 - let fragment = Dom_html.document##createDocumentFragment in 1896 1896 - Lwd.map' (update_children fragment elts) (fun () -> fragment)*) 1897 1897 - 1898 1898 - let children : _ elt list -> _ elt = function 1899 1899 - | [] -> empty 1900 1900 - | [x] -> x 1901 1901 - | [x; y] -> Lwd.map2 ~f:Lwd_seq.concat x y 1902 1902 - | xs -> Lwd_utils.reduce Lwd_seq.lwd_monoid xs 1903 1903 - 1904 1904 - let children_array : _ elt array -> _ elt = function 1905 1905 - | [||] -> empty 1906 1906 - | [|x|] -> x 1907 1907 - | [|x; y|] -> Lwd.map2 ~f:Lwd_seq.concat x y 1908 1908 - | xs -> Lwd_seq.bind (Lwd.pure (Lwd_seq.of_array xs)) (fun x -> x) 1909 1909 - 1910 1910 - let to_node x = x 1911 1911 - end

-836

forks/lwd/lib/tyxml-lwd/tyxml_lwd.mli

reviewed

··· 1 1 - open Js_of_ocaml 2 2 - 3 3 - type raw_node = Dom.node Js.t 4 4 - type 'a live = 'a Lwd_seq.t Lwd.t 5 5 - type 'a attr = 'a option Lwd.t 6 6 - 7 7 - (** {1 TyXML compatible representation of XML documents} *) 8 8 - 9 9 - module Xml : Xml_sigs.T 10 10 - with type 'a W.t = 'a Lwd.t 11 11 - and type (-'a, 'b) W.ft = 'a -> 'b 12 12 - and type 'a W.tlist = 'a Lwd.t list 13 13 - and type uri = string 14 14 - and type elt = raw_node live 15 15 - and type event_handler = (Dom_html.event Js.t -> bool) attr 16 16 - and type mouse_event_handler = (Dom_html.mouseEvent Js.t -> bool) attr 17 17 - and type keyboard_event_handler = (Dom_html.keyboardEvent Js.t -> bool) attr 18 18 - and type touch_event_handler = (Dom_html.touchEvent Js.t -> bool) attr 19 19 - 20 20 - (** {1 TyXML produced Svg and Html} *) 21 21 - 22 22 - type +'a node = private raw_node 23 23 - 24 24 - open Svg_types 25 25 - module Svg : sig 26 26 - type +'a elt = 'a node live 27 27 - type doc = [`Svg] elt 28 28 - type +'a attrib 29 29 - 30 30 - module Xml = Xml 31 31 - type ('a, 'b) nullary = ?a:'a attrib list -> unit -> 'b elt 32 32 - type ('a, 'b, 'c) unary = ?a:'a attrib list -> 'b elt -> 'c elt 33 33 - type ('a, 'b, 'c) star = ?a:'a attrib list -> 'b elt list -> 'c elt 34 34 - 35 35 - module Info : Xml_sigs.Info 36 36 - type uri = string 37 37 - val string_of_uri : uri -> string 38 38 - val uri_of_string : string -> uri 39 39 - 40 40 - val a_x : Unit.length Lwd.t -> [>`X] attrib 41 41 - val a_y : Unit.length Lwd.t -> [>`Y] attrib 42 42 - val a_width : Unit.length Lwd.t -> [>`Width] attrib 43 43 - val a_height : Unit.length Lwd.t -> [>`Height] attrib 44 44 - val a_preserveAspectRatio : uri Lwd.t -> [>`PreserveAspectRatio] attrib 45 45 - val a_zoomAndPan : [<`Disable|`Magnify] Lwd.t -> [>`ZoomAndSpan] attrib 46 46 - val a_href : uri Lwd.t -> [>`Xlink_href] attrib 47 47 - val a_requiredExtensions : spacestrings Lwd.t -> [>`RequiredExtension] attrib 48 48 - val a_systemLanguage : 49 49 - commastrings Lwd.t -> [>`SystemLanguage] attrib 50 50 - val a_externalRessourcesRequired : 51 51 - bool Lwd.t -> [>`ExternalRessourcesRequired] attrib 52 52 - val a_id : uri Lwd.t -> [>`Id] attrib 53 53 - val a_user_data : uri -> uri Lwd.t -> [>`User_data] attrib 54 54 - val a_xml_lang : uri Lwd.t -> [>`Xml_Lang] attrib 55 55 - val a_type : uri Lwd.t -> [>`Type] attrib 56 56 - val a_media : commastrings Lwd.t -> [>`Media] attrib 57 57 - val a_class : spacestrings Lwd.t -> [>`Class] attrib 58 58 - val a_style : uri Lwd.t -> [>`Style] attrib 59 59 - val a_transform : transforms Lwd.t -> [>`Transform] attrib 60 60 - val a_viewBox : fourfloats Lwd.t -> [>`ViewBox] attrib 61 61 - val a_d : uri Lwd.t -> [>`D] attrib 62 62 - val a_pathLength : float Lwd.t -> [>`PathLength] attrib 63 63 - val a_rx : Unit.length Lwd.t -> [>`Rx] attrib 64 64 - val a_ry : Unit.length Lwd.t -> [>`Ry] attrib 65 65 - val a_cx : Unit.length Lwd.t -> [>`Cx] attrib 66 66 - val a_cy : Unit.length Lwd.t -> [>`Cy] attrib 67 67 - val a_r : Unit.length Lwd.t -> [>`R] attrib 68 68 - val a_x1 : Unit.length Lwd.t -> [>`X1] attrib 69 69 - val a_y1 : Unit.length Lwd.t -> [>`Y1] attrib 70 70 - val a_x2 : Unit.length Lwd.t -> [>`X2] attrib 71 71 - val a_y2 : Unit.length Lwd.t -> [>`Y2] attrib 72 72 - val a_points : coords Lwd.t -> [>`Points] attrib 73 73 - val a_x_list : lengths Lwd.t -> [>`X_list] attrib 74 74 - val a_y_list : lengths Lwd.t -> [>`Y_list] attrib 75 75 - val a_dx : float Lwd.t -> [>`Dx] attrib 76 76 - val a_dy : float Lwd.t -> [>`Dy] attrib 77 77 - val a_dx_list : lengths Lwd.t -> [>`Dx_list] attrib 78 78 - val a_dy_list : lengths Lwd.t -> [>`Dy_list] attrib 79 79 - val a_lengthAdjust : 80 80 - [<`Spacing|`SpacingAndGlyphs] Lwd.t -> [>`LengthAdjust] attrib 81 81 - val a_textLength : Unit.length Lwd.t -> [>`TextLength] attrib 82 82 - val a_text_anchor : 83 83 - [<`End|`Inherit|`Middle|`Start] Lwd.t -> [>`Text_Anchor] attrib 84 84 - val a_text_decoration : 85 85 - [<`Blink|`Inherit|`Line_through|`None|`Overline|`Underline] Lwd.t -> 86 86 - [>`Text_Decoration] attrib 87 87 - val a_text_rendering : 88 88 - [<`Auto|`GeometricPrecision|`Inherit 89 89 - |`OptimizeLegibility|`OptimizeSpeed] Lwd.t -> 90 90 - [>`Text_Rendering] attrib 91 91 - val a_rotate : numbers Lwd.t -> [>`Rotate] attrib 92 92 - val a_startOffset : Unit.length Lwd.t -> [>`StartOffset] attrib 93 93 - val a_method : [<`Align | `Stretch] Lwd.t -> [>`Method] attrib 94 94 - val a_spacing : [<`Auto | `Exact] Lwd.t -> [>`Spacing] attrib 95 95 - val a_glyphRef : uri Lwd.t -> [>`GlyphRef] attrib 96 96 - val a_format : uri Lwd.t -> [>`Format] attrib 97 97 - val a_markerUnits : 98 98 - [<`StrokeWidth | `UserSpaceOnUse] Lwd.t -> [>`MarkerUnits] attrib 99 99 - val a_refX : Unit.length Lwd.t -> [>`RefX] attrib 100 100 - val a_refY : Unit.length Lwd.t -> [>`RefY] attrib 101 101 - val a_markerWidth : Unit.length Lwd.t -> [>`MarkerWidth] attrib 102 102 - val a_markerHeight : 103 103 - Unit.length Lwd.t -> [>`MarkerHeight] attrib 104 104 - val a_orient : Unit.angle option Lwd.t -> [>`Orient] attrib 105 105 - val a_local : uri Lwd.t -> [>`Local] attrib 106 106 - val a_rendering_intent : 107 107 - [<`Absolute_colorimetric|`Auto|`Perceptual 108 108 - |`Relative_colorimetric|`Saturation] Lwd.t -> 109 109 - [>`Rendering_Indent] attrib 110 110 - val a_gradientUnits : 111 111 - [<`ObjectBoundingBox|`UserSpaceOnUse] Lwd.t -> [`GradientUnits] attrib 112 112 - val a_gradientTransform : transforms Lwd.t -> [>`Gradient_Transform] attrib 113 113 - val a_spreadMethod : [<`Pad|`Reflect|`Repeat] Lwd.t -> [>`SpreadMethod] attrib 114 114 - val a_fx : Unit.length Lwd.t -> [>`Fx] attrib 115 115 - val a_fy : Unit.length Lwd.t -> [>`Fy] attrib 116 116 - val a_offset : [<`Number of float | `Percentage of float] Lwd.t -> 117 117 - [>`Offset] attrib 118 118 - val a_patternUnits : [<`ObjectBoundingBox|`UserSpaceOnUse] Lwd.t -> 119 119 - [>`PatternUnits] attrib 120 120 - val a_patternContentUnits : [<`ObjectBoundingBox|`UserSpaceOnUse] Lwd.t -> 121 121 - [>`PatternContentUnits] attrib 122 122 - val a_patternTransform : transforms Lwd.t -> [>`PatternTransform] attrib 123 123 - val a_clipPathUnits : [<`ObjectBoundingBox|`UserSpaceOnUse] Lwd.t -> 124 124 - [>`ClipPathUnits] attrib 125 125 - val a_maskUnits : [<`ObjectBoundingBox|`UserSpaceOnUse] Lwd.t -> 126 126 - [>`MaskUnits] attrib 127 127 - val a_maskContentUnits : [<`ObjectBoundingBox|`UserSpaceOnUse] Lwd.t -> 128 128 - [>`MaskContentUnits] attrib 129 129 - val a_primitiveUnits : [<`ObjectBoundingBox|`UserSpaceOnUse] Lwd.t -> 130 130 - [>`PrimitiveUnits] attrib 131 131 - val a_filterRes : number_optional_number Lwd.t -> [>`FilterResUnits] attrib 132 132 - val a_result : uri Lwd.t -> [>`Result] attrib 133 133 - val a_in : 134 134 - [<`BackgroundAlpha|`BackgroundImage|`FillPaint|`Ref of uri 135 135 - |`SourceAlpha|`SourceGraphic|`StrokePaint] Lwd.t -> [>`In] attrib 136 136 - val a_in2 : 137 137 - [<`BackgroundAlpha|`BackgroundImage|`FillPaint|`Ref of uri 138 138 - |`SourceAlpha|`SourceGraphic|`StrokePaint] Lwd.t -> [>`In2] attrib 139 139 - val a_azimuth : float Lwd.t -> [>`Azimuth] attrib 140 140 - val a_elevation : float Lwd.t -> [>`Elevation] attrib 141 141 - val a_pointsAtX : float Lwd.t -> [>`PointsAtX] attrib 142 142 - val a_pointsAtY : float Lwd.t -> [>`PointsAtY] attrib 143 143 - val a_pointsAtZ : float Lwd.t -> [>`PointsAtZ] attrib 144 144 - val a_specularExponent : float Lwd.t -> [>`SpecularExponent] attrib 145 145 - val a_specularConstant : float Lwd.t -> [>`SpecularConstant] attrib 146 146 - val a_limitingConeAngle : float Lwd.t -> [>`LimitingConeAngle] attrib 147 147 - val a_mode : 148 148 - [<`Darken|`Lighten|`Multiply|`Normal|`Screen] Lwd.t -> [>`Mode] attrib 149 149 - val a_feColorMatrix_type : 150 150 - [<`HueRotate|`LuminanceToAlpha|`Matrix|`Saturate] Lwd.t -> 151 151 - [>`Typefecolor] attrib 152 152 - val a_values : numbers Lwd.t -> [>`Values] attrib 153 153 - val a_transfer_type : [<`Discrete|`Gamma|`Identity|`Linear|`Table] Lwd.t -> 154 154 - [>`Type_transfert] attrib 155 155 - val a_tableValues : numbers Lwd.t -> [>`TableValues] attrib 156 156 - val a_intercept : float Lwd.t -> [>`Intercept] attrib 157 157 - val a_amplitude : float Lwd.t -> [>`Amplitude] attrib 158 158 - val a_exponent : float Lwd.t -> [>`Exponent] attrib 159 159 - val a_transfer_offset : float Lwd.t -> [>`Offset_transfer] attrib 160 160 - val a_feComposite_operator : [<`Arithmetic|`Atop|`In|`Out|`Over|`Xor] Lwd.t -> 161 161 - [>`OperatorComposite] attrib 162 162 - val a_k1 : float Lwd.t -> [>`K1] attrib 163 163 - val a_k2 : float Lwd.t -> [>`K2] attrib 164 164 - val a_k3 : float Lwd.t -> [>`K3] attrib 165 165 - val a_k4 : float Lwd.t -> [>`K4] attrib 166 166 - val a_order : number_optional_number Lwd.t -> [>`Order] attrib 167 167 - val a_kernelMatrix : numbers Lwd.t -> [>`KernelMatrix] attrib 168 168 - val a_divisor : float Lwd.t -> [>`Divisor] attrib 169 169 - val a_bias : float Lwd.t -> [>`Bias] attrib 170 170 - val a_kernelUnitLength : 171 171 - number_optional_number Lwd.t -> [>`KernelUnitLength] attrib 172 172 - val a_targetX : int Lwd.t -> [>`TargetX] attrib 173 173 - val a_targetY : int Lwd.t -> [>`TargetY] attrib 174 174 - val a_edgeMode : [<`Duplicate|`None|`Wrap] Lwd.t -> [>`TargetY] attrib 175 175 - val a_preserveAlpha : bool Lwd.t -> [>`TargetY] attrib 176 176 - val a_surfaceScale : float Lwd.t -> [>`SurfaceScale] attrib 177 177 - val a_diffuseConstant : float Lwd.t -> [>`DiffuseConstant] attrib 178 178 - val a_scale : float Lwd.t -> [>`Scale] attrib 179 179 - val a_xChannelSelector : [<`A|`B|`G|`R] Lwd.t -> [>`XChannelSelector] attrib 180 180 - val a_yChannelSelector : [<`A|`B|`G|`R] Lwd.t -> [>`YChannelSelector] attrib 181 181 - val a_stdDeviation : number_optional_number Lwd.t -> [>`StdDeviation] attrib 182 182 - val a_feMorphology_operator : [<`Dilate|`Erode] Lwd.t -> [>`OperatorMorphology] attrib 183 183 - val a_radius : number_optional_number Lwd.t -> [>`Radius] attrib 184 184 - val a_baseFrenquency : number_optional_number Lwd.t -> [>`BaseFrequency] attrib 185 185 - val a_numOctaves : int Lwd.t -> [>`NumOctaves] attrib 186 186 - val a_seed : float Lwd.t -> [>`Seed] attrib 187 187 - val a_stitchTiles : [<`NoStitch|`Stitch] Lwd.t -> [>`StitchTiles] attrib 188 188 - val a_feTurbulence_type : [<`FractalNoise|`Turbulence] Lwd.t -> [>`TypeStitch] attrib 189 189 - val a_target : uri Lwd.t -> [>`Xlink_target] attrib 190 190 - val a_attributeName : uri Lwd.t -> [>`AttributeName] attrib 191 191 - val a_attributeType : [<`Auto|`CSS|`XML] Lwd.t -> [>`AttributeType] attrib 192 192 - val a_begin : uri Lwd.t -> [>`Begin] attrib 193 193 - val a_dur : uri Lwd.t -> [>`Dur] attrib 194 194 - val a_min : uri Lwd.t -> [>`Min] attrib 195 195 - val a_max : uri Lwd.t -> [>`Max] attrib 196 196 - val a_restart : [<`Always|`Never|`WhenNotActive] Lwd.t -> [>`Restart] attrib 197 197 - val a_repeatCount : uri Lwd.t -> [>`RepeatCount] attrib 198 198 - val a_repeatDur : uri Lwd.t -> [>`RepeatDur] attrib 199 199 - val a_fill : paint Lwd.t -> [>`Fill] attrib 200 200 - val a_animation_fill : [<`Freeze|`Remove] Lwd.t -> [>`Fill_Animation] attrib 201 201 - val a_calcMode : [<`Discrete|`Linear|`Paced|`Spline] Lwd.t -> [>`CalcMode] attrib 202 202 - val a_animation_values : strings Lwd.t -> [>`Valuesanim] attrib 203 203 - val a_keyTimes : strings Lwd.t -> [>`KeyTimes] attrib 204 204 - val a_keySplines : strings Lwd.t -> [>`KeySplines] attrib 205 205 - val a_from : uri Lwd.t -> [>`From] attrib 206 206 - val a_to : uri Lwd.t -> [>`To] attrib 207 207 - val a_by : uri Lwd.t -> [>`By] attrib 208 208 - val a_additive : [<`Replace|`Sum] Lwd.t -> [>`Additive] attrib 209 209 - val a_accumulate : [<`None|`Sum] Lwd.t -> [>`Accumulate] attrib 210 210 - val a_keyPoints : numbers_semicolon Lwd.t -> [>`KeyPoints] attrib 211 211 - val a_path : uri Lwd.t -> [>`Path] attrib 212 212 - val a_animateTransform_type : 213 213 - [`Rotate|`Scale|`SkewX|`SkewY|`Translate] Lwd.t -> 214 214 - [`Typeanimatetransform] attrib 215 215 - val a_horiz_origin_x : float Lwd.t -> [>`HorizOriginX] attrib 216 216 - val a_horiz_origin_y : float Lwd.t -> [>`HorizOriginY] attrib 217 217 - val a_horiz_adv_x : float Lwd.t -> [>`HorizAdvX] attrib 218 218 - val a_vert_origin_x : float Lwd.t -> [>`VertOriginX] attrib 219 219 - val a_vert_origin_y : float Lwd.t -> [>`VertOriginY] attrib 220 220 - val a_vert_adv_y : float Lwd.t -> [>`VertAdvY] attrib 221 221 - val a_unicode : uri Lwd.t -> [>`Unicode] attrib 222 222 - val a_glyph_name : uri Lwd.t -> [>`glyphname] attrib 223 223 - val a_orientation : [<`H | `V] Lwd.t -> [>`Orientation] attrib 224 224 - val a_arabic_form : [<`Initial|`Isolated|`Medial|`Terminal] Lwd.t -> 225 225 - [>`Arabicform] attrib 226 226 - val a_lang : uri Lwd.t -> [>`Lang] attrib 227 227 - val a_u1 : uri Lwd.t -> [>`U1] attrib 228 228 - val a_u2 : uri Lwd.t -> [>`U2] attrib 229 229 - val a_g1 : uri Lwd.t -> [>`G1] attrib 230 230 - val a_g2 : uri Lwd.t -> [>`G2] attrib 231 231 - val a_k : uri Lwd.t -> [>`K] attrib 232 232 - val a_font_family : uri Lwd.t -> [>`Font_Family] attrib 233 233 - val a_font_style : uri Lwd.t -> [>`Font_Style] attrib 234 234 - val a_font_variant : uri Lwd.t -> [>`Font_Variant] attrib 235 235 - val a_font_weight : uri Lwd.t -> [>`Font_Weight] attrib 236 236 - val a_font_stretch : uri Lwd.t -> [>`Font_Stretch] attrib 237 237 - val a_font_size : uri Lwd.t -> [>`Font_Size] attrib 238 238 - val a_unicode_range : uri Lwd.t -> [>`UnicodeRange] attrib 239 239 - val a_units_per_em : uri Lwd.t -> [>`UnitsPerEm] attrib 240 240 - val a_stemv : float Lwd.t -> [>`Stemv] attrib 241 241 - val a_stemh : float Lwd.t -> [>`Stemh] attrib 242 242 - val a_slope : float Lwd.t -> [>`Slope] attrib 243 243 - val a_cap_height : float Lwd.t -> [>`CapHeight] attrib 244 244 - val a_x_height : float Lwd.t -> [>`XHeight] attrib 245 245 - val a_accent_height : float Lwd.t -> [>`AccentHeight] attrib 246 246 - val a_ascent : float Lwd.t -> [>`Ascent] attrib 247 247 - val a_widths : uri Lwd.t -> [>`Widths] attrib 248 248 - val a_bbox : uri Lwd.t -> [>`Bbox] attrib 249 249 - val a_ideographic : float Lwd.t -> [>`Ideographic] attrib 250 250 - val a_alphabetic : float Lwd.t -> [>`Alphabetic] attrib 251 251 - val a_mathematical : float Lwd.t -> [>`Mathematical] attrib 252 252 - val a_hanging : float Lwd.t -> [>`Hanging] attrib 253 253 - val a_videographic : float Lwd.t -> [>`VIdeographic] attrib 254 254 - val a_v_alphabetic : float Lwd.t -> [>`VAlphabetic] attrib 255 255 - val a_v_mathematical : float Lwd.t -> [>`VMathematical] attrib 256 256 - val a_v_hanging : float Lwd.t -> [>`VHanging] attrib 257 257 - val a_underline_position : float Lwd.t -> [>`UnderlinePosition] attrib 258 258 - val a_underline_thickness : float Lwd.t -> [>`UnderlineThickness] attrib 259 259 - val a_strikethrough_position : float Lwd.t -> [>`StrikethroughPosition] attrib 260 260 - val a_strikethrough_thickness : float Lwd.t -> [>`StrikethroughThickness] attrib 261 261 - val a_overline_position : float Lwd.t -> [>`OverlinePosition] attrib 262 262 - val a_overline_thickness : float Lwd.t -> [>`OverlineThickness] attrib 263 263 - val a_string : uri Lwd.t -> [>`String] attrib 264 264 - val a_name : uri Lwd.t -> [>`Name] attrib 265 265 - val a_alignment_baseline : 266 266 - [<`After_edge|`Alphabetic|`Auto|`Baseline|`Before_edge|`Central|`Hanging 267 267 - |`Ideographic|`Inherit|`Mathematical|`Middle 268 268 - |`Text_after_edge|`Text_before_edge] Lwd.t -> [>`Alignment_Baseline] attrib 269 269 - val a_dominant_baseline : 270 270 - [<`Alphabetic|`Auto|`Central|`Hanging|`Ideographic|`Inherit 271 271 - |`Mathematical|`Middle|`No_change|`Reset_size|`Text_after_edge 272 272 - |`Text_before_edge|`Use_script] Lwd.t -> [>`Dominant_Baseline] attrib 273 273 - val a_stop_color : uri Lwd.t -> [>`Stop_Color] attrib 274 274 - val a_stop_opacity : float Lwd.t -> [>`Stop_Opacity] attrib 275 275 - val a_stroke : paint Lwd.t -> [>`Stroke] attrib 276 276 - val a_stroke_width : Unit.length Lwd.t -> [>`Stroke_Width] attrib 277 277 - val a_stroke_linecap : [<`Butt|`Round|`Square] Lwd.t -> [>`Stroke_Linecap] attrib 278 278 - val a_stroke_linejoin : [<`Bever|`Miter|`Round] Lwd.t -> [>`Stroke_Linejoin] attrib 279 279 - val a_stroke_miterlimit : float Lwd.t -> [>`Stroke_Miterlimit] attrib 280 280 - val a_stroke_dasharray : Unit.length list Lwd.t -> [>`Stroke_Dasharray] attrib 281 281 - val a_stroke_dashoffset : Unit.length Lwd.t -> [>`Stroke_Dashoffset] attrib 282 282 - val a_stroke_opacity : float Lwd.t -> [>`Stroke_Opacity] attrib 283 283 - val a_onabort : Xml.event_handler -> [>`OnAbort] attrib 284 284 - val a_onactivate : Xml.event_handler -> [>`OnActivate] attrib 285 285 - val a_onbegin : Xml.event_handler -> [>`OnBegin] attrib 286 286 - val a_onend : Xml.event_handler -> [>`OnEnd] attrib 287 287 - val a_onerror : Xml.event_handler -> [>`OnError] attrib 288 288 - val a_onfocusin : Xml.event_handler -> [>`OnFocusIn] attrib 289 289 - val a_onfocusout : Xml.event_handler -> [>`OnFocusOut] attrib 290 290 - val a_onrepeat : Xml.event_handler -> [>`OnRepeat] attrib 291 291 - val a_onresize : Xml.event_handler -> [>`OnResize] attrib 292 292 - val a_onscroll : Xml.event_handler -> [>`OnScroll] attrib 293 293 - val a_onunload : Xml.event_handler -> [>`OnUnload] attrib 294 294 - val a_onzoom : Xml.event_handler -> [>`OnZoom] attrib 295 295 - val a_onclick : Xml.mouse_event_handler -> [>`OnClick] attrib 296 296 - val a_onmousedown : Xml.mouse_event_handler -> [>`OnMouseDown] attrib 297 297 - val a_onmouseup : Xml.mouse_event_handler -> [>`OnMouseUp] attrib 298 298 - val a_onmouseover : Xml.mouse_event_handler -> [>`OnMouseOver] attrib 299 299 - val a_onmouseout : Xml.mouse_event_handler -> [>`OnMouseOut] attrib 300 300 - val a_onmousemove : Xml.mouse_event_handler -> [>`OnMouseMove] attrib 301 301 - val a_ontouchstart : Xml.touch_event_handler -> [>`OnTouchStart] attrib 302 302 - val a_ontouchend : Xml.touch_event_handler -> [>`OnTouchEnd] attrib 303 303 - val a_ontouchmove : Xml.touch_event_handler -> [>`OnTouchMove] attrib 304 304 - val a_ontouchcancel : Xml.touch_event_handler -> [>`OnTouchCancel] attrib 305 305 - val txt : uri Lwd.t -> [>txt] elt 306 306 - val svg : ([<svg_attr], [<svg_content], [>svg]) star 307 307 - val g : ([<g_attr], [<g_content], [>g]) star 308 308 - val defs : ([<defs_attr], [<defs_content], [>defs]) star 309 309 - val desc : ([<desc_attr], [<desc_content], [>desc]) unary 310 310 - val title : ([<desc_attr], [<title_content], [>title]) unary 311 311 - val symbol : ([<symbol_attr], [<symbol_content], [>symbol]) star 312 312 - val use : ([<use_attr], [<use_content], [>use]) star 313 313 - val image : ([<image_attr], [<image_content], [>image]) star 314 314 - val switch : ([<switch_attr], [<switch_content], [>switch]) star 315 315 - val style : ([<style_attr], [<style_content], [>style]) unary 316 316 - val path : ([<path_attr], [<path_content], [>path]) star 317 317 - val rect : ([<rect_attr], [<rect_content], [>rect]) star 318 318 - val circle : ([<circle_attr], [<circle_content], [>circle]) star 319 319 - val ellipse : ([<ellipse_attr], [<ellipse_content], [>ellipse]) star 320 320 - val line : ([<line_attr], [<line_content], [>line]) star 321 321 - val polyline : ([<polyline_attr], [<polyline_content], [>polyline]) star 322 322 - val polygon : ([<polygon_attr], [<polygon_content], [>polygon]) star 323 323 - val text : ([<text_attr], [<text_content], [>text]) star 324 324 - val tspan : ([<tspan_attr], [<tspan_content], [>tspan]) star 325 325 - val textPath : ([<textpath_attr], [<textpath_content], [>textpath]) star 326 326 - val marker : ([<marker_attr], [<marker_content], [>marker]) star 327 327 - val linearGradient : 328 328 - ([<lineargradient_attr], [<lineargradient_content], [>lineargradient]) star 329 329 - val radialGradient : 330 330 - ([<radialgradient_attr], [<radialgradient_content], [>radialgradient]) star 331 331 - val stop : ([<stop_attr], [<stop_content], [>stop]) star 332 332 - val pattern : ([<pattern_attr], [<pattern_content], [>pattern]) star 333 333 - val clipPath : ([<clippath_attr], [<clippath_content], [>clippath]) star 334 334 - val filter : ([<filter_attr], [<filter_content], [>filter]) star 335 335 - val feDistantLight : 336 336 - ([<fedistantlight_attr], [<fedistantlight_content], [>fedistantlight]) star 337 337 - val fePointLight : 338 338 - ([<fepointlight_attr], [<fepointlight_content], [>fepointlight]) star 339 339 - val feSpotLight : 340 340 - ([<fespotlight_attr], [<fespotlight_content], [>fespotlight]) star 341 341 - val feBlend : ([<feblend_attr], [<feblend_content], [>feblend]) star 342 342 - val feColorMatrix : 343 343 - ([<fecolormatrix_attr], [<fecolormatrix_content], [>fecolormatrix]) star 344 344 - val feComponentTransfer : 345 345 - ([<fecomponenttransfer_attr], [<fecomponenttransfer_content], 346 346 - [>fecomponenttransfer]) star 347 347 - val feFuncA : ([<fefunca_attr], [<fefunca_content], [>fefunca]) star 348 348 - val feFuncG : ([<fefuncg_attr], [<fefuncg_content], [>fefuncg]) star 349 349 - val feFuncB : ([<fefuncb_attr], [<fefuncb_content], [>fefuncb]) star 350 350 - val feFuncR : ([<fefuncr_attr], [<fefuncr_content], [>fefuncr]) star 351 351 - val feComposite : 352 352 - ([<fecomposite_attr], [<fecomposite_content], [>fecomposite]) star 353 353 - val feConvolveMatrix : 354 354 - ([<feconvolvematrix_attr], [<feconvolvematrix_content], 355 355 - [>feconvolvematrix]) star 356 356 - val feDiffuseLighting : 357 357 - ([<fediffuselighting_attr], [<fediffuselighting_content], 358 358 - [>fediffuselighting]) star 359 359 - val feDisplacementMap : 360 360 - ([<fedisplacementmap_attr], [<fedisplacementmap_content], 361 361 - [>fedisplacementmap]) star 362 362 - val feFlood : ([<feflood_attr], [<feflood_content], [>feflood]) star 363 363 - val feGaussianBlur : 364 364 - ([<fegaussianblur_attr], [<fegaussianblur_content], [>fegaussianblur]) star 365 365 - val feImage : ([<feimage_attr], [<feimage_content], [>feimage]) star 366 366 - val feMerge : ([<femerge_attr], [<femerge_content], [>femerge]) star 367 367 - val feMorphology : 368 368 - ([<femorphology_attr], [<femorphology_content], [>femorphology]) star 369 369 - val feOffset : 370 370 - ([<feoffset_attr], [<feoffset_content], [>feoffset]) star 371 371 - val feSpecularLighting : 372 372 - ([<fespecularlighting_attr], [<fespecularlighting_content], 373 373 - [>fespecularlighting]) star 374 374 - val feTile : ([<fetile_attr], [<fetile_content], [>fetile]) star 375 375 - val feTurbulence : 376 376 - ([<feturbulence_attr], [<feturbulence_content], [>feturbulence]) star 377 377 - val cursor : 378 378 - ([<cursor_attr], [<descriptive_element], [>cursor]) star 379 379 - val a : ([<a_attr], [<a_content], [>a]) star 380 380 - val view : ([<view_attr], [<descriptive_element], [>view]) star 381 381 - val script : ([<script_attr], [<script_content], [>script]) unary 382 382 - val animate : ([<animate_attr], [<descriptive_element], [>animate]) star 383 383 - val animation : 384 384 - ([<animation_attr], [<descriptive_element], [>animation]) star 385 385 - [@@ocaml.warning "-3"] 386 386 - val set : ([<set_attr], [<descriptive_element], [>set]) star 387 387 - val animateMotion : 388 388 - ([<animatemotion_attr], [<animatemotion_content], [>animatemotion]) star 389 389 - val mpath : 390 390 - ([<mpath_attr], [<descriptive_element], [>mpath]) star 391 391 - val animateColor : 392 392 - ([<animatecolor_attr], [<descriptive_element], [>animatecolor]) star 393 393 - val animateTransform : 394 394 - ([<animatetransform_attr], [<descriptive_element], 395 395 - [>animatetransform]) star 396 396 - val metadata : ?a:metadata_attr attrib list -> Xml.elt list -> [>metadata] elt 397 397 - val foreignObject : ?a:foreignobject_attr attrib list -> Xml.elt list -> [>foreignobject] elt 398 398 - 399 399 - (* val pcdata : string Lwd.t -> [>txt] elt *) 400 400 - (* val of_seq : Xml_stream.signal Seq.t -> 'a elt list *) 401 401 - val tot : Xml.elt -> 'a elt 402 402 - (* val totl : Xml.elt list -> 'a elt list *) 403 403 - val toelt : 'a elt -> Xml.elt 404 404 - (* val toeltl : 'a elt list -> Xml.elt list *) 405 405 - val doc_toelt : doc -> Xml.elt 406 406 - val to_xmlattribs : 'a attrib list -> Xml.attrib list 407 407 - val to_attrib : Xml.attrib -> 'a attrib 408 408 - end 409 409 - 410 410 - open Html_types 411 411 - module Html : sig 412 412 - type 'a elt = 'a node live 413 413 - type doc = html elt 414 414 - type +'a attrib 415 415 - type ('a, 'b) nullary = ?a:'a attrib list -> unit -> 'b elt 416 416 - type ('a, 'b, 'c) unary = ?a:'a attrib list -> 'b elt -> 'c elt 417 417 - type ('a, 'b, 'c) star = ?a:'a attrib list -> 'b elt list -> 'c elt 418 418 - module Info : Xml_sigs.Info 419 419 - 420 420 - val string_of_uri : Xml.uri -> string 421 421 - val uri_of_string : string -> Xml.uri 422 422 - val a_class : nmtokens Lwd.t -> [>`Class] attrib 423 423 - val a_user_data : string -> string Lwd.t -> [>`User_data] attrib 424 424 - val a_id : string Lwd.t -> [>`Id] attrib 425 425 - val a_title : string Lwd.t -> [>`Title] attrib 426 426 - val a_xml_lang : string Lwd.t -> [>`XML_lang] attrib 427 427 - val a_lang : string Lwd.t -> [>`Lang] attrib 428 428 - val a_onabort : Xml.event_handler -> [>`OnAbort] attrib 429 429 - val a_onafterprint : Xml.event_handler -> [>`OnAfterPrint] attrib 430 430 - val a_onbeforeprint : Xml.event_handler -> [>`OnBeforePrint] attrib 431 431 - val a_onbeforeunload : Xml.event_handler -> [>`OnBeforeUnload] attrib 432 432 - val a_onblur : Xml.event_handler -> [>`OnBlur] attrib 433 433 - val a_oncanplay : Xml.event_handler -> [>`OnCanPlay] attrib 434 434 - val a_oncanplaythrough : Xml.event_handler -> [>`OnCanPlayThrough] attrib 435 435 - val a_onchange : Xml.event_handler -> [>`OnChange] attrib 436 436 - val a_ondurationchange : Xml.event_handler -> [>`OnDurationChange] attrib 437 437 - val a_onemptied : Xml.event_handler -> [>`OnEmptied] attrib 438 438 - val a_onended : Xml.event_handler -> [>`OnEnded] attrib 439 439 - val a_onerror : Xml.event_handler -> [>`OnError] attrib 440 440 - val a_onfocus : Xml.event_handler -> [>`OnFocus] attrib 441 441 - val a_onformchange : Xml.event_handler -> [>`OnFormChange] attrib 442 442 - val a_onforminput : Xml.event_handler -> [>`OnFormInput] attrib 443 443 - val a_onhashchange : Xml.event_handler -> [>`OnHashChange] attrib 444 444 - val a_oninput : Xml.event_handler -> [>`OnInput] attrib 445 445 - val a_oninvalid : Xml.event_handler -> [>`OnInvalid] attrib 446 446 - val a_onmousewheel : Xml.event_handler -> [>`OnMouseWheel] attrib 447 447 - val a_onoffline : Xml.event_handler -> [>`OnOffLine] attrib 448 448 - val a_ononline : Xml.event_handler -> [>`OnOnLine] attrib 449 449 - val a_onpause : Xml.event_handler -> [>`OnPause] attrib 450 450 - val a_onplay : Xml.event_handler -> [>`OnPlay] attrib 451 451 - val a_onplaying : Xml.event_handler -> [>`OnPlaying] attrib 452 452 - val a_onpagehide : Xml.event_handler -> [>`OnPageHide] attrib 453 453 - val a_onpageshow : Xml.event_handler -> [>`OnPageShow] attrib 454 454 - val a_onpopstate : Xml.event_handler -> [>`OnPopState] attrib 455 455 - val a_onprogress : Xml.event_handler -> [>`OnProgress] attrib 456 456 - val a_onratechange : Xml.event_handler -> [>`OnRateChange] attrib 457 457 - val a_onreadystatechange : Xml.event_handler -> [>`OnReadyStateChange] attrib 458 458 - val a_onredo : Xml.event_handler -> [>`OnRedo] attrib 459 459 - val a_onresize : Xml.event_handler -> [>`OnResize] attrib 460 460 - val a_onscroll : Xml.event_handler -> [>`OnScroll] attrib 461 461 - val a_onseeked : Xml.event_handler -> [>`OnSeeked] attrib 462 462 - val a_onseeking : Xml.event_handler -> [>`OnSeeking] attrib 463 463 - val a_onselect : Xml.event_handler -> [>`OnSelect] attrib 464 464 - val a_onshow : Xml.event_handler -> [>`OnShow] attrib 465 465 - val a_onstalled : Xml.event_handler -> [>`OnStalled] attrib 466 466 - val a_onstorage : Xml.event_handler -> [>`OnStorage] attrib 467 467 - val a_onsubmit : Xml.event_handler -> [>`OnSubmit] attrib 468 468 - val a_onsuspend : Xml.event_handler -> [>`OnSuspend] attrib 469 469 - val a_ontimeupdate : Xml.event_handler -> [>`OnTimeUpdate] attrib 470 470 - val a_onundo : Xml.event_handler -> [>`OnUndo] attrib 471 471 - val a_onunload : Xml.event_handler -> [>`OnUnload] attrib 472 472 - val a_onvolumechange : Xml.event_handler -> [>`OnVolumeChange] attrib 473 473 - val a_onwaiting : Xml.event_handler -> [>`OnWaiting] attrib 474 474 - val a_onload : Xml.event_handler -> [>`OnLoad] attrib 475 475 - val a_onloadeddata : Xml.event_handler -> [>`OnLoadedData] attrib 476 476 - val a_onloadedmetadata : Xml.event_handler -> [>`OnLoadedMetaData] attrib 477 477 - val a_onloadstart : Xml.event_handler -> [>`OnLoadStart] attrib 478 478 - val a_onmessage : Xml.event_handler -> [>`OnMessage] attrib 479 479 - val a_onclick : Xml.mouse_event_handler -> [>`OnClick] attrib 480 480 - val a_oncontextmenu : Xml.mouse_event_handler -> [>`OnContextMenu] attrib 481 481 - val a_ondblclick : Xml.mouse_event_handler -> [>`OnDblClick] attrib 482 482 - val a_ondrag : Xml.mouse_event_handler -> [>`OnDrag] attrib 483 483 - val a_ondragend : Xml.mouse_event_handler -> [>`OnDragEnd] attrib 484 484 - val a_ondragenter : Xml.mouse_event_handler -> [>`OnDragEnter] attrib 485 485 - val a_ondragleave : Xml.mouse_event_handler -> [>`OnDragLeave] attrib 486 486 - val a_ondragover : Xml.mouse_event_handler -> [>`OnDragOver] attrib 487 487 - val a_ondragstart : Xml.mouse_event_handler -> [>`OnDragStart] attrib 488 488 - val a_ondrop : Xml.mouse_event_handler -> [>`OnDrop] attrib 489 489 - val a_onmousedown : Xml.mouse_event_handler -> [>`OnMouseDown] attrib 490 490 - val a_onmouseup : Xml.mouse_event_handler -> [>`OnMouseUp] attrib 491 491 - val a_onmouseover : Xml.mouse_event_handler -> [>`OnMouseOver] attrib 492 492 - val a_onmousemove : Xml.mouse_event_handler -> [>`OnMouseMove] attrib 493 493 - val a_onmouseout : Xml.mouse_event_handler -> [>`OnMouseOut] attrib 494 494 - val a_ontouchstart : Xml.touch_event_handler -> [>`OnTouchStart] attrib 495 495 - val a_ontouchend : Xml.touch_event_handler -> [>`OnTouchEnd] attrib 496 496 - val a_ontouchmove : Xml.touch_event_handler -> [>`OnTouchMove] attrib 497 497 - val a_ontouchcancel : Xml.touch_event_handler -> [>`OnTouchCancel] attrib 498 498 - val a_onkeypress : Xml.keyboard_event_handler -> [>`OnKeyPress] attrib 499 499 - val a_onkeydown : Xml.keyboard_event_handler -> [>`OnKeyDown] attrib 500 500 - val a_onkeyup : Xml.keyboard_event_handler -> [>`OnKeyUp] attrib 501 501 - val a_allowfullscreen : unit -> [>`Allowfullscreen] attrib 502 502 - val a_allowpaymentrequest : unit -> [>`Allowpaymentrequest] attrib 503 503 - val a_autocomplete : autocomplete_option Lwd.t -> [>`Autocomplete] attrib 504 504 - val a_async : unit -> [>`Async] attrib 505 505 - val a_autofocus : unit -> [>`Autofocus] attrib 506 506 - val a_autoplay : unit -> [>`Autoplay] attrib 507 507 - val a_muted : unit -> [>`Muted] attrib 508 508 - val a_crossorigin : 509 509 - [<`Anonymous|`Use_credentials] Lwd.t -> [>`Crossorigin] attrib 510 510 - val a_integrity : string Lwd.t -> [>`Integrity] attrib 511 511 - val a_mediagroup : string Lwd.t -> [>`Mediagroup] attrib 512 512 - val a_challenge : string Lwd.t -> [>`Challenge] attrib 513 513 - val a_contenteditable : bool Lwd.t -> [>`Contenteditable] attrib 514 514 - val a_contextmenu : string Lwd.t -> [>`Contextmenu] attrib 515 515 - val a_controls : unit -> [>`Controls] attrib 516 516 - val a_dir : [<`Ltr|`Rtl] Lwd.t -> [>`Dir] attrib 517 517 - val a_draggable : bool Lwd.t -> [>`Draggable] attrib 518 518 - val a_form : string Lwd.t -> [>`Form] attrib 519 519 - val a_formaction : Xml.uri Lwd.t -> [>`Formaction] attrib 520 520 - val a_formenctype : string Lwd.t -> [>`Formenctype] attrib 521 521 - val a_formnovalidate : unit -> [>`Formnovalidate] attrib 522 522 - val a_formtarget : string Lwd.t -> [>`Formtarget] attrib 523 523 - val a_hidden : unit -> [>`Hidden] attrib 524 524 - val a_high : float Lwd.t -> [>`High] attrib 525 525 - val a_icon : Xml.uri Lwd.t -> [>`Icon] attrib 526 526 - val a_ismap : unit -> [>`Ismap] attrib 527 527 - val a_keytype : string Lwd.t -> [>`Keytype] attrib 528 528 - val a_list : string Lwd.t -> [>`List] attrib 529 529 - val a_loop : unit -> [>`Loop] attrib 530 530 - val a_low : float Lwd.t -> [>`High] attrib 531 531 - val a_max : float Lwd.t -> [>`Max] attrib 532 532 - val a_input_max : number_or_datetime Lwd.t -> [>`Input_Max] attrib 533 533 - val a_min : float Lwd.t -> [>`Min] attrib 534 534 - val a_input_min : number_or_datetime Lwd.t -> [>`Input_Min] attrib 535 535 - val a_inputmode : 536 536 - [<`Decimal|`Email|`None|`Numeric|`Search|`Tel|`Text|`Url] Lwd.t -> 537 537 - [>`Inputmode] attrib 538 538 - val a_novalidate : unit -> [>`Novalidate] attrib 539 539 - val a_open : unit -> [>`Open] attrib 540 540 - val a_optimum : float Lwd.t -> [>`Optimum] attrib 541 541 - val a_pattern : string Lwd.t -> [>`Pattern] attrib 542 542 - val a_placeholder : string Lwd.t -> [>`Placeholder] attrib 543 543 - val a_poster : Xml.uri Lwd.t -> [>`Poster] attrib 544 544 - val a_preload : [<`Audio|`Metadata|`None] Lwd.t -> [>`Preload] attrib 545 545 - val a_pubdate : unit -> [>`Pubdate] attrib 546 546 - val a_radiogroup : string Lwd.t -> [>`Radiogroup] attrib 547 547 - val a_referrerpolicy : referrerpolicy Lwd.t -> [>`Referrerpolicy] attrib 548 548 - val a_required : unit -> [>`Required] attrib 549 549 - val a_reversed : unit -> [>`Reversed] attrib 550 550 - val a_sandbox : [<sandbox_token] list Lwd.t -> [>`Sandbox] attrib 551 551 - val a_spellcheck : bool Lwd.t -> [>`Spellcheck] attrib 552 552 - val a_scoped : unit -> [>`Scoped] attrib 553 553 - val a_seamless : unit -> [>`Seamless] attrib 554 554 - val a_sizes : (int * int) list option Lwd.t -> [>`Sizes] attrib 555 555 - val a_span : int Lwd.t -> [>`Span] attrib 556 556 - 557 557 - type image_candidate = [ 558 558 - | `Url of Xml.uri 559 559 - | `Url_pixel of Xml.uri * float 560 560 - | `Url_width of Xml.uri * int 561 561 - ] 562 562 - val a_srcset : image_candidate list Lwd.t -> [>`Srcset] attrib 563 563 - val a_img_sizes : string list Lwd.t -> [>`Img_sizes] attrib 564 564 - val a_start : int Lwd.t -> [>`Start] attrib 565 565 - val a_step : float option Lwd.t -> [>`Step] attrib 566 566 - val a_wrap : [<`Hard | `Soft] Lwd.t -> [>`Wrap] attrib 567 567 - val a_version : string Lwd.t -> [>`Version] attrib 568 568 - val a_xmlns : [<`W3_org_1999_xhtml] Lwd.t -> [>`XMLns] attrib 569 569 - val a_manifest : Xml.uri Lwd.t -> [>`Manifest] attrib 570 570 - val a_cite : Xml.uri Lwd.t -> [>`Cite] attrib 571 571 - val a_xml_space : [<`Default | `Preserve] Lwd.t -> [>`XML_space] attrib 572 572 - val a_accesskey : char Lwd.t -> [>`Accesskey] attrib 573 573 - val a_charset : string Lwd.t -> [>`Charset] attrib 574 574 - val a_accept_charset : charsets Lwd.t -> [>`Accept_charset] attrib 575 575 - val a_accept : contenttypes Lwd.t -> [>`Accept] attrib 576 576 - val a_href : Xml.uri Lwd.t -> [>`Href] attrib 577 577 - val a_hreflang : string Lwd.t -> [>`Hreflang] attrib 578 578 - val a_download : string option Lwd.t -> [>`Download] attrib 579 579 - val a_rel : linktypes Lwd.t -> [>`Rel] attrib 580 580 - val a_tabindex : int Lwd.t -> [>`Tabindex] attrib 581 581 - val a_mime_type : string Lwd.t -> [>`Mime_type] attrib 582 582 - val a_datetime : string Lwd.t -> [>`Datetime] attrib 583 583 - val a_action : Xml.uri Lwd.t -> [>`Action] attrib 584 584 - val a_checked : unit -> [>`Checked] attrib 585 585 - val a_cols : int Lwd.t -> [>`Cols] attrib 586 586 - val a_enctype : string Lwd.t -> [>`Enctype] attrib 587 587 - val a_label_for : string Lwd.t -> [>`Label_for] attrib 588 588 - val a_output_for : idrefs Lwd.t -> [>`Output_for] attrib 589 589 - val a_maxlength : int Lwd.t -> [>`Maxlength] attrib 590 590 - val a_minlength : int Lwd.t -> [>`Minlength] attrib 591 591 - val a_method : [<`Get | `Post] Lwd.t -> [>`Method] attrib 592 592 - val a_multiple : unit -> [>`Multiple] attrib 593 593 - val a_name : string Lwd.t -> [>`Name] attrib 594 594 - val a_rows : int Lwd.t -> [>`Rows] attrib 595 595 - val a_selected : unit -> [>`Selected] attrib 596 596 - val a_size : int Lwd.t -> [>`Size] attrib 597 597 - val a_src : Xml.uri Lwd.t -> [>`Src] attrib 598 598 - val a_input_type : 599 599 - [<`Button|`Checkbox|`Color|`Date|`Datetime|`Datetime_local|`Email|`File 600 600 - |`Hidden|`Image|`Month|`Number|`Password|`Radio|`Range|`Reset|`Search 601 601 - |`Submit|`Tel|`Text|`Time|`Url|`Week] Lwd.t -> 602 602 - [>`Input_Type] attrib 603 603 - val a_text_value : string Lwd.t -> [>`Text_Value] attrib 604 604 - val a_int_value : int Lwd.t -> [>`Int_Value] attrib 605 605 - val a_value : string Lwd.t -> [>`Value] attrib 606 606 - val a_float_value : float Lwd.t -> [>`Float_Value] attrib 607 607 - val a_disabled : unit -> [>`Disabled] attrib 608 608 - val a_readonly : unit -> [>`ReadOnly] attrib 609 609 - val a_button_type : [<`Button|`Reset|`Submit] Lwd.t -> [>`Button_Type] attrib 610 610 - val a_command_type : [<`Checkbox|`Command|`Radio] Lwd.t -> [>`Command_Type] attrib 611 611 - val a_menu_type : [<`Context|`Toolbar] Lwd.t -> [>`Menu_Type] attrib 612 612 - val a_label : string Lwd.t -> [>`Label] attrib 613 613 - val a_colspan : int Lwd.t -> [>`Colspan] attrib 614 614 - val a_headers : idrefs Lwd.t -> [>`Headers] attrib 615 615 - val a_rowspan : int Lwd.t -> [>`Rowspan] attrib 616 616 - val a_alt : string Lwd.t -> [>`Alt] attrib 617 617 - val a_height : int Lwd.t -> [>`Height] attrib 618 618 - val a_width : int Lwd.t -> [>`Width] attrib 619 619 - 620 620 - type shape = [ `Circle | `Default | `Poly | `Rect] 621 621 - val a_shape : shape Lwd.t -> [>`Shape] attrib 622 622 - val a_coords : numbers Lwd.t -> [>`Coords] attrib 623 623 - val a_usemap : string Lwd.t -> [>`Usemap] attrib 624 624 - val a_data : Xml.uri Lwd.t -> [>`Data] attrib 625 625 - val a_scrolling : [<`Auto | `No | `Yes] Lwd.t -> [>`Scrolling] attrib 626 626 - val a_target : string Lwd.t -> [>`Target] attrib 627 627 - val a_content : string Lwd.t -> [>`Content] attrib 628 628 - val a_http_equiv : string Lwd.t -> [>`Http_equiv] attrib 629 629 - val a_defer : unit -> [>`Defer] attrib 630 630 - val a_media : mediadesc Lwd.t -> [>`Media] attrib 631 631 - val a_style : string Lwd.t -> [>`Style_Attr] attrib 632 632 - val a_property : string Lwd.t -> [>`Property] attrib 633 633 - val a_role : string list Lwd.t -> [>`Role] attrib 634 634 - val a_aria : string -> string list Lwd.t -> [>`Aria] attrib 635 635 - val txt : string Lwd.t -> [>txt] elt 636 636 - val html : ?a:html_attrib attrib list -> [<head] elt -> 637 637 - [<body] elt -> [>html] elt 638 638 - val head : ?a:head_attrib attrib list -> [<title] elt -> 639 639 - head_content_fun elt list -> [>head] elt 640 640 - val base : ([<base_attrib], [>base]) nullary 641 641 - val title : (noattrib, [<title_content_fun], [>title]) unary 642 642 - val body : ([<body_attrib], [<flow5], [>body]) star 643 643 - val svg : ?a:[<svg_attr] Svg.attrib list -> 644 644 - [<svg_content] Svg.elt list -> [>svg] elt 645 645 - val footer : ([<footer_attrib], [<footer_content_fun], [>footer]) star 646 646 - val header : ([<header_attrib], [<header_content_fun], [>header]) star 647 647 - val section : ([<section_attrib], [<section_content_fun], [>section]) star 648 648 - val nav : ([<nav_attrib], [<nav_content_fun], [>nav]) star 649 649 - val h1 : ([<h1_attrib], [<h1_content_fun], [>h1]) star 650 650 - val h2 : ([<h2_attrib], [<h2_content_fun], [>h2]) star 651 651 - val h3 : ([<h3_attrib], [<h3_content_fun], [>h3]) star 652 652 - val h4 : ([<h4_attrib], [<h4_content_fun], [>h4]) star 653 653 - val h5 : ([<h5_attrib], [<h5_content_fun], [>h5]) star 654 654 - val h6 : ([<h6_attrib], [<h6_content_fun], [>h6]) star 655 655 - val hgroup : ([<hgroup_attrib], [<hgroup_content_fun], [>hgroup]) star 656 656 - val address : ([<address_attrib], [<address_content_fun], [>address]) star 657 657 - val article : ([<article_attrib], [<article_content_fun], [>article]) star 658 658 - val aside : ([<aside_attrib], [<aside_content_fun], [>aside]) star 659 659 - val main : ([<main_attrib], [<main_content_fun], [>main]) star 660 660 - val p : ([<p_attrib], [<p_content_fun], [>p]) star 661 661 - val pre : ([<pre_attrib], [<pre_content_fun], [>pre]) star 662 662 - val blockquote : 663 663 - ([<blockquote_attrib], [<blockquote_content_fun], [>blockquote]) star 664 664 - val div : ([<div_attrib], [<div_content_fun], [>div]) star 665 665 - val dl : ([<dl_attrib], [<dl_content_fun], [>dl]) star 666 666 - val ol : ([<ol_attrib], [<ol_content_fun], [>ol]) star 667 667 - val ul : ([<ul_attrib], [<ul_content_fun], [>ul]) star 668 668 - val dd : ([<dd_attrib], [<dd_content_fun], [>dd]) star 669 669 - val dt : ([<dt_attrib], [<dt_content_fun], [>dt]) star 670 670 - val li : ([<li_attrib], [<li_content_fun], [>li]) star 671 671 - val figcaption : 672 672 - ([<figcaption_attrib], [<figcaption_content_fun], [>figcaption]) star 673 673 - val figure : 674 674 - ?figcaption:[`Bottom of [<figcaption] elt |`Top of [<figcaption] elt] -> 675 675 - ([<figure_attrib], [<figure_content_fun], [>figure]) star 676 676 - val hr : ([<hr_attrib], [>hr]) nullary 677 677 - val b : ([<b_attrib], [<b_content_fun], [>b]) star 678 678 - val i : ([<i_attrib], [<i_content_fun], [>i]) star 679 679 - val u : ([<u_attrib], [<u_content_fun], [>u]) star 680 680 - val small : ([<small_attrib], [<small_content_fun], [>small]) star 681 681 - val sub : ([<sub_attrib], [<sub_content_fun], [>sub]) star 682 682 - val sup : ([<sup_attrib], [<sup_content_fun], [>sup]) star 683 683 - val mark : ([<mark_attrib], [<mark_content_fun], [>mark]) star 684 684 - val wbr : ([<wbr_attrib], [>wbr]) nullary 685 685 - val bdo : dir:[<`Ltr | `Rtl] Lwd.t -> 686 686 - ([<bdo_attrib], [<bdo_content_fun], [>bdo]) star 687 687 - val abbr : ([<abbr_attrib], [<abbr_content_fun], [>abbr]) star 688 688 - val br : ([<br_attrib], [>br]) nullary 689 689 - val cite : ([<cite_attrib], [<cite_content_fun], [>cite]) star 690 690 - val code : ([<code_attrib], [<code_content_fun], [>code]) star 691 691 - val dfn : ([<dfn_attrib], [<dfn_content_fun], [>dfn]) star 692 692 - val em : ([<em_attrib], [<em_content_fun], [>em]) star 693 693 - val kbd : ([<kbd_attrib], [<kbd_content_fun], [>kbd]) star 694 694 - val q : ([<q_attrib], [<q_content_fun], [>q]) star 695 695 - val samp : ([<samp_attrib], [<samp_content_fun], [>samp]) star 696 696 - val span : ([<span_attrib], [<span_content_fun], [>span]) star 697 697 - val strong : ([<strong_attrib], [<strong_content_fun], [>strong]) star 698 698 - val time : ([<time_attrib], [<time_content_fun], [>time]) star 699 699 - val var : ([<var_attrib], [<var_content_fun], [>var]) star 700 700 - val a : ([<a_attrib], 'a, [>'a a]) star 701 701 - val del : ([<del_attrib], 'a, [>'a del]) star 702 702 - val ins : ([<ins_attrib], 'a, [>'a ins]) star 703 703 - val img : src:Xml.uri Lwd.t -> alt:string Lwd.t -> 704 704 - ([<img_attrib], [>img]) nullary 705 705 - val iframe : ([<iframe_attrib], [<iframe_content_fun], [>iframe]) star 706 706 - val object_ : ?params:[<param] elt list -> 707 707 - ([<object__attrib], 'a, [>`Object of 'a]) star 708 708 - val param : ([<param_attrib], [>param]) nullary 709 709 - val embed : ([<embed_attrib], [>embed]) nullary 710 710 - val audio : ?src:Xml.uri Lwd.t -> ?srcs:[<source] elt list -> 711 711 - ([<audio_attrib], 'a, [>'a audio]) star 712 712 - val video : ?src:Xml.uri Lwd.t -> ?srcs:[<source] elt list -> 713 713 - ([<video_attrib], 'a, [>'a video]) star 714 714 - val canvas : ([<canvas_attrib], 'a, [>'a canvas]) star 715 715 - val source : ([<source_attrib], [>source]) nullary 716 716 - val area : alt:string Lwd.t -> 717 717 - ([<`Accesskey|`Alt|`Aria|`Class|`Contenteditable|`Contextmenu|`Coords 718 718 - |`Dir|`Draggable|`Hidden|`Hreflang|`Id|`Lang |`Media|`Mime_type 719 719 - |`OnAbort|`OnBlur|`OnCanPlay|`OnCanPlayThrough|`OnChange|`OnClick 720 720 - |`OnContextMenu|`OnDblClick|`OnDrag|`OnDragEnd|`OnDragEnter 721 721 - |`OnDragLeave|`OnDragOver|`OnDragStart|`OnDrop|`OnDurationChange 722 722 - |`OnEmptied|`OnEnded|`OnError|`OnFocus|`OnFormChange|`OnFormInput 723 723 - |`OnInput|`OnInvalid|`OnKeyDown|`OnKeyPress|`OnKeyUp|`OnLoad 724 724 - |`OnLoadStart|`OnLoadedData|`OnLoadedMetaData|`OnMouseDown 725 725 - |`OnMouseMove|`OnMouseOut|`OnMouseOver|`OnMouseUp|`OnMouseWheel 726 726 - |`OnPause|`OnPlay|`OnPlaying|`OnProgress|`OnRateChange 727 727 - |`OnReadyStateChange|`OnScroll|`OnSeeked|`OnSeeking|`OnSelect 728 728 - |`OnShow|`OnStalled|`OnSubmit|`OnSuspend|`OnTimeUpdate|`OnTouchCancel 729 729 - |`OnTouchEnd|`OnTouchMove|`OnTouchStart|`OnVolumeChange|`OnWaiting 730 730 - |`Rel|`Role|`Shape|`Spellcheck|`Style_Attr|`Tabindex|`Target 731 731 - |`Title|`User_data|`XML_lang|`XMLns], [>area]) nullary 732 732 - val map : ([<map_attrib], 'a, [>'a map]) star 733 733 - val caption : ([<caption_attrib], [<caption_content_fun], [>caption]) star 734 734 - val table : 735 735 - ?caption:[<caption] elt -> ?columns:[<colgroup] elt list -> 736 736 - ?thead:[<thead] elt -> ?tfoot:[<tfoot] elt -> 737 737 - ([<table_attrib], [<table_content_fun], [>table]) star 738 738 - val tablex : 739 739 - ?caption:[<caption] elt -> ?columns:[<colgroup] elt list -> 740 740 - ?thead:[<thead] elt -> ?tfoot:[<tfoot] elt -> 741 741 - ([<tablex_attrib], [<tablex_content_fun], [>tablex]) star 742 742 - val colgroup : 743 743 - ([<colgroup_attrib], [<colgroup_content_fun], [>colgroup]) star 744 744 - val col : ([<col_attrib], [>col]) nullary 745 745 - val thead : ([<thead_attrib], [<thead_content_fun], [>thead]) star 746 746 - val tbody : ([<tbody_attrib], [<tbody_content_fun], [>tbody]) star 747 747 - val tfoot : ([<tfoot_attrib], [<tfoot_content_fun], [>tfoot]) star 748 748 - val td : ([<td_attrib], [<td_content_fun], [>td]) star 749 749 - val th : ([<th_attrib], [<th_content_fun], [>th]) star 750 750 - val tr : ([<tr_attrib], [<tr_content_fun], [>tr]) star 751 751 - val form : ([<form_attrib], [<form_content_fun], [>form]) star 752 752 - val fieldset : ?legend:[<legend] elt -> 753 753 - ([<fieldset_attrib], [<fieldset_content_fun], [>fieldset]) star 754 754 - val legend : ([<legend_attrib], [<legend_content_fun], [>legend]) star 755 755 - val label : ([<label_attrib], [<label_content_fun], [>label]) star 756 756 - val input : ([<input_attrib], [>input]) nullary 757 757 - val button : ([<button_attrib], [<button_content_fun], [>button]) star 758 758 - val select : ([<select_attrib], [<select_content_fun], [>select]) star 759 759 - val datalist : ?children:[<`Options of [<selectoption] elt list 760 760 - | `Phras of [<phrasing] elt list] -> 761 761 - ([<datalist_attrib], [>datalist]) nullary 762 762 - val optgroup : label:string Lwd.t -> 763 763 - ([<optgroup_attrib], [<optgroup_content_fun], [>optgroup]) star 764 764 - val option : 765 765 - ([<option_attrib], [<option_content_fun], [>selectoption]) unary 766 766 - val textarea : ?a:[<textarea_attrib] attrib list -> string Lwd.t -> [>textarea] elt 767 767 - (* Textarea syntactically looks like it takes its content from its children 768 768 - nodes, but dynamic semantics use the value attribute :-( *) 769 769 - val keygen : 770 770 - ([<keygen_attrib], [>keygen]) nullary 771 771 - val progress : 772 772 - ([<progress_attrib], [<progress_content_fun], [>progress]) star 773 773 - val meter : 774 774 - ([<meter_attrib], [<meter_content_fun], [>meter]) star 775 775 - val output_elt : 776 776 - ([<output_elt_attrib], [<output_elt_content_fun], [>output_elt]) star 777 777 - val entity : string -> [>txt] elt 778 778 - val space : unit -> [>txt] elt 779 779 - val cdata : string -> [>txt] elt 780 780 - val cdata_script : string -> [>txt] elt 781 781 - val cdata_style : string -> [>txt] elt 782 782 - val details : [<summary] elt -> 783 783 - ([<details_attrib], [<details_content_fun], [>details]) star 784 784 - val summary : ([<summary_attrib], [<summary_content_fun], [>summary]) star 785 785 - val command : label:string Lwd.t -> ([<command_attrib], [>command]) nullary 786 786 - val menu : ?children:[<`Flows of [<flow5] elt list 787 787 - | `Lis of [<`Li of [<common]] elt list] -> 788 788 - ([<menu_attrib], [>menu]) nullary 789 789 - val script : 790 790 - ([<script_attrib], [<script_content_fun], [>script]) unary 791 791 - val noscript : 792 792 - ([<noscript_attrib], [<flow5_without_noscript], [>noscript]) star 793 793 - val template : 794 794 - ([<template_attrib], [<template_content_fun], [>template]) star 795 795 - val meta : ([<meta_attrib], [>meta]) nullary 796 796 - val style : ([<style_attrib], [<style_content_fun], [>style]) star 797 797 - val link : rel:linktypes Lwd.t -> href:Xml.uri Lwd.t -> 798 798 - ([<link_attrib], [>link]) nullary 799 799 - val rt : ([<rt_attrib], [<rt_content_fun], [>rt]) star 800 800 - val rp : ([<rp_attrib], [<rp_content_fun], [>rp]) star 801 801 - val ruby : ([<ruby_attrib], [<ruby_content_fun], [>ruby]) star 802 802 - 803 803 - (* val pcdata : string Lwd.t -> [>pcdata] elt *) 804 804 - (* val of_seq : Xml_stream.signal Seq.t -> 'a elt list *) 805 805 - val tot : Xml.elt -> 'a elt 806 806 - (* val totl : Xml.elt list -> 'a elt list *) 807 807 - val toelt : 'a elt -> Xml.elt 808 808 - (* val toeltl : 'a elt list -> Xml.elt list *) 809 809 - val doc_toelt : doc -> Xml.elt 810 810 - val to_xmlattribs : 'a attrib list -> Xml.attrib list 811 811 - val to_attrib : Xml.attrib -> 'a attrib 812 812 - end 813 813 - 814 814 - (** {1 Running an Lwd-driven DOM in the browser} *) 815 815 - 816 816 - module Lwdom : sig 817 817 - type 'a elt = 'a Lwd_seq.t Lwd.t 818 818 - 819 819 - val elt : 'a -> 'a elt 820 820 - (** Create an element from a value *) 821 821 - 822 822 - val children : 'a elt list -> 'a elt 823 823 - (** Flatten a list of elements *) 824 824 - 825 825 - val children_array : 'a elt array -> 'a elt 826 826 - (** Flatten an array of elements *) 827 827 - 828 828 - val attr : 'a -> 'a attr 829 829 - (** Make a constant attribute *) 830 830 - 831 831 - val rattr : 'a Lwd.t -> 'a attr 832 832 - (** Make a reactive attribute *) 833 833 - 834 834 - val to_node : _ node -> raw_node 835 835 - end 836 836 -

-32

forks/lwd/lwd.opam

reviewed

··· 1 1 - # This file is generated by dune, edit dune-project instead 2 2 - opam-version: "2.0" 3 3 - synopsis: "Lightweight reactive documents" 4 4 - maintainer: ["fred@tarides.com"] 5 5 - authors: ["Frédéric Bour"] 6 6 - license: "MIT" 7 7 - homepage: "https://github.com/let-def/lwd" 8 8 - doc: "https://let-def.github.io/lwd/doc" 9 9 - bug-reports: "https://github.com/let-def/lwd/issues" 10 10 - depends: [ 11 11 - "dune" {>= "3.5"} 12 12 - "seq" 13 13 - "ocaml" {>= "4.03"} 14 14 - "qtest" {with-test} 15 15 - "qcheck" {with-test} 16 16 - "odoc" {with-doc} 17 17 - ] 18 18 - build: [ 19 19 - ["dune" "subst"] {dev} 20 20 - [ 21 21 - "dune" 22 22 - "build" 23 23 - "-p" 24 24 - name 25 25 - "-j" 26 26 - jobs 27 27 - "@install" 28 28 - "@runtest" {with-test} 29 29 - "@doc" {with-doc} 30 30 - ] 31 31 - ] 32 32 - dev-repo: "git+https://github.com/let-def/lwd.git"

+5 -5

forks/lwd/nottui-lwt.opam forks/nottui/nottui-lwt.opam

reviewed

··· 1 1 # This file is generated by dune, edit dune-project instead 2 2 opam-version: "2.0" 3 3 synopsis: "Run Nottui UIs in Lwt" 4 4 - maintainer: ["fred@tarides.com"] 5 5 - authors: ["Frédéric Bour"] 4 4 + maintainer: ["fred@tarides.com" "eli.jambu@gmail.com"] 5 5 + authors: ["Frédéric Bour" "Eli Dowling"] 6 6 license: "MIT" 7 7 - homepage: "https://github.com/let-def/lwd" 7 7 + homepage: "https://github.com/flador20/nottui" 8 8 doc: "https://let-def.github.io/lwd/doc" 9 9 - bug-reports: "https://github.com/let-def/lwd/issues" 9 9 + bug-reports: "https://github.com/flador20/nottui/issues" 10 10 depends: [ 11 11 "dune" {>= "3.5"} 12 12 "lwt" ··· 28 28 "@doc" {with-doc} 29 29 ] 30 30 ] 31 31 - dev-repo: "git+https://github.com/let-def/lwd.git" 31 31 + dev-repo: "git+https://github.com/flador20/nottui.git"

+5 -5

forks/lwd/nottui-pretty.opam forks/nottui/nottui-pretty.opam

reviewed

··· 1 1 # This file is generated by dune, edit dune-project instead 2 2 opam-version: "2.0" 3 3 synopsis: "A pretty-printer based on PPrint rendering UIs" 4 4 - maintainer: ["fred@tarides.com"] 5 5 - authors: ["Frédéric Bour"] 4 4 + maintainer: ["fred@tarides.com" "eli.jambu@gmail.com"] 5 5 + authors: ["Frédéric Bour" "Eli Dowling"] 6 6 license: "MIT" 7 7 - homepage: "https://github.com/let-def/lwd" 7 7 + homepage: "https://github.com/flador20/nottui" 8 8 doc: "https://let-def.github.io/lwd/doc" 9 9 - bug-reports: "https://github.com/let-def/lwd/issues" 9 9 + bug-reports: "https://github.com/flador20/nottui/issues" 10 10 depends: [ 11 11 "dune" {>= "3.5"} 12 12 "nottui" {= version} ··· 27 27 "@doc" {with-doc} 28 28 ] 29 29 ] 30 30 - dev-repo: "git+https://github.com/let-def/lwd.git" 30 30 + dev-repo: "git+https://github.com/flador20/nottui.git"

-32

forks/lwd/nottui.opam

reviewed

··· 1 1 - # This file is generated by dune, edit dune-project instead 2 2 - opam-version: "2.0" 3 3 - synopsis: "UI toolkit for the terminal built on top of Notty and Lwd" 4 4 - maintainer: ["fred@tarides.com"] 5 5 - authors: ["Frédéric Bour"] 6 6 - license: "MIT" 7 7 - homepage: "https://github.com/let-def/lwd" 8 8 - doc: "https://let-def.github.io/lwd/doc" 9 9 - bug-reports: "https://github.com/let-def/lwd/issues" 10 10 - depends: [ 11 11 - "dune" {>= "3.5"} 12 12 - "lwd" {= version} 13 13 - "notty" {>= "0.2"} 14 14 - "cbor" {with-test} 15 15 - "containers" {with-test} 16 16 - "odoc" {with-doc} 17 17 - ] 18 18 - build: [ 19 19 - ["dune" "subst"] {dev} 20 20 - [ 21 21 - "dune" 22 22 - "build" 23 23 - "-p" 24 24 - name 25 25 - "-j" 26 26 - jobs 27 27 - "@install" 28 28 - "@runtest" {with-test} 29 29 - "@doc" {with-doc} 30 30 - ] 31 31 - ] 32 32 - dev-repo: "git+https://github.com/let-def/lwd.git"

-32

forks/lwd/tyxml-lwd.opam

reviewed

··· 1 1 - # This file is generated by dune, edit dune-project instead 2 2 - opam-version: "2.0" 3 3 - synopsis: "Make reactive webpages in Js_of_ocaml using Tyxml and Lwd" 4 4 - maintainer: ["fred@tarides.com"] 5 5 - authors: ["Frédéric Bour"] 6 6 - license: "MIT" 7 7 - homepage: "https://github.com/let-def/lwd" 8 8 - doc: "https://let-def.github.io/lwd/doc" 9 9 - bug-reports: "https://github.com/let-def/lwd/issues" 10 10 - depends: [ 11 11 - "dune" {>= "3.5"} 12 12 - "lwd" {= version} 13 13 - "tyxml" {>= "4.5.0"} 14 14 - "js_of_ocaml" 15 15 - "js_of_ocaml-ppx" 16 16 - "odoc" {with-doc} 17 17 - ] 18 18 - build: [ 19 19 - ["dune" "subst"] {dev} 20 20 - [ 21 21 - "dune" 22 22 - "build" 23 23 - "-p" 24 24 - name 25 25 - "-j" 26 26 - jobs 27 27 - "@install" 28 28 - "@runtest" {with-test} 29 29 - "@doc" {with-doc} 30 30 - ] 31 31 - ] 32 32 - dev-repo: "git+https://github.com/let-def/lwd.git"

+1

forks/nottui/.envrc

reviewed

··· 1 1 + use flake

+95

forks/nottui/README.md

reviewed

··· 1 1 + Nottui is a toolkit for making terminal user-interfaces. 2 2 + It builds upon [Notty](https://github.com/pqwy/notty/), adding a layout DSL and support for event dispatch, 3 3 + and [Lwd](https://github.com/let-def/lwd) which is used for interactivity. 4 4 + 5 5 + **This repo is forked from [Lwd](https://github.com/let-def/lwd) I'd like to get it reintegrated with that at some point, I'm just waiting until let-def has a little more time on his plate** 6 6 + 7 7 + # Getting started 8 8 + 9 9 + The package is distributed through opam: 10 10 + 11 11 + ```bash 12 12 + $ opam install nottui 13 13 + ``` 14 14 + 15 15 + ## Tutorial 16 16 + There is a tutorial for nottui which will take you through the basics of making a small application, it covers: 17 17 + - how to do layout 18 18 + - reactive values 19 19 + - handling keyboard input 20 20 + - and much more! 21 21 + 22 22 + See [tutorial](tutorial/hackernews/tutorial.md) 23 23 + 24 24 + ## Docs 25 25 + For more details on how to write Nottui applications and how Nottui works see the [docs](docs/). 26 26 + I recommend reading at least [the fundimentals](docs/fundimentals.md). 27 27 + ## Examples 28 28 + 29 29 + Here are a few examples of using Nottui, more can be found in the [examples](examples/) folder: 30 30 + 31 31 + Let's start with Hello world. 32 32 + 33 33 + #### Hello world 34 34 + 35 35 + ```ocaml 36 36 + #require "nottui";; 37 37 + open Nottui;; 38 38 + 39 39 + Ui_loop.run (Lwd.pure (W.printf "Hello world"));; 40 40 + ``` 41 41 + 42 42 + Running the application is just a matter of calling `Ui_loop.run` with a ui 43 43 + value. 44 44 + 45 45 + **Note:** Press Ctrl-Q to return to the top-level (or shell). 46 46 + 47 47 + #### Counting clicks 48 48 + 49 49 + Now we will count the number of clicks on a button. 50 50 + 51 51 + ```ocaml 52 52 + let vcount = Lwd.var 0;; 53 53 + 54 54 + let button count = 55 55 + W.button (Printf.sprintf "Clicked %d times!" count) 56 56 + (fun () -> Lwd.set vcount (count + 1));; 57 57 + 58 58 + Ui_loop.run (Lwd.map button (Lwd.get vcount));; 59 59 + ``` 60 60 + 61 61 + We reserve state for holding the number of clicks, we render a button and 62 62 + increment the state when clicked. 63 63 + 64 64 + #### Displaying a tree 65 65 + 66 66 + ```ocaml 67 67 + type tree = Tree of string * (unit -> tree list) 68 68 + 69 69 + let rec tree_ui (Tree (label, child)) = 70 70 + let opened = Lwd.var false in 71 71 + let render is_opened = 72 72 + let btn_text = if is_opened then "[-] " else "[+] " in 73 73 + let btn_action () = Lwd.set opened (not is_opened) in 74 74 + let btn = W.button (btn_text ^ label) btn_action in 75 75 + let layout node forest = 76 76 + Ui.join_y node (Ui.join_x (Ui.space 2 0) forest) 77 77 + in 78 78 + if is_opened 79 79 + then Lwd.map (layout btn) (forest_ui (child ())) 80 80 + else Lwd.pure btn 81 81 + in 82 82 + Lwd.join (Lwd.map render (Lwd.get opened)) 83 83 + 84 84 + and forest_ui nodes = 85 85 + Lwd_utils.pack Ui.pack_y 86 86 + (List.map tree_ui nodes) 87 87 + ;; 88 88 + 89 89 + let rec fake_fs () = [ 90 90 + Tree ("bin", fake_fs); 91 91 + Tree ("home", fake_fs); 92 92 + Tree ("usr", fake_fs); 93 93 + ] in 94 94 + Ui_loop.run (forest_ui (fake_fs ()));; 95 95 + ```

+6

forks/nottui/docs/async.md

reviewed

··· 1 1 + # Using Nottui with async runtimes 2 2 + TODO: 3 3 + 4 4 + With Lwt 5 5 + With Eio 6 6 + With picos?

+7

forks/nottui/docs/docs.md

reviewed

··· 1 1 + # Nottui docs 2 2 + - [tutorial](../tutorial/hackernews/bin/tutorial.md) to get a quick guide to building a basic nottui application 3 3 + - [fundimentals](fundimentals.md) to get an overview of the nottui syntax and basic concepts. 4 4 + - [performance of lwd.bind](lwd_bind.md) to learn about why you should avoid using `let$*` too much. 5 5 + - [async](async.md) to learn about how to couple nottui with various async runtimes. 6 6 + 7 7 +

+277

forks/nottui/docs/fundimentals.md

reviewed

··· 1 1 + ## Fundamentals of Lwd as it relates to nottui 2 2 + 3 3 + Lwd (Lightweight Document) is a library that lets you build values that changes over time and recompute reactively. 4 4 + Nottui is a library for building TUI(Terminal User Interface) programs that uses Lwd to make its ui react to changes. 5 5 + Notty is a library for interface with the terminal, displaying symbols, colours etc. 6 6 + 7 7 + When writing a ui in nottui, you are building a graph of Lwd nodes containing ui elements that each reactively update when their children change. 8 8 + Each "tick" Nottui will use Lwd to resolve the current state of the ui, updating any pieces whos dependencies have changed. 9 9 + If the new ui is different it will render it to the terminal using Notty. 10 10 + ## Core functions within Nottui 11 11 + 12 12 + # Key Functions in Nottui 13 13 + 14 14 + Nottui provides a set of core modules and functions for building terminal user interfaces: 15 15 + 16 16 + ## Ui Module 17 17 + - `Ui.atom`: Creates a UI element from a Notty image 18 18 + Example: 19 19 + 20 20 + let hello_world = Ui.atom (Notty.I.string Notty.A.empty "Hello, World!") 21 21 + 22 22 + 23 23 + - `Ui.hcat`, `Ui.vcat`, `Ui.zcat`: Concatenate lists of UI elements 24 24 + - `Ui.hcat`: Horizontally concatenates UI elements 25 25 + - `Ui.vcat`: Vertically concatenates UI elements 26 26 + - `Ui.zcat`: Stacks UI elements on top of each other (z-axis) 27 27 + Example: 28 28 + ```ocaml 29 29 + let horizontal_layout = Ui.hcat [ 30 30 + Ui.atom (Notty.I.string Notty.A.empty "Left"); 31 31 + Ui.atom (Notty.I.string Notty.A.empty "Right") 32 32 + ] 33 33 + let vertical_layout = Ui.vcat [ 34 34 + Ui.atom (Notty.I.string Notty.A.empty "Top"); 35 35 + Ui.atom (Notty.I.string Notty.A.empty "Bottom") 36 36 + ] 37 37 + ``` 38 38 + 39 39 + - `Ui.resize`: Adjust layout specifications of a UI element 40 40 + Parameters: 41 41 + - `?w`: Width (optional) 42 42 + - `?h`: Height (optional) 43 43 + - `?sw`: Width strategy (optional) 44 44 + - `?sh`: Height strategy (optional) 45 45 + Example: 46 46 + 47 47 + let resized_element = Ui.resize ~w:20 ~h:10 (Ui.atom (Notty.I.string Notty.A.empty "Resized")) 48 48 + 49 49 + 50 50 + - `Ui.mouse_area`, `Ui.keyboard_area`: Add event handlers to UI elements 51 51 + Example: 52 52 + 53 53 + let clickable_button = 54 54 + Ui.mouse_area (fun ~x:_ ~y:_ _ -> 55 55 + Printf.printf "Button clicked!\n"; 56 56 + `Handled 57 57 + ) (Ui.atom (Notty.I.string Notty.A.empty "Click me")) 58 58 + 59 59 + let keyboard_input = 60 60 + Ui.keyboard_area (fun _ -> 61 61 + Printf.printf "Key pressed!\n"; 62 62 + `Handled 63 63 + ) (Ui.atom (Notty.I.string Notty.A.empty "Press any key")) 64 64 + 65 65 + 66 66 + - `Ui.size_sensor`, `Ui.transient_sensor`, `Ui.permanent_sensor`: Observe UI element dimensions 67 67 + - `Ui.size_sensor`: Reports size changes of a UI element 68 68 + - `Ui.transient_sensor`: Reports size changes only when the element is visible 69 69 + - `Ui.permanent_sensor`: Always reports size changes, even when the element is not visible 70 70 + Example: 71 71 + 72 72 + let size_aware_element = 73 73 + Ui.size_sensor (fun ~w ~h -> 74 74 + Printf.printf "Element size: %dx%d\n" w h; 75 75 + Ui.atom (Notty.I.string Notty.A.empty (Printf.sprintf "Size: %dx%d" w h)) 76 76 + ) 77 77 + 78 78 + 79 79 + 80 80 + ## Ui_loop Module 81 81 + 82 82 + - `Ui_loop.run`: Starts the loop for running the application 83 83 + 84 84 + ## Examples 85 85 + 86 86 + 1. Hello World: 87 87 + ``` 88 88 + Ui_loop.run (Lwd.pure (Ui.atom (Notty.I.string A.empty "Hello, World!"))) 89 89 + 90 90 + 91 91 + 2. Button with Click Counter: 92 92 + 93 93 + let count = Lwd.var 0 94 94 + let button = 95 95 + Ui.mouse_area (fun ~x:_ ~y:_ _ -> 96 96 + Lwd.set count (Lwd.peek count + 1); 97 97 + `Handled) 98 98 + (Lwd.map (fun n -> Ui.atom (Notty.I.string A.empty (Printf.sprintf "Clicks: %d" n))) (Lwd.get count)) 99 99 + 100 100 + Ui_loop.run (Lwd.pure button) 101 101 + 102 102 + 103 103 + 3. Simple Layout: 104 104 + 105 105 + let layout = 106 106 + Ui.join_y 107 107 + (Ui.atom (Notty.I.string A.empty "Top")) 108 108 + (Ui.join_x 109 109 + (Ui.atom (Notty.I.string A.empty "Left")) 110 110 + (Ui.atom (Notty.I.string A.empty "Right"))) 111 111 + 112 112 + Ui_loop.run (Lwd.pure layout) 113 113 + 114 114 + 115 115 + These examples demonstrate basic UI creation, event handling, and layout composition using Nottui's core functions. 116 116 + 117 117 + ## Core functions within Lwd 118 118 + 119 119 + #### Lwd.t and Lwd.var 120 120 + 121 121 + - `'a Lwd.t`: Represents a value of type `'a` that can change over time. 122 122 + - `'a Lwd.var`: A mutable variable that can be used as a source for `Lwd.t` values. 123 123 + 124 124 + #### Basic Operations 125 125 + 126 126 + - Creating a variable: 127 127 + ```ocaml 128 128 + let counter_var = Lwd.var 0 129 129 + ``` 130 130 + - Reading a variable as a reactive `Lwd.t`: 131 131 + 132 132 + ```ocaml 133 133 + let counter_value = Lwd.get counter_var 134 134 + ``` 135 135 + - Reading a variable instantaneously: 136 136 + This reads a variable as it currently is. 137 137 + This should be used in callbacks and in response to events like keybaord input becasue 138 138 + it won't trigger an update when the variable changes 139 139 + ```ocaml 140 140 + Ui.keyboard_area (function 141 141 + | `Enter ,[]-> 142 142 + let counter_value = Lwd.peek counter_var 143 143 + (*do something with counter*) 144 144 + `Handled 145 145 + |_-> `Unandled 146 146 + ) 147 147 + ``` 148 148 + 149 149 + 150 150 + - Updating a variable: 151 151 + ```ocaml 152 152 + counter_var |> Lwd.update(fun counter -> counter + 1) 153 153 + ``` 154 154 + 155 155 + 156 156 + #### Transforming Lwd values: 157 157 + 158 158 + Lwd.map transforms the contents of an `lwd.t` just like `List.map`. 159 159 + It will re-run the computation whenevre the input `Lwd.t` changes 160 160 + 161 161 + ```ocaml 162 162 + let double_counter = Lwd.map (fun x -> x * 2) counter_value 163 163 + ``` 164 164 + 165 165 + ```ocaml 166 166 + let counter_display = Lwd.bind (fun x -> if x>10 then a else b) counter_value 167 167 + ``` 168 168 + 169 169 + 170 170 + #### Lwd infix syntax 171 171 + 172 172 + `let$` Syntax 173 173 + Used for binding Lwd values, similar to Lwd.map: 174 174 + ```ocaml 175 175 + let$ count = Lwd.get counter in 176 176 + W.printf "Count: %d" count 177 177 + ``` 178 178 + 179 179 + 180 180 + `and$` Syntax 181 181 + Combines multiple Lwd values: 182 182 + ```ocaml 183 183 + let$ count = Lwd.get counter 184 184 + and$ name = Lwd.get name_var in 185 185 + W.printf "%s: %d" name count 186 186 + ``` 187 187 + `|>$` Syntax 188 188 + shorthand for `|> Lwd.map ~f:` 189 189 + This is particularly useful when running funcs like `Ui.resize` or `Ui.keyboard_area` 190 190 + ```ocaml 191 191 + "hi 192 192 + there" 193 193 + |>W.string 194 194 + |>Lwd.pure 195 195 + |>W.Scroll.v_scroll 196 196 + |>$ Ui.resize ~sw:1 ~mw:10000 197 197 + (* 198 198 + Same as: 199 199 + |> Lwd.map ~f:(Ui.resize ~sw:1 ~mw:10000)*) 200 200 + ``` 201 201 + 202 202 + `let$*` Syntax 203 203 + For nested Lwd computations, similar to Lwd.bind: 204 204 + ```ocaml 205 205 + let$* count = Lwd.get counter in 206 206 + let$* doubled = Lwd.return (count * 2) in 207 207 + W.printf "Doubled count: %d" doubled 208 208 + ``` 209 209 + 210 210 + Note: Use `let$*` sparingly as it can lead to inefficient recomputations. 211 211 + 212 212 + `$=` Operator for Setting Lwd.vars 213 213 + A convenient way to update Lwd.vars: 214 214 + 215 215 + ```ocaml 216 216 + let counter=Lwd.var 1 in 217 217 + counter $= 1 218 218 + ``` 219 219 + 220 220 + This is equivalent to: 221 221 + 222 222 + ```ocaml 223 223 + Lwd.set counter (1) 224 224 + ``` 225 225 + 226 226 + 227 227 + ### Practical Examples 228 228 + 229 229 + Creating a Counter Button 230 230 + 231 231 + ```ocaml 232 232 + open Nottui 233 233 + open Lwd_infix 234 234 + 235 235 + let make_counter_button () = 236 236 + let counter = Lwd.var 0 in 237 237 + let$ count = Lwd.get counter in 238 238 + Nottui_widgets.button 239 239 + (Printf.sprintf "Clicks: %d" count) 240 240 + (fun () -> counter $= fun c -> c + 1) 241 241 + ``` 242 242 + 243 243 + 244 244 + Combining Multiple Reactive Elements 245 245 + ```ocaml 246 246 + let make_ui () = 247 247 + let name = Lwd.var "User" in 248 248 + let counter = Lwd.var 0 in 249 249 + let$ button = make_counter_button () 250 250 + and$ greeting = 251 251 + let$ name = Lwd.get name 252 252 + and$ count = Lwd.get counter in 253 253 + Nottui_widgets.printf "Hello, %s! Count: %d" name count 254 254 + in 255 255 + Ui.join_y button greeting 256 256 + ``` 257 257 + 258 258 + 259 259 + Using let$* (Cautiously) 260 260 + ```ocaml 261 261 + let make_dynamic_ui () = 262 262 + let threshold = Lwd.var 5 in 263 263 + let counter = Lwd.var 0 in 264 264 + let$* count = Lwd.get counter in 265 265 + if count > 10 then 266 266 + some_complex_ui_lwd_t 267 267 + else 268 268 + some_other_complex_ui_lwd_t 269 269 + ``` 270 270 + 271 271 + 272 272 + ### Best Practices: 273 273 + - Prefer let$ and and$ for most transformations and combinations. 274 274 + - Use let$* sparingly, only when necessary for conditional logic or complex transformations. 275 275 + - Utilize $= for concise Lwd.var updates. 276 276 + - Structure your UI to minimize unnecessary recomputations. 277 277 +

+67

forks/nottui/docs/lwd_bind.md

reviewed

··· 1 1 + 2 2 + # Caution with Lwd.bind/let$* 3 3 + Avoid Overuse of `let$*`( which is an alias for `Lwd.bind`) 4 4 + 5 5 + The `let$*` syntax, while powerful, should be used sparingly in Lwd applications, especially with Nottui. It's crucial to understand its implications and potential performance pitfalls. 6 6 + 7 7 + ## Why let$* Should Be Avoided When Possible 8 8 + Full Recomputation: The most significant issue with `let$*` is that it causes the any dependencies within it to be removed and reinstantiated. This can lead to unnecessary recomputations and a lot of extra work and thus potential performance issues. 9 9 + 10 10 + Less clear dependencies: Combining all `lwd.var`s in one place using `let$` and `and$` makes it more easy to see what will cause a recomputation. 11 11 + 12 12 + ## Example of Inefficient Use 13 13 + Consider this example: 14 14 + ```ocaml 15 15 + let inefficient_ui = 16 16 + let$* count = Lwd.get counter in 17 17 + let$* name = Lwd.get name_var in 18 18 + let$* items = Lwd.get item_list in 19 19 + Ui.vbox [ 20 20 + Nottui_widgets.printf "Count: %d" count; 21 21 + Nottui_widgets.printf "Name: %s" name; 22 22 + Ui.vbox (List.map (fun item -> Nottui_widgets.printf "%s" item) items) 23 23 + ] 24 24 + ``` 25 25 + In this case, the entire UI will be recomputed whenever `counter`, `name_var`, or `item_list` changes, even if only one of them has actually been updated. 26 26 + 27 27 + ## Efficient Alternative 28 28 + A more efficient approach would be: 29 29 + ```ocaml 30 30 + let efficient_ui = 31 31 + Ui.vbox [ 32 32 + (let$ count = Lwd.get counter in 33 33 + Nottui_widgets.printf "Count: %d" count); 34 34 + (let$ name = Lwd.get name_var in 35 35 + Nottui_widgets.printf "Name: %s" name); 36 36 + (let$ items = Lwd.get item_list in 37 37 + Ui.vbox (List.map (fun item -> Nottui_widgets.printf "%s" item) items)) 38 38 + ] 39 39 + ``` 40 40 + 41 41 + This version ensures that each part of the UI is only recomputed when its specific dependencies change. 42 42 + 43 43 + ## When to Use `let$*` 44 44 + Despite these cautions, there are legitimate uses for `let$*`: 45 45 + 46 46 + - Conditional UI Logic: When you need to make decisions about UI structure based on reactive values. 47 47 + - Complex Transformations: For operations that genuinely require nested reactive computations. 48 48 + An example of appropriate use: 49 49 + ```ocaml 50 50 + let conditional_ui = 51 51 + let$* count = Lwd.get counter in 52 52 + if count > 10 then 53 53 + (* Think of this as a standin for a more complex ui that is reactive*) 54 54 + let$ message = Lwd.return "Count is high!" in 55 55 + Nottui_widgets.printf "%s" message 56 56 + else 57 57 + (* Think of this as a standin for a more complex ui that is reactive*) 58 58 + let$ message = Lwd.return "Count is low." in 59 59 + Nottui_widgets.printf "%s" message 60 60 + ``` 61 61 + 62 62 + 63 63 + Best Practices 64 64 + Prefer `let$`and `and$`: Use these for most transformations and combinations of Lwd values. 65 65 + Isolate `let$*` Usage: When needed, try to isolate `let$*` to small, specific parts of your UI. 66 66 + Review and Refactor: Regularly review your use of `let$*` and consider if there are more efficient ways to structure your reactive computations. 67 67 + By being cautious with `let$*` and understanding its implications, you can create more efficient and maintainable reactive UIs with Lwd and Nottui.

+2

forks/nottui/dune

reviewed

··· 1 1 + 2 2 + (data_only_dirs "tutorial")

+56

forks/nottui/dune-project

reviewed

··· 1 1 + (lang dune 3.5) 2 2 + 3 3 + (generate_opam_files true) 4 4 + 5 5 + (formatting 6 6 + (enabled_for dune)) 7 7 + 8 8 + (name nottui) 9 9 + 10 10 + (source 11 11 + (github flador20/nottui)) 12 12 + 13 13 + (license MIT) 14 14 + 15 15 + (authors 16 16 + "Frédéric Bour" 17 17 + "Eli Dowling" 18 18 + ) 19 19 + 20 20 + (maintainers 21 21 + "fred@tarides.com" 22 22 + "eli.jambu@gmail.com" 23 23 + ) 24 24 + 25 25 + (package 26 26 + (name nottui) 27 27 + (synopsis "UI toolkit for the terminal built on top of Notty and Lwd") 28 28 + (documentation "https://let-def.github.io/lwd/doc") 29 29 + (depends 30 30 + (lwd 31 31 + (= :version)) 32 32 + (notty 33 33 + (>= 0.2)) 34 34 + (cbor :with-test) ; for the examples 35 35 + (containers :with-test))) 36 36 + 37 37 + (package 38 38 + (name nottui-pretty) 39 39 + (synopsis "A pretty-printer based on PPrint rendering UIs") 40 40 + (documentation "https://let-def.github.io/lwd/doc") 41 41 + (depends 42 42 + (nottui 43 43 + (= :version)) 44 44 + (notty 45 45 + (>= 0.2)))) 46 46 + 47 47 + (package 48 48 + (name nottui-lwt) 49 49 + (synopsis "Run Nottui UIs in Lwt") 50 50 + (documentation "https://let-def.github.io/lwd/doc") 51 51 + (depends 52 52 + lwt 53 53 + (nottui 54 54 + (= :version)) 55 55 + (notty 56 56 + (>= 0.2))))

+109

forks/nottui/flake.lock

reviewed

··· 1 1 + { 2 2 + "nodes": { 3 3 + "flake-parts": { 4 4 + "inputs": { 5 5 + "nixpkgs-lib": "nixpkgs-lib" 6 6 + }, 7 7 + "locked": { 8 8 + "lastModified": 1719994518, 9 9 + "narHash": "sha256-pQMhCCHyQGRzdfAkdJ4cIWiw+JNuWsTX7f0ZYSyz0VY=", 10 10 + "owner": "hercules-ci", 11 11 + "repo": "flake-parts", 12 12 + "rev": "9227223f6d922fee3c7b190b2cc238a99527bbb7", 13 13 + "type": "github" 14 14 + }, 15 15 + "original": { 16 16 + "id": "flake-parts", 17 17 + "type": "indirect" 18 18 + } 19 19 + }, 20 20 + "flake-utils": { 21 21 + "inputs": { 22 22 + "systems": "systems" 23 23 + }, 24 24 + "locked": { 25 25 + "lastModified": 1710146030, 26 26 + "narHash": "sha256-SZ5L6eA7HJ/nmkzGG7/ISclqe6oZdOZTNoesiInkXPQ=", 27 27 + "owner": "numtide", 28 28 + "repo": "flake-utils", 29 29 + "rev": "b1d9ab70662946ef0850d488da1c9019f3a9752a", 30 30 + "type": "github" 31 31 + }, 32 32 + "original": { 33 33 + "owner": "numtide", 34 34 + "repo": "flake-utils", 35 35 + "type": "github" 36 36 + } 37 37 + }, 38 38 + "nixpkgs": { 39 39 + "locked": { 40 40 + "lastModified": 1715266358, 41 41 + "narHash": "sha256-doPgfj+7FFe9rfzWo1siAV2mVCasW+Bh8I1cToAXEE4=", 42 42 + "path": "/nix/store/asymc3nsl739p1wwr0w6xbjnqs3qb94p-source", 43 43 + "rev": "f1010e0469db743d14519a1efd37e23f8513d714", 44 44 + "type": "path" 45 45 + }, 46 46 + "original": { 47 47 + "id": "nixpkgs-unstable", 48 48 + "type": "indirect" 49 49 + } 50 50 + }, 51 51 + "nixpkgs-lib": { 52 52 + "locked": { 53 53 + "lastModified": 1719876945, 54 54 + "narHash": "sha256-Fm2rDDs86sHy0/1jxTOKB1118Q0O3Uc7EC0iXvXKpbI=", 55 55 + "type": "tarball", 56 56 + "url": "https://github.com/NixOS/nixpkgs/archive/5daf0514482af3f97abaefc78a6606365c9108e2.tar.gz" 57 57 + }, 58 58 + "original": { 59 59 + "type": "tarball", 60 60 + "url": "https://github.com/NixOS/nixpkgs/archive/5daf0514482af3f97abaefc78a6606365c9108e2.tar.gz" 61 61 + } 62 62 + }, 63 63 + "ocaml-overlay": { 64 64 + "inputs": { 65 65 + "flake-utils": "flake-utils", 66 66 + "nixpkgs": [ 67 67 + "nixpkgs" 68 68 + ] 69 69 + }, 70 70 + "locked": { 71 71 + "lastModified": 1719856582, 72 72 + "narHash": "sha256-FH8Bo8uDzgPvWhdpvO/UDNcN5x19Hc/8wAY2LvoHk9o=", 73 73 + "owner": "nix-ocaml", 74 74 + "repo": "nix-overlays", 75 75 + "rev": "b6c6fad7a40227db49e2628947db34745d6b7f53", 76 76 + "type": "github" 77 77 + }, 78 78 + "original": { 79 79 + "owner": "nix-ocaml", 80 80 + "repo": "nix-overlays", 81 81 + "type": "github" 82 82 + } 83 83 + }, 84 84 + "root": { 85 85 + "inputs": { 86 86 + "flake-parts": "flake-parts", 87 87 + "nixpkgs": "nixpkgs", 88 88 + "ocaml-overlay": "ocaml-overlay" 89 89 + } 90 90 + }, 91 91 + "systems": { 92 92 + "locked": { 93 93 + "lastModified": 1681028828, 94 94 + "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=", 95 95 + "owner": "nix-systems", 96 96 + "repo": "default", 97 97 + "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e", 98 98 + "type": "github" 99 99 + }, 100 100 + "original": { 101 101 + "owner": "nix-systems", 102 102 + "repo": "default", 103 103 + "type": "github" 104 104 + } 105 105 + } 106 106 + }, 107 107 + "root": "root", 108 108 + "version": 7 109 109 + }

+101

forks/nottui/flake.nix

reviewed

··· 1 1 + { 2 2 + description = "Nottui nix flake"; 3 3 + 4 4 + # Flake inputs 5 5 + inputs = { 6 6 + 7 7 + nixpkgs.url = "nixpkgs-unstable"; # also valid: "nixpkgs" 8 8 + 9 9 + ocaml-overlay = { 10 10 + url = "github:nix-ocaml/nix-overlays"; 11 11 + inputs.nixpkgs.follows = "nixpkgs"; 12 12 + }; 13 13 + }; 14 14 + 15 15 + # Flake outputs 16 16 + outputs = { self, nixpkgs, flake-parts, ocaml-overlay, ... }@inputs: 17 17 + 18 18 + flake-parts.lib.mkFlake { inherit inputs; } { 19 19 + systems = 20 20 + [ "x86_64-linux" "aarch64-linux" "aarch64-darwin" "x86_64-darwin" ]; 21 21 + perSystem = { config, self', inputs', pkgs, system, ... }: 22 22 + let 23 23 + # OCaml packages available on nixpkgs 24 24 + ocamlPackages = pkgs.ocaml-ng.ocamlPackages_5_1; 25 25 + packages = { 26 26 + lwd = ocamlPackages.lwd.overrideAttrs (old: { 27 27 + src = pkgs.fetchFromGitHub { 28 28 + owner = "faldor20"; 29 29 + repo = "lwd"; 30 30 + rev = "a150ef22ecb60d842e45a377fec233826a06b221"; 31 31 + sha256 = "sha256-bee+tEmi8RMCT6W7N8qYC1UvDXl8RqAoWze1GBjfVPw="; 32 32 + }; 33 33 + }); 34 34 + 35 35 + nottui = ocamlPackages.buildDunePackage { 36 36 + pname = "nottui"; 37 37 + version = "0.4.0"; 38 38 + duneVersion = "3"; 39 39 + src = ./.; 40 40 + buildInputs = with ocamlPackages; [ 41 41 + packages.lwd 42 42 + ppx_inline_test 43 43 + ppx_assert 44 44 + notty 45 45 + ]; 46 46 + strictDeps = true; 47 47 + }; 48 48 + 49 49 + nottui-lwd = ocamlPackages.buildDunePackage { 50 50 + pname = "nottui-lwd"; 51 51 + version = "0.4.0"; 52 52 + duneVersion = "3"; 53 53 + src = ./lib/nottui-lwd/.; 54 54 + buildInputs = with ocamlPackages; [ packages.nottui notty ]; 55 55 + strictDeps = true; 56 56 + }; 57 57 + 58 58 + nottui-pretty = ocamlPackages.buildDunePackage { 59 59 + pname = "nottui-pretty"; 60 60 + version = "0.4.0"; 61 61 + duneVersion = "3"; 62 62 + src = ./lib/nottui-pretty/.; 63 63 + buildInputs = with ocamlPackages; [ packages.nottui ]; 64 64 + strictDeps = true; 65 65 + }; 66 66 + }; 67 67 + 68 68 + in { 69 69 + _module.args.pkgs = import inputs.nixpkgs { 70 70 + inherit system; 71 71 + config.allowUnfree = true; 72 72 + overlays = [ ocaml-overlay.overlays.default ]; 73 73 + }; 74 74 + packages = packages; 75 75 + devShells = { 76 76 + default = pkgs.mkShell.override { stdenv = pkgs.gccStdenv; } { 77 77 + buildInputs = with ocamlPackages; [ 78 78 + dune 79 79 + utop 80 80 + ocaml 81 81 + ocamlformat 82 82 + 83 83 + #for tangling 84 84 + re 85 85 + iter 86 86 + base 87 87 + angstrom 88 88 + ppx_let 89 89 + ]; 90 90 + 91 91 + inputsFrom = [ self'.packages.nottui ]; 92 92 + packages = builtins.attrValues { 93 93 + inherit (pkgs) gcc pkg-config; 94 94 + inherit (ocamlPackages) ocaml-lsp ocamlformat-rpc-lib; 95 95 + }; 96 96 + }; 97 97 + }; 98 98 + 99 99 + }; 100 100 + }; 101 101 + }

+8

forks/nottui/lib/nottui/dune

reviewed

··· 1 1 + (include_subdirs unqualified) 2 2 + 3 3 + (library 4 4 + (name nottui) 5 5 + (public_name nottui) 6 6 + (wrapped true) 7 7 + (libraries lwd notty notty.unix) 8 8 + )

+2

forks/nottui/lib/nottui/nottui.ml

reviewed

··· 1 1 + include Nottui_main 2 2 + module W=Widgets

+180

forks/nottui/lib/nottui/widgets/Shared.ml

reviewed

··· 1 1 + open Notty 2 2 + open Nottui_main 3 3 + 4 4 + let neutral_grav = Gravity.make ~h:`Neutral ~v:`Neutral 5 5 + let make_even num = num + (num mod 2 * 1) 6 6 + 7 7 + let empty_lwd = Lwd.return Ui.empty 8 8 + let mini, maxi, clampi = Lwd_utils.(mini, maxi, clampi) 9 9 + 10 10 + let attr_clickable = A.(bg lightblue) 11 11 + 12 12 + (** This is for shifting something away from the edge it is pushed against *) 13 13 + let pad_edge x_pad y_pad grav ui = 14 14 + let y_pad = 15 15 + match grav |> Gravity.v with 16 16 + | `Negative -> 17 17 + -y_pad 18 18 + | `Neutral -> 19 19 + 0 20 20 + | `Positive -> 21 21 + y_pad 22 22 + in 23 23 + match grav |> Gravity.h with 24 24 + | `Negative -> 25 25 + ui |> Ui.shift_area (-x_pad) y_pad 26 26 + | `Neutral -> 27 27 + ui 28 28 + | `Positive -> 29 29 + ui |> Ui.shift_area x_pad y_pad 30 30 + ;; 31 31 + 32 32 + (** Ui element from a string *) 33 33 + let string ?(attr = A.empty) str = 34 34 + let control_character_index str i = 35 35 + let len = String.length str in 36 36 + let i = ref i in 37 37 + while 38 38 + let i = !i in 39 39 + i < len && str.[i] >= ' ' 40 40 + do 41 41 + incr i 42 42 + done; 43 43 + if !i = len then raise Not_found; 44 44 + !i 45 45 + in 46 46 + let rec split str i = 47 47 + match control_character_index str i with 48 48 + | j -> 49 49 + let img = I.string attr (String.sub str i (j - i)) in 50 50 + img :: split str (j + 1) 51 51 + | exception Not_found -> 52 52 + [ I.string attr (if i = 0 then str else String.sub str i (String.length str - i)) ] 53 53 + in 54 54 + Ui.atom (I.vcat (split str 0)) 55 55 + ;; 56 56 + 57 57 + (** Ui element from an int *) 58 58 + let int ?attr x = string ?attr (string_of_int x) 59 59 + 60 60 + (** Ui element from a boolean *) 61 61 + let bool ?attr x = string ?attr (string_of_bool x) 62 62 + 63 63 + (** Ui element from a float *) 64 64 + let float_ ?attr x = string ?attr (string_of_float x) 65 65 + 66 66 + (** Printf support *) 67 67 + let printf ?attr fmt = Printf.ksprintf (string ?attr) fmt 68 68 + 69 69 + (** asprintf support *) 70 70 + let fmt ?attr fmt = Format.kasprintf (string ?attr) fmt 71 71 + 72 72 + (** Printf support *) 73 73 + let kprintf k ?attr fmt = Printf.ksprintf (fun str -> k (string ?attr str)) fmt 74 74 + 75 75 + (** Printf support *) 76 76 + let kfmt k ?attr fmt = Format.kasprintf (fun str -> k (string ?attr str)) fmt 77 77 + 78 78 + (**A size sensor that automatically updates the size variable*) 79 79 + let simpleSizeSensor ~size_var ui = 80 80 + ui 81 81 + |> Ui.size_sensor (fun ~w ~h -> 82 82 + if Lwd.peek size_var <> (w, h) then Lwd.set size_var (w, h)) 83 83 + ;; 84 84 + 85 85 + (** A simple un_navigateable input field that only allows typing and deleting content. Try using edit_field for something that allows navigating within the text*) 86 86 + let input_field ?(focus = Focus.make ()) start_state ~on_change ~on_submit = 87 87 + let update focus_h focus text = 88 88 + let content = 89 89 + Ui.atom @@ I.hcat [ I.string A.(st underline) (if text = "" then " " else text) ] 90 90 + in 91 91 + let handler = function 92 92 + | `ASCII 'U', [ `Ctrl ] -> 93 93 + on_change ""; 94 94 + `Handled (* clear *) 95 95 + | `Escape, [] -> 96 96 + Focus.release focus_h; 97 97 + `Handled 98 98 + | `ASCII k, _ -> 99 99 + let text = text ^ String.make 1 k in 100 100 + on_change text; 101 101 + `Handled 102 102 + | `Backspace, _ -> 103 103 + let text = 104 104 + if text |> String.length > 0 105 105 + then String.sub text 0 (String.length text - 1) 106 106 + else text 107 107 + in 108 108 + on_change text; 109 109 + `Handled 110 110 + | `Enter, _ -> 111 111 + on_submit text; 112 112 + `Handled 113 113 + | _ -> 114 114 + `Unhandled 115 115 + in 116 116 + Ui.keyboard_area ~focus handler content 117 117 + in 118 118 + let node = Lwd.map2 ~f:(update focus) (Focus.status focus) start_state in 119 119 + node 120 120 + ;; 121 121 + 122 122 + (** Horizontally stacks Ui elements *) 123 123 + let hbox l = Lwd_utils.pack Ui.pack_x l 124 124 + 125 125 + (** Horizontally stacks ui elements *) 126 126 + let vbox l = Lwd_utils.pack Ui.pack_y l 127 127 + 128 128 + (** Stacks Ui elements infront of one another *) 129 129 + let zbox l = Lwd_utils.pack Ui.pack_z l 130 130 + 131 131 + 132 132 + (** Horizontal/vertical box. We fill lines until there is no room, 133 133 + and then go to the next ligne. All widgets in a line are considered to 134 134 + have the same height. 135 135 + @param width dynamic width (default 80) *) 136 136 + let flex_box ?(w = Lwd.return 80) (l : Ui.t Lwd.t list) : Ui.t Lwd.t = 137 137 + let open Lwd.Infix in 138 138 + Lwd_utils.flatten_l l 139 139 + >>= fun l -> 140 140 + w 141 141 + >|= fun w_limit -> 142 142 + let rec box_render (acc : Ui.t) (i : int) l : Ui.t = 143 143 + match l with 144 144 + | [] -> acc 145 145 + | ui0 :: tl -> 146 146 + let w0 = (Ui.layout_spec ui0).Ui.w in 147 147 + if i + w0 >= w_limit 148 148 + then (* newline starting with ui0 *) 149 149 + Ui.join_y acc (box_render ui0 w0 tl) 150 150 + else (* same line *) 151 151 + box_render (Ui.join_x acc ui0) (i + w0) tl 152 152 + in 153 153 + box_render Ui.empty 0 l 154 154 + ;; 155 155 + 156 156 + module List = struct 157 157 + include List 158 158 + 159 159 + (** intersperse elements of the list with items *) 160 160 + let intersperse t ~sep = 161 161 + match t with 162 162 + | [] -> [] 163 163 + | x :: xs -> x :: fold_right (fun y acc -> sep :: y :: acc) xs [] 164 164 + ;; 165 165 + end 166 166 + 167 167 + (** [on_focus f ui] 168 168 + 169 169 + Transforms the Ui with function [f] if the Ui is focused *) 170 170 + let on_ui_focus f ui = if ui |> Ui.has_focus then ui |> f else ui 171 171 + 172 172 + let on_focus ~focus f ui = 173 173 + Lwd.map2 ui (focus |> Focus.status) ~f:(fun ui focus -> 174 174 + if focus |> Focus.has_focus then ui |> f else ui) 175 175 + ;; 176 176 + 177 177 + let is_focused ~focus f ui = 178 178 + Lwd.map2 ui (focus |> Focus.status) ~f:(fun ui focus -> f ui (focus |> Focus.has_focus)) 179 179 + ;; 180 180 +

+190

forks/nottui/lib/nottui/widgets/border_box.ml

reviewed

··· 1 1 + (** Border box. Surrounds a Ui element in a border that can have labels, or appear when focused *) 2 2 + 3 3 + open Notty 4 4 + open Nottui_main 5 5 + open Lwd_infix 6 6 + 7 7 + (*------ Internal/Private----*) 8 8 + module Internal = struct 9 9 + let neutral_grav = Gravity.make ~h:`Neutral ~v:`Neutral 10 10 + 11 11 + module W = Nottui_widgets 12 12 + 13 13 + (** Truncate a string to a given length, adding an ellipsis if truncated. *) 14 14 + let truncate_string len str = 15 15 + if String.length str > len 16 16 + then if len <= 3 then "" else String.sub str 0 (len - 3) ^ "..." 17 17 + else str 18 18 + ;; 19 19 + 20 20 + (** top border*) 21 21 + let outline_top attr w label = 22 22 + let chr x = I.uchar attr (Uchar.of_int x) 1 1 in 23 23 + let hbar = I.uchar attr (Uchar.of_int 0x2500) w 1 24 24 + and label = if label |> I.width > w - 2 then I.empty else label |> I.hpad 2 0 25 25 + and a, b = chr 0x256d, chr 0x256e in 26 26 + I.zcat [ label; I.hcat [ a; hbar; b ]; label ] 27 27 + ;; 28 28 + 29 29 + (** bottom border*) 30 30 + let outline_bot attr w label = 31 31 + let chr x = I.uchar attr (Uchar.of_int x) 1 1 in 32 32 + let hbar = I.uchar attr (Uchar.of_int 0x2500) w 1 in 33 33 + let label = 34 34 + if label |> I.width > w - 2 35 35 + then I.empty 36 36 + else label |> I.hpad (w - (label |> I.width |> ( + ) 1)) 0 37 37 + in 38 38 + let c, d = chr 0x256f, chr 0x2570 in 39 39 + I.zcat [ label; I.hcat [ d; hbar; c ] ] 40 40 + ;; 41 41 + 42 42 + let make_label max_width label_str = 43 43 + I.strf " %s " (truncate_string (max_width - 2) label_str) 44 44 + ;; 45 45 + 46 46 + (** Internal function for rendering a border box with known dimensions and padding.*) 47 47 + let border_box_intern 48 48 + ?(border_attr = A.empty) 49 49 + ?(label_top = I.empty) 50 50 + ?(label_bottom = I.empty) 51 51 + ~w 52 52 + ~h 53 53 + ~pad 54 54 + ~pad_w 55 55 + ~pad_h 56 56 + input 57 57 + = 58 58 + (*can't go below 1 internal width or things get weird*) 59 59 + let h = if pad_h < 1 then Int.max h 1 else h in 60 60 + let w = if pad_w < 1 then Int.max w 1 else w in 61 61 + (* this is a weird quirk, but we have to be careful of runaway size expansion. 62 62 + If we increase the width of the space by making the vbar longer than the input ui element it will be able to expand to fill that space. 63 63 + That will then increase the vbar and increase the height etc etc untill the max height is reached*) 64 64 + let vbar = 65 65 + I.uchar border_attr (Uchar.of_int 0x2502) 1 (h + (pad_h * 2)) 66 66 + |> Ui.atom 67 67 + |> Ui.resize ~h:0 68 68 + in 69 69 + Ui.vcat 70 70 + [ outline_top border_attr w label_top |> Ui.atom |> Ui.resize ~w:0 71 71 + ; Ui.hcat 72 72 + [ vbar 73 73 + ; I.void pad_w 1 |> Ui.atom 74 74 + ; Ui.vcat 75 75 + [ I.void 1 pad_h |> Ui.atom 76 76 + ; input |> Ui.resize ~pad 77 77 + ; I.void 1 pad_h |> Ui.atom 78 78 + ] 79 79 + ; I.void pad_w 1 |> Ui.atom 80 80 + ; vbar 81 81 + ] 82 82 + ; outline_bot border_attr w label_bottom |> Ui.atom |> Ui.resize ~w:0 83 83 + ] 84 84 + ;; 85 85 + end 86 86 + 87 87 + open Internal 88 88 + 89 89 + let with_border_attr 90 90 + ?(pad = neutral_grav) 91 91 + ?(pad_w = 2) 92 92 + ?(pad_h = 1) 93 93 + ?label_top 94 94 + ?label_bottom 95 95 + get_border 96 96 + input 97 97 + = 98 98 + let size = Lwd.var (0, 0) in 99 99 + let layout_width = Lwd.var 0 in 100 100 + let input = 101 101 + let$ input = input in 102 102 + (*We need this later to determine the max with*) 103 103 + layout_width $= (input |> Ui.layout_width); 104 104 + input 105 105 + (*This lets us tell the input to be a flexible size*) 106 106 + |> Ui.size_sensor (fun ~w ~h -> if Lwd.peek size <> (w, h) then Lwd.set size (w, h)) 107 107 + in 108 108 + (*This is original width and height of the input before padding or anything *) 109 109 + let$ o_w, o_h = Lwd.get size 110 110 + and$ input = input 111 111 + and$ border_attr = get_border in 112 112 + let w, h = o_w + (pad_w * 2), o_h in 113 113 + let h = h in 114 114 + let bbox = 115 115 + border_box_intern 116 116 + ~border_attr 117 117 + ?label_top:(label_top |> Option.map (make_label (w - 2))) 118 118 + ?label_bottom:(label_bottom |> Option.map (make_label (w - 2))) 119 119 + (* ~label_bottom:(if has_focus then I.strf "focused" else I.strf "unfocused") *) 120 120 + ~w 121 121 + ~h 122 122 + ~pad 123 123 + ~pad_w 124 124 + ~pad_h 125 125 + input 126 126 + in 127 127 + (*If we want the input to be shrinkable we make it expandable, set it's width to something small and then set a max width for the whole box*) 128 128 + bbox 129 129 + ;; 130 130 + 131 131 + let focusable 132 132 + ?pad 133 133 + ?pad_w 134 134 + ?pad_h 135 135 + ?label_top 136 136 + ?label_bottom 137 137 + ?(border_attr = A.empty) 138 138 + ?(focus_attr = A.fg A.blue) 139 139 + ?(focus = Focus.make ()) 140 140 + ?(on_key = fun _ -> `Unhandled) 141 141 + input 142 142 + = 143 143 + let input = 144 144 + input 145 145 + |> Lwd.map2 (focus |> Focus.status) ~f:(fun focus ui -> 146 146 + ui |> Ui.keyboard_area ~focus on_key) 147 147 + in 148 148 + with_border_attr 149 149 + ?pad 150 150 + ?pad_w 151 151 + ?pad_h 152 152 + ?label_top 153 153 + ?label_bottom 154 154 + (let$ focus = Focus.status focus in 155 155 + if Focus.has_focus focus then focus_attr else border_attr) 156 156 + input 157 157 + ;; 158 158 + 159 159 + let box ?pad ?pad_w ?pad_h ?label_top ?label_bottom ?(border_attr = A.empty) input = 160 160 + with_border_attr 161 161 + ?pad 162 162 + ?pad_w 163 163 + ?pad_h 164 164 + ?label_top 165 165 + ?label_bottom 166 166 + (border_attr |> Lwd.pure) 167 167 + input 168 168 + ;; 169 169 + 170 170 + let static 171 171 + ?(pad = neutral_grav) 172 172 + ?(pad_w = 2) 173 173 + ?(pad_h = 1) 174 174 + ?label_top 175 175 + ?label_bottom 176 176 + ?(border_attr = A.empty) 177 177 + ui 178 178 + = 179 179 + let Ui.{ w; h; _ } = Ui.layout_spec ui in 180 180 + Internal.border_box_intern 181 181 + ~w 182 182 + ~h 183 183 + ~pad 184 184 + ~pad_w 185 185 + ~pad_h 186 186 + ?label_top 187 187 + ?label_bottom 188 188 + ~border_attr 189 189 + ui 190 190 + ;;

+84

forks/nottui/lib/nottui/widgets/border_box.mli

reviewed

··· 1 1 + (** A border box that allows setting the border style from an [Lwd.t] prefer [Border_box.focusable] or [Border_box.box] unless you need this *) 2 2 + val with_border_attr 3 3 + : ?pad:Nottui_main.gravity 4 4 + -> ?pad_w:int 5 5 + -> ?pad_h:int 6 6 + -> ?label_top:string 7 7 + -> ?label_bottom:string 8 8 + -> Notty.attr Lwd.t 9 9 + -> Nottui_main.ui Lwd.t 10 10 + -> Nottui_main.ui Lwd.t 11 11 + 12 12 + (** Creates a bordered box around the given [input] widget. This box will change colour when focused 13 13 + 14 14 + @param scaling 15 15 + Controls how the input widget is sized within the border box. Can be: 16 16 + - [`Static] - The input widget is not resized. 17 17 + - [`Expand sw] - The input widget is allowed to expand to fill the available space, with a stretch width [sw]. 18 18 + - [`Shrinkable (min_width, sw)] - The input widget is allowed to shrink to a minimum width of [min_width], and expand with a stretch width [sw]. 19 19 + @param pad The padding around the input widget within the border box. 20 20 + @param pad_w The horizontal padding around the input widget. 21 21 + @param pad_h The vertical padding around the input widget. 22 22 + @param label An optional label to display within the border box. 23 23 + @param input The input widget to be bordered. 24 24 + @param border_attr Style for the border, defaults to [A.empty]. 25 25 + @param focus Focus handle for the box . 26 26 + @param focus_attr Style for the border when focused, defaults to [A.fg A.blue]. 27 27 + @param on_key 28 28 + Callback called when a key is pressed while the box is focused. Useful for performing actions when the box is selected . *) 29 29 + val focusable 30 30 + : ?pad:Nottui_main.gravity 31 31 + -> ?pad_w:int 32 32 + -> ?pad_h:int 33 33 + -> ?label_top:string 34 34 + -> ?label_bottom:string 35 35 + -> ?border_attr:Notty.attr 36 36 + -> ?focus_attr:Notty.attr 37 37 + -> ?focus:Nottui_main.Focus.handle 38 38 + -> ?on_key:(Nottui_main.Ui.key -> Nottui_main.Ui.may_handle) 39 39 + -> Nottui_main.ui Lwd.t 40 40 + -> Nottui_main.ui Lwd.t 41 41 + 42 42 + (** Creates a bordered box around the given [input] widget. 43 43 + @param scaling 44 44 + Controls how the input widget is sized within the border box. Can be: 45 45 + - [`Static] - The input widget is not resized. 46 46 + - [`Expand sw] - The input widget is allowed to expand to fill the available space, with a stretch width [sw]. 47 47 + - [`Shrinkable (min_width, sw)] - The input widget is allowed to shrink to a minimum width of [min_width], and expand with a stretch width [sw]. 48 48 + @param pad The padding around the input widget within the border box. 49 49 + @param pad_w The horizontal padding around the input widget. 50 50 + @param pad_h The vertical padding around the input widget. 51 51 + @param label An optional label to display within the border box. 52 52 + @param input The input widget to be bordered. 53 53 + @param border_attr Style for the border, defaults to [A.empty]. *) 54 54 + val box 55 55 + : ?pad:Nottui_main.gravity 56 56 + -> ?pad_w:int 57 57 + -> ?pad_h:int 58 58 + -> ?label_top:string 59 59 + -> ?label_bottom:string 60 60 + -> ?border_attr:Notty.attr 61 61 + -> Nottui_main.ui Lwd.t 62 62 + -> Nottui_main.ui Lwd.t 63 63 + 64 64 + (** Creates a bordered box around the given [input]. The input must have a static sive ans this doesn't adjust the s . 65 65 + @param scaling 66 66 + Controls how the input widget is sized within the border box. Can be: 67 67 + - [`Static] - The input widget is not resized. 68 68 + - [`Expand sw] - The input widget is allowed to expand to fill the available space, with a stretch width [sw]. 69 69 + - [`Shrinkable (min_width, sw)] - The input widget is allowed to shrink to a minimum width of [min_width], and expand with a stretch width [sw]. 70 70 + @param pad The padding around the input widget within the border box. 71 71 + @param pad_w The horizontal padding around the input widget. 72 72 + @param pad_h The vertical padding around the input widget. 73 73 + @param label An optional label to display within the border box. 74 74 + @param input The input widget to be bordered. 75 75 + @param border_attr Style for the border, defaults to [A.empty]. *) 76 76 + val static 77 77 + : ?pad:Nottui_main.gravity 78 78 + -> ?pad_w:int 79 79 + -> ?pad_h:int 80 80 + -> ?label_top:Notty.image 81 81 + -> ?label_bottom:Notty.image 82 82 + -> ?border_attr:Notty.attr 83 83 + -> Nottui_main.ui 84 84 + -> Nottui_main.ui

+37

forks/nottui/lib/nottui/widgets/lists.ml

reviewed

··· 1 1 + open Nottui_main 2 2 + open Shared 3 3 + open Lwd_infix 4 4 + 5 5 + let vlist ?(bullet = "- ") (l : Ui.t Lwd.t list) : Ui.t Lwd.t = 6 6 + l 7 7 + |> List.map (fun ui -> Lwd.map ~f:(Ui.join_x (string bullet)) ui) 8 8 + |> Lwd_utils.pack Ui.pack_y 9 9 + ;; 10 10 + 11 11 + let vlist_with 12 12 + ?(bullet = "- ") 13 13 + ?(filter = Lwd.return (fun _ -> true)) 14 14 + (f : 'a -> Ui.t Lwd.t) 15 15 + (l : 'a list Lwd.t) 16 16 + : Ui.t Lwd.t 17 17 + = 18 18 + let open Lwd.Infix in 19 19 + let rec filter_map_ acc f l = 20 20 + match l with 21 21 + | [] -> List.rev acc 22 22 + | x :: l' -> 23 23 + let acc' = 24 24 + match f x with 25 25 + | None -> acc 26 26 + | Some y -> y :: acc 27 27 + in 28 28 + filter_map_ acc' f l' 29 29 + in 30 30 + let l = l |>$ List.map (fun x -> x, Lwd.map ~f:(Ui.join_x (string bullet)) @@ f x) in 31 31 + let l_filter : _ list Lwd.t = 32 32 + filter 33 33 + >>= fun filter -> 34 34 + l >|= filter_map_ [] (fun (x, ui) -> if filter x then Some ui else None) 35 35 + in 36 36 + l_filter >>= vbox 37 37 + ;;

+12

forks/nottui/lib/nottui/widgets/lists.mli

reviewed

··· 1 1 + (** Displays a list of ui items. 2 2 + If you want the items to be selectable, look at [selection_list] *) 3 3 + val vlist : ?bullet:string -> Nottui_main.ui Lwd.t list -> Nottui_main.ui Lwd.t 4 4 + 5 5 + (** Displays a list of something that can be transformed into ui can be filtered. 6 6 + Simmilar to selection_list_filterable *) 7 7 + val vlist_with 8 8 + : ?bullet:string 9 9 + -> ?filter:('a -> bool) Lwd.t 10 10 + -> ('a -> Nottui_main.ui Lwd.t) 11 11 + -> 'a list Lwd.t 12 12 + -> Nottui_main.ui Lwd.t

+360

forks/nottui/lib/nottui/widgets/nottui_widgets.ml

reviewed

··· 1 1 + open Lwd.Infix 2 2 + 3 3 + open Notty 4 4 + open Nottui_main 5 5 + include Shared 6 6 + 7 7 + (**Original widgets that came with*) 8 8 + 9 9 + type pane_state = 10 10 + | Split of 11 11 + { pos : int 12 12 + ; max : int 13 13 + } 14 14 + | Re_split of 15 15 + { pos : int 16 16 + ; max : int 17 17 + ; at : int 18 18 + } 19 19 + 20 20 + let h_pane ?(splitter_color = A.lightyellow) left right = 21 21 + let state_var = Lwd.var (Split { pos = 5; max = 10 }) in 22 22 + let render state (l, r) = 23 23 + let (Split { pos; max } | Re_split { pos; max; _ }) = state in 24 24 + (*make sure the panes can get infinetly wide and shrink infinitely small*) 25 25 + let l = Ui.resize ~w:0 ~h:0 ~sh:1 ~sw:pos ~mw:1000 ~mh:1000 l in 26 26 + let r = Ui.resize ~w:0 ~h:0 ~sh:1 ~sw:(max - pos) ~mw:1000 ~mh:1000 r in 27 27 + let splitter = 28 28 + Ui.resize ~bg:Notty.A.(bg splitter_color) ~w:1 ~h:0 ~sw:0 ~sh:1 Ui.empty 29 29 + in 30 30 + let splitter = 31 31 + Ui.mouse_area 32 32 + (fun ~x:_ ~y:_ -> function 33 33 + | `Left -> 34 34 + `Grab 35 35 + ( (fun ~x ~y:_ -> 36 36 + match Lwd.peek state_var with 37 37 + | Split { pos; max } -> 38 38 + Lwd.set state_var (Re_split { pos; max; at = x }) 39 39 + | Re_split { pos; max; at } -> 40 40 + if at <> x then Lwd.set state_var (Re_split { pos; max; at = x })) 41 41 + , fun ~x:_ ~y:_ -> () ) 42 42 + | _ -> `Unhandled) 43 43 + splitter 44 44 + in 45 45 + let ui = Ui.join_x l (Ui.join_x splitter r) in 46 46 + let ui = Ui.resize ~w:10 ~h:10 ~sw:1 ~sh:1 ~mh:1000 ~mw:1000 ui in 47 47 + let ui = 48 48 + match state with 49 49 + | Split _ -> ui 50 50 + | Re_split { at; _ } -> 51 51 + Ui.transient_sensor 52 52 + (fun ~x ~y:_ ~w ~h:_ () -> 53 53 + let newpos = clampi (at - x) ~min:0 ~max:w in 54 54 + Lwd.set state_var (Split { pos = newpos; max = w })) 55 55 + ui 56 56 + in 57 57 + ui 58 58 + in 59 59 + Lwd.map2 ~f:render (Lwd.get state_var) (Lwd.pair left right) 60 60 + ;; 61 61 + 62 62 + let v_pane top bot = 63 63 + let state_var = Lwd.var (Split { pos = 5; max = 10 }) in 64 64 + let render state (top, bot) = 65 65 + let (Split { pos; max } | Re_split { pos; max; _ }) = state in 66 66 + let top = Ui.resize ~w:0 ~h:0 ~sw:1 ~sh:pos top in 67 67 + let bot = Ui.resize ~w:0 ~h:0 ~sw:1 ~sh:(max - pos) bot in 68 68 + let splitter = 69 69 + Ui.resize ~bg:Notty.A.(bg lightyellow) ~w:0 ~h:1 ~sw:1 ~sh:0 Ui.empty 70 70 + in 71 71 + let splitter = 72 72 + Ui.mouse_area 73 73 + (fun ~x:_ ~y:_ -> function 74 74 + | `Left -> 75 75 + `Grab 76 76 + ( (fun ~x:_ ~y -> 77 77 + match Lwd.peek state_var with 78 78 + | Split { pos; max } -> 79 79 + Lwd.set state_var (Re_split { pos; max; at = y }) 80 80 + | Re_split { pos; max; at } -> 81 81 + if at <> y then Lwd.set state_var (Re_split { pos; max; at = y })) 82 82 + , fun ~x:_ ~y:_ -> () ) 83 83 + | _ -> `Unhandled) 84 84 + splitter 85 85 + in 86 86 + let ui = Ui.join_y top (Ui.join_y splitter bot) in 87 87 + let ui = Ui.resize ~w:10 ~h:10 ~sw:1 ~sh:1 ui in 88 88 + let ui = 89 89 + match state with 90 90 + | Split _ -> ui 91 91 + | Re_split { at; _ } -> 92 92 + Ui.transient_sensor 93 93 + (fun ~x:_ ~y ~w:_ ~h () -> 94 94 + let newpos = clampi (at - y) ~min:0 ~max:h in 95 95 + Lwd.set state_var (Split { pos = newpos; max = h })) 96 96 + ui 97 97 + in 98 98 + ui 99 99 + in 100 100 + Lwd.map2 ~f:render (Lwd.get state_var) (Lwd.pair top bot) 101 101 + ;; 102 102 + 103 103 + let sub' str p l = if p = 0 && l = String.length str then str else String.sub str p l 104 104 + 105 105 + let edit_field ?(focus = Focus.make ()) state ~on_change ~on_submit = 106 106 + let update focus_h focus (text, pos) = 107 107 + let pos = clampi pos ~min:0 ~max:(String.length text) in 108 108 + let content = 109 109 + Ui.atom 110 110 + @@ I.hcat 111 111 + @@ 112 112 + if Focus.has_focus focus 113 113 + then ( 114 114 + let attr = attr_clickable in 115 115 + let len = String.length text in 116 116 + (if pos >= len 117 117 + then [ I.string attr text ] 118 118 + else [ I.string attr (sub' text 0 pos) ]) 119 119 + @ 120 120 + if pos < String.length text 121 121 + then 122 122 + [ I.string A.(bg lightred) (sub' text pos 1) 123 123 + ; I.string attr (sub' text (pos + 1) (len - pos - 1)) 124 124 + ] 125 125 + else [ I.string A.(bg lightred) " " ]) 126 126 + else [ I.string A.(st underline) (if text = "" then " " else text) ] 127 127 + in 128 128 + let handler = function 129 129 + | `ASCII 'U', [ `Ctrl ] -> 130 130 + on_change ("", 0); 131 131 + `Handled (* clear *) 132 132 + | `Escape, [] -> 133 133 + Focus.release focus_h; 134 134 + `Handled 135 135 + | `ASCII k, _ -> 136 136 + let text = 137 137 + if pos < String.length text 138 138 + then 139 139 + String.sub text 0 pos 140 140 + ^ String.make 1 k 141 141 + ^ String.sub text pos (String.length text - pos) 142 142 + else text ^ String.make 1 k 143 143 + in 144 144 + on_change (text, pos + 1); 145 145 + `Handled 146 146 + | `Backspace, _ -> 147 147 + let text = 148 148 + if pos > 0 149 149 + then 150 150 + if pos < String.length text 151 151 + then 152 152 + String.sub text 0 (pos - 1) ^ String.sub text pos (String.length text - pos) 153 153 + else if String.length text > 0 154 154 + then String.sub text 0 (String.length text - 1) 155 155 + else text 156 156 + else text 157 157 + in 158 158 + let pos = maxi 0 (pos - 1) in 159 159 + on_change (text, pos); 160 160 + `Handled 161 161 + | `Enter, _ -> 162 162 + on_submit (text, pos); 163 163 + `Handled 164 164 + | `Arrow `Left, [] -> 165 165 + let pos = mini (String.length text) pos in 166 166 + if pos > 0 167 167 + then ( 168 168 + on_change (text, pos - 1); 169 169 + `Handled) 170 170 + else `Unhandled 171 171 + | `Arrow `Right, [] -> 172 172 + let pos = pos + 1 in 173 173 + if pos <= String.length text 174 174 + then ( 175 175 + on_change (text, pos); 176 176 + `Handled) 177 177 + else `Unhandled 178 178 + | _ -> `Unhandled 179 179 + in 180 180 + Ui.keyboard_area ~focus handler content 181 181 + in 182 182 + let node = Lwd.map2 ~f:(update focus) (Focus.status focus) state in 183 183 + let mouse_grab (text, pos) ~x ~y:_ = function 184 184 + | `Left -> 185 185 + if x <> pos then on_change (text, x); 186 186 + Focus.request focus; 187 187 + `Handled 188 188 + | _ -> `Unhandled 189 189 + in 190 190 + Lwd.map2 state node ~f:(fun state content -> Ui.mouse_area (mouse_grab state) content) 191 191 + ;; 192 192 + 193 193 + 194 194 + 195 195 + (** Prints the summary, but calls [f()] to compute a sub-widget 196 196 + when clicked on. Useful for displaying deep trees. Mouse only *) 197 197 + let unfoldable ?(folded_by_default = true) summary (f : unit -> Ui.t Lwd.t) : Ui.t Lwd.t = 198 198 + let open Lwd.Infix in 199 199 + let opened = Lwd.var (not folded_by_default) in 200 200 + let fold_content = 201 201 + Lwd.get opened 202 202 + >>= function 203 203 + | true -> 204 204 + (* call [f] and pad a bit *) 205 205 + f () |> Lwd.map ~f:(Ui.join_x (string " ")) 206 206 + | false -> empty_lwd 207 207 + in 208 208 + (* pad summary with a "> " when it's opened *) 209 209 + let summary = 210 210 + Lwd.get opened 211 211 + >>= fun op -> 212 212 + summary 213 213 + >|= fun s -> 214 214 + Ui.hcat [ string ~attr:attr_clickable (if op then "v" else ">"); string " "; s ] 215 215 + in 216 216 + let cursor ~x:_ ~y:_ = function 217 217 + | `Left when Lwd.peek opened -> 218 218 + Lwd.set opened false; 219 219 + `Handled 220 220 + | `Left -> 221 221 + Lwd.set opened true; 222 222 + `Handled 223 223 + | _ -> `Unhandled 224 224 + in 225 225 + let mouse = Lwd.map ~f:(fun m -> Ui.mouse_area cursor m) summary in 226 226 + Lwd.map2 mouse fold_content ~f:(fun summary fold -> 227 227 + (* TODO: make this configurable/optional *) 228 228 + (* newline if it's too big to fit on one line nicely *) 229 229 + let spec_sum = Ui.layout_spec summary in 230 230 + let spec_fold = Ui.layout_spec fold in 231 231 + (* TODO: somehow, probe for available width here? *) 232 232 + let too_big = 233 233 + spec_fold.Ui.h > 1 || (spec_fold.Ui.h > 0 && spec_sum.Ui.w + spec_fold.Ui.w > 60) 234 234 + in 235 235 + if too_big 236 236 + then Ui.join_y summary (Ui.join_x (string " ") fold) 237 237 + else Ui.join_x summary fold) 238 238 + ;; 239 239 + 240 240 + 241 241 + 242 242 + (** A grid layout, with alignment in all rows/columns. 243 243 + @param max_h maximum height of a cell 244 244 + @param max_w maximum width of a cell 245 245 + @param bg attribute for controlling background style 246 246 + @param h_space horizontal space between each cell in a row 247 247 + @param v_space vertical space between each row 248 248 + @param pad used to control padding of cells 249 249 + @param crop 250 250 + used to control cropping of cells 251 251 + TODO: control padding/alignment, vertically and horizontally 252 252 + TODO: control align left/right in cells 253 253 + TODO: horizontal rule below headers 254 254 + TODO: headers *) 255 255 + let grid 256 256 + ?max_h 257 257 + ?max_w 258 258 + ?pad 259 259 + ?crop 260 260 + ?bg 261 261 + ?(h_space = 0) 262 262 + ?(v_space = 0) 263 263 + ?(headers : Ui.t Lwd.t list option) 264 264 + (rows : Ui.t Lwd.t list list) 265 265 + : Ui.t Lwd.t 266 266 + = 267 267 + let rows = 268 268 + match headers with 269 269 + | None -> rows 270 270 + | Some r -> r :: rows 271 271 + in 272 272 + (* build a [ui list list Lwd.t] *) 273 273 + Lwd_utils.map_l (fun r -> Lwd_utils.flatten_l r) rows 274 274 + >>= fun (rows : Ui.t list list) -> 275 275 + (* determine width of each column and height of each row *) 276 276 + let n_cols = List.fold_left (fun n r -> maxi n (List.length r)) 0 rows in 277 277 + let col_widths = Array.make n_cols 1 in 278 278 + List.iter 279 279 + (fun row -> 280 280 + List.iteri 281 281 + (fun col_j cell -> 282 282 + let w = (Ui.layout_spec cell).Ui.w in 283 283 + col_widths.(col_j) <- maxi col_widths.(col_j) w) 284 284 + row) 285 285 + rows; 286 286 + (match max_w with 287 287 + | None -> () 288 288 + | Some max_w -> 289 289 + (* limit width *) 290 290 + Array.iteri (fun i x -> col_widths.(i) <- mini x max_w) col_widths); 291 291 + (* now render, with some padding *) 292 292 + let pack_pad_x = 293 293 + if h_space <= 0 294 294 + then Ui.empty, Ui.join_x 295 295 + else Ui.empty, fun x y -> Ui.hcat [ x; Ui.space h_space 0; y ] 296 296 + and pack_pad_y = 297 297 + if v_space = 0 298 298 + then Ui.empty, Ui.join_y 299 299 + else Ui.empty, fun x y -> Ui.vcat [ x; Ui.space v_space 0; y ] 300 300 + in 301 301 + let rows = 302 302 + List.map 303 303 + (fun row -> 304 304 + let row_h = List.fold_left (fun n c -> maxi n (Ui.layout_spec c).Ui.h) 0 row in 305 305 + let row_h = 306 306 + match max_h with 307 307 + | None -> row_h 308 308 + | Some max_h -> mini row_h max_h 309 309 + in 310 310 + let row = 311 311 + List.mapi (fun i c -> Ui.resize ~w:col_widths.(i) ~h:row_h ?crop ?pad ?bg c) row 312 312 + in 313 313 + Lwd_utils.reduce pack_pad_x row) 314 314 + rows 315 315 + in 316 316 + (* TODO: mouse and keyboard handling *) 317 317 + let ui = Lwd_utils.reduce pack_pad_y rows in 318 318 + Lwd.return ui 319 319 + ;; 320 320 + 321 321 + (** Turn the given [ui] into a clickable button, calls [f] when clicked. *) 322 322 + let button_of ui f = 323 323 + Ui.mouse_area 324 324 + (fun ~x:_ ~y:_ _ -> 325 325 + f (); 326 326 + `Handled) 327 327 + ui 328 328 + ;; 329 329 + 330 330 + (** A clickable button that calls [f] when clicked, labelled with a string. *) 331 331 + let button ?(attr = attr_clickable) s f = button_of (string ~attr s) f 332 332 + 333 333 + 334 334 + let toggle, toggle' = 335 335 + let toggle_ st (lbl : string Lwd.t) (f : bool -> unit) : Ui.t Lwd.t = 336 336 + let mk_but st_v lbl_v = 337 337 + let lbl = 338 338 + Ui.hcat 339 339 + [ printf "[%s|" lbl_v 340 340 + ; string ~attr:attr_clickable (if st_v then "✔" else "×") 341 341 + ; string "]" 342 342 + ] 343 343 + in 344 344 + button_of lbl (fun () -> 345 345 + let new_st = not st_v in 346 346 + Lwd.set st new_st; 347 347 + f new_st) 348 348 + in 349 349 + Lwd.map2 ~f:mk_but (Lwd.get st) lbl 350 350 + in 351 351 + (* Similar to {!toggle}, except it directly reflects the state of a variable. *) 352 352 + let toggle' (lbl : string Lwd.t) (v : bool Lwd.var) : Ui.t Lwd.t = 353 353 + toggle_ v lbl (Lwd.set v) 354 354 + (* a toggle, with a true/false state *) 355 355 + and toggle ?(init = false) (lbl : string Lwd.t) (f : bool -> unit) : Ui.t Lwd.t = 356 356 + let st = Lwd.var init in 357 357 + toggle_ st lbl f 358 358 + in 359 359 + toggle, toggle' 360 360 + ;;

+44

forks/nottui/lib/nottui/widgets/nottui_widgets.mli

reviewed

··· 1 1 + open Notty 2 2 + open Nottui_main 3 3 + include module type of Shared 4 4 + val empty_lwd : ui Lwd.t 5 5 + 6 6 + 7 7 + (** Vertical pane that can be dragged to be bigger or smaller *) 8 8 + val v_pane : ui Lwd.t -> ui Lwd.t -> ui Lwd.t 9 9 + 10 10 + (** horizontal pane that can be dragged to be bigger or smaller *) 11 11 + val h_pane : ?splitter_color:(Notty.A.color)-> ui Lwd.t -> ui Lwd.t -> ui Lwd.t 12 12 + 13 13 + 14 14 + (** An editable text field. 15 15 + Supports navigating with arrow keys *) 16 16 + val edit_field : 17 17 + ?focus:Focus.handle -> 18 18 + (string * int) Lwd.t -> 19 19 + on_change:(string * int -> unit) -> 20 20 + on_submit:(string * int -> unit) -> ui Lwd.t 21 21 + 22 22 + 23 23 + (** Shows the summary when folded, calls [f()] to compute a sub-widget when clicked on. Useful for displaying deep trees. Mouse only *) 24 24 + val unfoldable : 25 25 + ?folded_by_default:bool -> 26 26 + ui Lwd.t -> (unit -> ui Lwd.t) -> ui Lwd.t 27 27 + 28 28 + 29 29 + val grid : 30 30 + ?max_h:int -> ?max_w:int -> 31 31 + ?pad:gravity -> ?crop:gravity -> ?bg:attr -> 32 32 + ?h_space:int -> ?v_space:int -> 33 33 + ?headers:ui Lwd.t list -> 34 34 + ui Lwd.t list list -> ui Lwd.t 35 35 + 36 36 + (** A clickable button that calls [f] when clicked, labelled with a string. *) 37 37 + val button : ?attr:attr -> string -> (unit -> unit) -> ui 38 38 + 39 39 + 40 40 + (** A toggle button that invokes the callback when toggled*) 41 41 + val toggle : ?init:bool -> string Lwd.t -> (bool -> unit) -> ui Lwd.t 42 42 + 43 43 + (** A toggle button that changes the state of the Lwd.var when toggled*) 44 44 + val toggle' : string Lwd.t -> bool Lwd.var -> ui Lwd.t

+328

forks/nottui/lib/nottui/widgets/old.ml

reviewed

··· 1 1 + open Notty 2 2 + open Nottui_main 3 3 + open Nottui_widgets 4 4 + open Lists 5 5 + 6 6 + (** 7 7 + All these widgets I keep around becasue they were in nottui, but I am not personally using them and can't speak to their quality or stablity 8 8 + *) 9 9 + 10 10 + let attr_menu_main = A.(bg green ++ fg black) 11 11 + let attr_menu_sub = A.(bg lightgreen ++ fg black) 12 12 + 13 13 + type window_manager = 14 14 + { overlays : ui Lwd.t Lwd_table.t 15 15 + ; view : ui Lwd.t 16 16 + } 17 17 + 18 18 + let window_manager base = 19 19 + let overlays = Lwd_table.make () in 20 20 + let composition = 21 21 + Lwd.join (Lwd_table.reduce (Lwd_utils.lift_monoid Ui.pack_z) overlays) 22 22 + in 23 23 + let view = 24 24 + Lwd.map2 base composition ~f:(fun base composite -> 25 25 + Ui.join_z base (Ui.resize_to (Ui.layout_spec base) composite)) 26 26 + in 27 27 + { overlays; view } 28 28 + ;; 29 29 + 30 30 + let window_manager_view wm = wm.view 31 31 + let window_manager_overlays wm = wm.overlays 32 32 + 33 33 + let menu_overlay wm g ?(dx = 0) ?(dy = 0) body around = 34 34 + let sensor ~x ~y ~w ~h () = 35 35 + let row = Lwd_table.append (window_manager_overlays wm) in 36 36 + let h_pad = 37 37 + match Gravity.h g with 38 38 + | `Negative -> Ui.space (x + dx) 0 39 39 + | `Neutral -> Ui.space (x + dx + (w / 2)) 0 40 40 + | `Positive -> Ui.space (x + dx + w) 0 41 41 + in 42 42 + let v_pad = 43 43 + match Gravity.v g with 44 44 + | `Negative -> Ui.space 0 (y + dy) 45 45 + | `Neutral -> Ui.space 0 (y + dy + (h / 2)) 46 46 + | `Positive -> Ui.space 0 (y + dy + h) 47 47 + in 48 48 + let view = 49 49 + Lwd.map body ~f:(fun body -> 50 50 + let body = 51 51 + let pad = Ui.space 1 0 in 52 52 + Ui.join_x pad (Ui.join_x body pad) 53 53 + in 54 54 + let bg = Ui.resize_to (Ui.layout_spec body) ~bg:A.(bg lightgreen) Ui.empty in 55 55 + let catchall = 56 56 + Ui.mouse_area 57 57 + (fun ~x:_ ~y:_ -> function 58 58 + | `Left -> 59 59 + Lwd_table.remove row; 60 60 + `Handled 61 61 + | _ -> `Handled) 62 62 + (Ui.resize ~sw:1 ~sh:1 ~mw:1000 ~mh:1000 Ui.empty) 63 63 + in 64 64 + Ui.join_z catchall @@ Ui.join_y v_pad @@ Ui.join_x h_pad @@ Ui.join_z bg body) 65 65 + in 66 66 + Lwd_table.set row view 67 67 + in 68 68 + Ui.transient_sensor sensor around 69 69 + ;; 70 70 + 71 71 + let main_menu_item wm text f = 72 72 + let text = string ~attr:attr_menu_main (" " ^ text ^ " ") in 73 73 + let refresh = Lwd.var () in 74 74 + let overlay = ref false in 75 75 + let on_click ~x:_ ~y:_ = function 76 76 + | `Left -> 77 77 + overlay := true; 78 78 + Lwd.set refresh (); 79 79 + `Handled 80 80 + | _ -> `Unhandled 81 81 + in 82 82 + Lwd.map (Lwd.get refresh) ~f:(fun () -> 83 83 + let ui = Ui.mouse_area on_click text in 84 84 + if !overlay 85 85 + then ( 86 86 + overlay := false; 87 87 + menu_overlay wm (Gravity.make ~h:`Negative ~v:`Positive) (f ()) ui) 88 88 + else ui) 89 89 + ;; 90 90 + 91 91 + let sub_menu_item wm text f = 92 92 + let text = string ~attr:attr_menu_sub text in 93 93 + let refresh = Lwd.var () in 94 94 + let overlay = ref false in 95 95 + let on_click ~x:_ ~y:_ = function 96 96 + | `Left -> 97 97 + overlay := true; 98 98 + Lwd.set refresh (); 99 99 + `Handled 100 100 + | _ -> `Unhandled 101 101 + in 102 102 + Lwd.map (Lwd.get refresh) ~f:(fun () -> 103 103 + let ui = Ui.mouse_area on_click text in 104 104 + if !overlay 105 105 + then ( 106 106 + overlay := false; 107 107 + menu_overlay wm (Gravity.make ~h:`Positive ~v:`Negative) (f ()) ui) 108 108 + else ui) 109 109 + ;; 110 110 + 111 111 + let sub_entry text f = 112 112 + let text = string ~attr:attr_menu_sub text in 113 113 + let on_click ~x:_ ~y:_ = function 114 114 + | `Left -> 115 115 + f (); 116 116 + `Handled 117 117 + | _ -> `Unhandled 118 118 + in 119 119 + Ui.mouse_area on_click text 120 120 + ;; 121 121 + 122 122 + (*------- scrolling------*) 123 123 + 124 124 + type scrollbox_state = 125 125 + { w : int 126 126 + ; h : int 127 127 + ; x : int 128 128 + ; y : int 129 129 + } 130 130 + 131 131 + let adjust_offset visible total off = 132 132 + let off = if off + visible > total then total - visible else off in 133 133 + let off = if off < 0 then 0 else off in 134 134 + off 135 135 + ;; 136 136 + 137 137 + let decr_if x cond = if cond then x - 1 else x 138 138 + let scrollbar_bg = Notty.A.gray 4 139 139 + let scrollbar_fg = Notty.A.gray 7 140 140 + let scrollbar_click_step = 3 (* Clicking scrolls one third of the screen *) 141 141 + let scrollbar_wheel_step = 8 (* Wheel event scrolls 1/8th of the screen *) 142 142 + 143 143 + let hscrollbar visible total offset ~set = 144 144 + let prefix = offset * visible / total in 145 145 + let suffix = (total - offset - visible) * visible / total in 146 146 + let handle = visible - prefix - suffix in 147 147 + let render size color = Ui.atom Notty.(I.char (A.bg color) ' ' size 1) in 148 148 + let mouse_handler ~x ~y:_ = function 149 149 + | `Left -> 150 150 + if x < prefix 151 151 + then ( 152 152 + set (offset - maxi 1 (visible / scrollbar_click_step)); 153 153 + `Handled) 154 154 + else if x > prefix + handle 155 155 + then ( 156 156 + set (offset + maxi 1 (visible / scrollbar_click_step)); 157 157 + `Handled) 158 158 + else 159 159 + `Grab 160 160 + ( (fun ~x:x' ~y:_ -> set (offset + ((x' - x) * total / visible))) 161 161 + , fun ~x:_ ~y:_ -> () ) 162 162 + | `Scroll dir -> 163 163 + let dir = 164 164 + match dir with 165 165 + | `Down -> 1 166 166 + | `Up -> -1 167 167 + in 168 168 + set (offset + (dir * maxi 1 (visible / scrollbar_wheel_step))); 169 169 + `Handled 170 170 + | _ -> `Unhandled 171 171 + in 172 172 + let ( ++ ) = Ui.join_x in 173 173 + Ui.mouse_area 174 174 + mouse_handler 175 175 + (render prefix scrollbar_bg 176 176 + ++ render handle scrollbar_fg 177 177 + ++ render suffix scrollbar_bg) 178 178 + ;; 179 179 + 180 180 + let vscrollbar visible total offset ~set = 181 181 + let prefix = offset * visible / total in 182 182 + let suffix = (total - offset - visible) * visible / total in 183 183 + let handle = visible - prefix - suffix in 184 184 + let render size color = Ui.atom Notty.(I.char (A.bg color) ' ' 1 size) in 185 185 + let mouse_handler ~x:_ ~y = function 186 186 + | `Left -> 187 187 + if y < prefix 188 188 + then ( 189 189 + set (offset - maxi 1 (visible / scrollbar_click_step)); 190 190 + `Handled) 191 191 + else if y > prefix + handle 192 192 + then ( 193 193 + set (offset + maxi 1 (visible / scrollbar_click_step)); 194 194 + `Handled) 195 195 + else 196 196 + `Grab 197 197 + ( (fun ~x:_ ~y:y' -> set (offset + ((y' - y) * total / visible))) 198 198 + , fun ~x:_ ~y:_ -> () ) 199 199 + | `Scroll dir -> 200 200 + let dir = 201 201 + match dir with 202 202 + | `Down -> 1 203 203 + | `Up -> -1 204 204 + in 205 205 + set (offset + (dir * maxi 1 (visible / scrollbar_wheel_step))); 206 206 + `Handled 207 207 + | _ -> `Unhandled 208 208 + in 209 209 + let ( ++ ) = Ui.join_y in 210 210 + Ui.mouse_area 211 211 + mouse_handler 212 212 + (render prefix scrollbar_bg 213 213 + ++ render handle scrollbar_fg 214 214 + ++ render suffix scrollbar_bg) 215 215 + ;; 216 216 + 217 217 + let scrollbox t = 218 218 + (* Keep track of scroll state *) 219 219 + let state_var = Lwd.var { w = 0; h = 0; x = 0; y = 0 } in 220 220 + (* Keep track of size available for display *) 221 221 + let update_size ~w ~h = 222 222 + let state = Lwd.peek state_var in 223 223 + if state.w <> w || state.h <> h then Lwd.set state_var { state with w; h } 224 224 + in 225 225 + let measure_size body = 226 226 + Ui.size_sensor update_size (Ui.resize ~w:0 ~h:0 ~sw:1 ~sh:1 body) 227 227 + in 228 228 + (* Given body and state, composite scroll bars *) 229 229 + let compose_bars body state = 230 230 + let bw, bh = Ui.layout_width body, Ui.layout_height body in 231 231 + (* Logic to determine which scroll bar should be visible *) 232 232 + let hvisible = state.w < bw 233 233 + and vvisible = state.h < bh in 234 234 + let hvisible = hvisible || (vvisible && state.w = bw) in 235 235 + let vvisible = vvisible || (hvisible && state.h = bh) in 236 236 + (* Compute size and offsets based on visibility *) 237 237 + let state_w = decr_if state.w vvisible in 238 238 + let state_h = decr_if state.h hvisible in 239 239 + let state_x = adjust_offset state_w bw state.x in 240 240 + let state_y = adjust_offset state_h bh state.y in 241 241 + (* Composite visible scroll bars *) 242 242 + let crop b = Ui.resize ~sw:1 ~sh:1 ~w:0 ~h:0 (Ui.shift_area state_x state_y b) in 243 243 + let set_vscroll y = 244 244 + let state = Lwd.peek state_var in 245 245 + if state.y <> y then Lwd.set state_var { state with y } 246 246 + in 247 247 + let set_hscroll x = 248 248 + let state = Lwd.peek state_var in 249 249 + if state.x <> x then Lwd.set state_var { state with x } 250 250 + in 251 251 + let ( <-> ) = Ui.join_y 252 252 + and ( <|> ) = Ui.join_x in 253 253 + match hvisible, vvisible with 254 254 + | false, false -> body 255 255 + | false, true -> crop body <|> vscrollbar state_h bh state_y ~set:set_vscroll 256 256 + | true, false -> crop body <-> hscrollbar state_w bw state_x ~set:set_hscroll 257 257 + | true, true -> 258 258 + crop body 259 259 + <|> vscrollbar state_h bh state_y ~set:set_vscroll 260 260 + <-> (hscrollbar state_w bw state_x ~set:set_hscroll <|> Ui.space 1 1) 261 261 + in 262 262 + (* Render final box *) 263 263 + Lwd.map2 t (Lwd.get state_var) ~f:(fun ui size -> measure_size (compose_bars ui size)) 264 264 + ;; 265 265 + 266 266 + (** A mouse_based file selection widget that opens at the current path *) 267 267 + let file_select ?(abs = false) ?filter ~(on_select : string -> unit) () : Ui.t Lwd.t = 268 268 + let rec aux ~fold path = 269 269 + try 270 270 + let p_rel = if path = "" then "." else path in 271 271 + if Sys.is_directory p_rel 272 272 + then ( 273 273 + let ui () = 274 274 + let arr = Sys.readdir p_rel in 275 275 + let l = Array.to_list arr |> List.map (Filename.concat path) in 276 276 + (* apply potential filter *) 277 277 + let l = 278 278 + match filter with 279 279 + | None -> l 280 280 + | Some f -> List.filter f l 281 281 + in 282 282 + let l = Lwd.return @@ List.sort String.compare l in 283 283 + vlist_with ~bullet:"" (aux ~fold:true) l 284 284 + in 285 285 + if fold 286 286 + then unfoldable ~folded_by_default:true (Lwd.return @@ string @@ path ^ "/") ui 287 287 + else ui ()) 288 288 + else Lwd.return @@ button ~attr:A.(st underline) path (fun () -> on_select path) 289 289 + with 290 290 + | e -> 291 291 + Lwd.return 292 292 + @@ Ui.vcat 293 293 + [ printf ~attr:A.(bg red) "cannot list directory %s" path 294 294 + ; string @@ Printexc.to_string e 295 295 + ] 296 296 + in 297 297 + let start = if abs then Sys.getcwd () else "" in 298 298 + aux ~fold:false start 299 299 + ;; 300 300 + 301 301 + (** Tab view, where exactly one element of [l] is shown at a time. *) 302 302 + let tabs (tabs : (string * (unit -> Ui.t Lwd.t)) list) : Ui.t Lwd.t = 303 303 + let open Lwd.Infix in 304 304 + match tabs with 305 305 + | [] -> Lwd.return Ui.empty 306 306 + | _ -> 307 307 + let cur = Lwd.var 0 in 308 308 + Lwd.get cur 309 309 + >>= fun idx_sel -> 310 310 + let _, f = List.nth tabs idx_sel in 311 311 + let tab_bar = 312 312 + tabs 313 313 + |> List.mapi (fun i (s, _) -> 314 314 + let attr = if i = idx_sel then A.(st underline) else A.empty in 315 315 + let tab_annot = printf ~attr "[%s]" s in 316 316 + Ui.mouse_area 317 317 + (fun ~x:_ ~y:_ l -> 318 318 + if l = `Left 319 319 + then ( 320 320 + Lwd.set cur i; 321 321 + `Handled) 322 322 + else `Unhandled) 323 323 + tab_annot) 324 324 + |> Ui.hcat 325 325 + in 326 326 + f () >|= Ui.join_y tab_bar 327 327 + ;; 328 328 +

+192

forks/nottui/lib/nottui/widgets/overlays.ml

reviewed

··· 1 1 + (**Widgets that are designed to overlay some exisiting Ui*) 2 2 + 3 3 + open Nottui_main 4 4 + open Shared 5 5 + open Lwd_infix 6 6 + 7 7 + open struct 8 8 + module BB = Border_box 9 9 + module W = Nottui_widgets 10 10 + end 11 11 + 12 12 + open Notty 13 13 + 14 14 + let size_logger ui = 15 15 + let size = Lwd.var (-1, -1) in 16 16 + W.vbox 17 17 + [ (size |> Lwd.get |>$ fun (w, h) -> W.fmt "w:%d,h:%d" w h) 18 18 + ; ui 19 19 + |>$ Ui.size_sensor (fun ~w ~h -> 20 20 + if Lwd.peek size <> (w, h) then Lwd.set size (w, h)) 21 21 + ] 22 22 + ;; 23 23 + 24 24 + let set_bg ~attr ui = 25 25 + let size = Lwd.var (0, 0) in 26 26 + W.zbox 27 27 + [ (size 28 28 + |> Lwd.get 29 29 + |>$ fun (w, h) -> I.char attr ' ' w h |> Ui.atom |> Ui.resize ~w:0 ~h:0) 30 30 + ; ui |>$ Ui.size_sensor (fun ~w ~h -> if (w, h) <> Lwd.peek size then size $= (w, h)) 31 31 + ] 32 32 + ;; 33 33 + 34 34 + let set_bg_static ~attr ui = 35 35 + let w, h = Ui.layout_width ui, Ui.layout_height ui in 36 36 + Ui.zcat [ I.char attr ' ' w h |> Ui.atom |> Ui.resize ~w:0 ~h:0; ui ] 37 37 + ;; 38 38 + 39 39 + let clear_bg ui = set_bg ~attr:A.empty ui 40 40 + 41 41 + (** Internal only function for building prompts. Just deals with the most basic part of the prompt so it can be extended with some custom content. 42 42 + The caller of the function is expected to call 43 43 + [Focus.release_reversable focus] 44 44 + and set [show_prompt] to [None] 45 45 + on_exit *) 46 46 + let prompt_internal ?pad_w ?pad_h ~focus ~show_prompt ui = 47 47 + (*Build the ui so that it is either the prompt or nothing depending on whether show prompt is enabled*) 48 48 + let prompt_ui = 49 49 + let$* show_prompt_val = show_prompt in 50 50 + let prompt_ui = 51 51 + show_prompt_val 52 52 + |> Option.map 53 53 + @@ fun (label, label_bottom, on_exit, prompt_content) -> 54 54 + (*we need focus because the base ui is rendering first and so *) 55 55 + Focus.request_reversable focus; 56 56 + let$* label_bottom = label_bottom in 57 57 + (*prefill the prompt if we want to *) 58 58 + prompt_content 59 59 + |> BB.focusable ?pad_w ?pad_h ~focus ~label_top:label ?label_bottom 60 60 + |> clear_bg 61 61 + |> Lwd.map2 (Focus.status focus) ~f:(fun focus_status ui -> 62 62 + ui 63 63 + |> Ui.event_filter ~focus:focus_status (fun event -> 64 64 + match event with 65 65 + | `Key (`Escape, _) -> 66 66 + on_exit `Closed; 67 67 + `Handled 68 68 + | _ -> `Unhandled)) 69 69 + in 70 70 + prompt_ui |> Option.value ~default:(Ui.empty |> Lwd.pure) 71 71 + in 72 72 + (*Now that we have the prompt ui we layer it ontop of the normal ui using zbox. 73 73 + My hope is that by not directly nesting them this will allow the ui to not re-render when the prompt appears*) 74 74 + W.zbox [ ui; prompt_ui |> Lwd.map ~f:(Ui.resize ~pad:neutral_grav) ] 75 75 + ;; 76 76 + 77 77 + type text_prompt_data = 78 78 + { label : string 79 79 + ; pre_fill : string 80 80 + ; on_exit : [ `Closed | `Finished of string ] -> unit 81 81 + } 82 82 + 83 83 + let text_prompt 84 84 + ?pad_h 85 85 + ?pad_w 86 86 + ?(modify_body = fun x -> x) 87 87 + ?(focus = Focus.make ()) 88 88 + ?(char_count = false) 89 89 + ~(show_prompt_var : text_prompt_data Option.t Lwd.var) 90 90 + ui 91 91 + = 92 92 + let prompt_input = Lwd.var ("", 0) in 93 93 + let prompt_val = Lwd.get prompt_input in 94 94 + (*Build the ui so that it is either the prompt or nothing depending on whether show prompt is enabled*) 95 95 + let prompt_args = 96 96 + let$ show_prompt_val = Lwd.get show_prompt_var in 97 97 + show_prompt_val 98 98 + |> Option.map 99 99 + @@ fun { label; pre_fill; on_exit } -> 100 100 + let on_exit result = 101 101 + Focus.release_reversable focus; 102 102 + show_prompt_var $= None; 103 103 + prompt_input $= ("", 0); 104 104 + on_exit result 105 105 + in 106 106 + (*we need focus because the base ui is rendering first and so *) 107 107 + Focus.request_reversable focus; 108 108 + (*prefill the prompt if we want to *) 109 109 + if prompt_input |> Lwd.peek |> fst == "" 110 110 + then prompt_input $= (pre_fill, pre_fill |> String.length); 111 111 + let prompt_field = 112 112 + W.zbox 113 113 + [ W.string ~attr:A.(st underline) " " 114 114 + |> Lwd.pure 115 115 + ; W.edit_field 116 116 + prompt_val 117 117 + ~on_change:(fun state -> Lwd.set prompt_input state) 118 118 + ~on_submit:(fun (str, _) -> on_exit (`Finished str)) 119 119 + ] 120 120 + |> modify_body 121 121 + in 122 122 + let label_bottom = 123 123 + let$ prompt_val, _ = prompt_val in 124 124 + if char_count then Some (prompt_val |> String.length |> Int.to_string) else None 125 125 + in 126 126 + label, label_bottom, on_exit, prompt_field 127 127 + in 128 128 + prompt_internal ?pad_w ?pad_h ~focus ~show_prompt:prompt_args ui 129 129 + ;; 130 130 + 131 131 + type 'a selection_list_prompt_data = 132 132 + { label : string 133 133 + ; items : 'a Selection_list.selectable_item list Lwd.t 134 134 + ; on_exit : [ `Closed | `Finished of 'a ] -> unit 135 135 + } 136 136 + 137 137 + (* TODO: Write a ui resize function that takes an optional version of the layout spec where eveyr field is optional too, then we can use that when we want to make a widget with a custom internal state, or i can just use w mw h mw etc *) 138 138 + 139 139 + let selection_list_prompt 140 140 + ?pad_w 141 141 + ?pad_h 142 142 + ?(modify_body = fun x -> x) 143 143 + ?(focus = Focus.make ()) 144 144 + ~show_prompt_var 145 145 + ui 146 146 + = 147 147 + (*Build the ui so that it is either the prompt or nothing depending on whether show prompt is enabled*) 148 148 + let prompt_args = 149 149 + let$ show_prompt_val = Lwd.get show_prompt_var in 150 150 + show_prompt_val 151 151 + |> Option.map 152 152 + @@ fun { label; items; on_exit } -> 153 153 + let on_exit result = 154 154 + Focus.release_reversable focus; 155 155 + show_prompt_var $= None; 156 156 + on_exit result 157 157 + in 158 158 + (*we need focus because the base ui is rendering first and so *) 159 159 + Focus.request_reversable focus; 160 160 + (*prefill the prompt if we want to *) 161 161 + let prompt_field = 162 162 + Selection_list.selection_list_custom 163 163 + ~focus 164 164 + ~custom_handler:(fun item key -> 165 165 + match key with 166 166 + | `Enter, [] -> 167 167 + `Finished item.data |> on_exit; 168 168 + `Handled 169 169 + | _ -> `Unhandled) 170 170 + items 171 171 + |> modify_body 172 172 + in 173 173 + let label_bottom = 174 174 + let$ items = items in 175 175 + Some (items |> List.length |> Printf.sprintf "%d items") 176 176 + in 177 177 + label, label_bottom, on_exit, prompt_field 178 178 + in 179 179 + prompt_internal ?pad_w ?pad_h ~focus ~show_prompt:prompt_args ui 180 180 + ;; 181 181 + 182 182 + let popup ~show_popup_var ui = 183 183 + let popup_ui = 184 184 + let$* show_popup = Lwd.get show_popup_var in 185 185 + match show_popup with 186 186 + | Some (content, label) -> 187 187 + let prompt_field = content in 188 188 + prompt_field |>$ Ui.resize ~w:5 |> BB.box ~label_top:label |> clear_bg 189 189 + | None -> Ui.empty |> Lwd.pure 190 190 + in 191 191 + W.zbox [ ui; popup_ui |>$ Ui.resize ~crop:neutral_grav ~pad:neutral_grav ] 192 192 + ;;

+58

forks/nottui/lib/nottui/widgets/overlays.mli

reviewed

··· 1 1 + (** Shows the size of the ui provided. Useful for debugging*) 2 2 + val size_logger : Nottui_main.ui Lwd.t -> Nottui_main.ui Lwd.t 3 3 + 4 4 + (**Sets an attr for anything behind the given area*) 5 5 + val set_bg : attr:Notty.attr -> Nottui_main.ui Lwd.t -> Nottui_main.ui Lwd.t 6 6 + 7 7 + (**Clears anything behind the given area using the width. If you have a dynamic sized element use [set_bg]*) 8 8 + val set_bg_static : attr:Notty.attr -> Nottui_main.ui -> Nottui_main.ui 9 9 + 10 10 + (**Clears anything behind the given area*) 11 11 + val clear_bg : Nottui_main.ui Lwd.t -> Nottui_main.ui Lwd.t 12 12 + 13 13 + 14 14 + 15 15 + (** Config for a text_prompt*) 16 16 + type text_prompt_data = { 17 17 + label : string; 18 18 + pre_fill : string; 19 19 + on_exit : [ `Closed | `Finished of string ] -> unit; 20 20 + } 21 21 + 22 22 + (** Text box prompt that takes user input then calls [on_exit] with the result. 23 23 + 24 24 + This will display ontop of any ui it is passed when show_prompt_var is [Some].*) 25 25 + 26 26 + val text_prompt : 27 27 + ?pad_h:int -> 28 28 + ?pad_w:int -> 29 29 + ?modify_body:(Nottui_main.ui Lwd.t -> Nottui_main.ui Lwd.t) -> 30 30 + ?focus:Nottui_main.Focus.handle -> 31 31 + ?char_count:bool -> 32 32 + show_prompt_var:text_prompt_data option Lwd.var -> 33 33 + Nottui_main.ui Lwd.t -> Nottui_main.ui Lwd.t 34 34 + 35 35 + (** Config for a selection_list_prompt*) 36 36 + type 'a selection_list_prompt_data = { 37 37 + label : string; 38 38 + items : 'a Selection_list.selectable_item list Lwd.t; 39 39 + on_exit : [ `Closed | `Finished of 'a ] -> unit; 40 40 + } 41 41 + 42 42 + (** Selection_list prompt. 43 43 + 44 44 + This will display ontop of any ui it is passed when show_prompt_var is [Some]. 45 45 + @param modify_body Function that takes the completed body of the prompt, incase you want to resize it or otherwise change it 46 46 + *) 47 47 + val selection_list_prompt : 48 48 + ?pad_w:int -> 49 49 + ?pad_h:int -> 50 50 + ?modify_body:(Nottui_main.ui Lwd.t -> Nottui_main.ui Lwd.t) -> 51 51 + ?focus:Nottui_main.Focus.handle -> 52 52 + show_prompt_var:'a selection_list_prompt_data option Lwd.var -> 53 53 + Nottui_main.ui Lwd.t -> Nottui_main.ui Lwd.t 54 54 + 55 55 + (**This is a simple popup that can show ontop of other ui elements *) 56 56 + val popup : 57 57 + show_popup_var:(Nottui_main.ui Lwd.t * string) option Lwd.var -> 58 58 + Nottui_main.ui Lwd.t -> Nottui_main.ui Lwd.t

+197

forks/nottui/lib/nottui/widgets/scroll.ml

reviewed

··· 1 1 + (** Widgets to make a section of UI scrollable*) 2 2 + open Nottui_main 3 3 + 4 4 + open Shared 5 5 + open Lwd_infix 6 6 + 7 7 + module Internal = struct 8 8 + let scroll_step = 1 9 9 + 10 10 + type scroll_state = 11 11 + { position : int 12 12 + ; bound : int 13 13 + } 14 14 + 15 15 + let default_scroll_state = { position = 0; bound = 0 } 16 16 + 17 17 + (** Primative for implementing scrolling, should be avoided unless you actually have reason to be changing the scroll state *) 18 18 + let vscroll_area_intern ~state ~change t = 19 19 + let visible = ref (-1) in 20 20 + let total = ref (-1) in 21 21 + let scroll state delta = 22 22 + let position = state.position + delta in 23 23 + let position = clampi position ~min:0 ~max:state.bound in 24 24 + if position <> state.position then change `Action { state with position }; 25 25 + `Handled 26 26 + in 27 27 + let focus_handler state = function 28 28 + (*| `Arrow `Left , _ -> scroll (-scroll_step) 0*) 29 29 + (*| `Arrow `Right, _ -> scroll (+scroll_step) 0*) 30 30 + | `Arrow `Up, [] -> scroll state (-scroll_step) 31 31 + | `Arrow `Down, [] -> scroll state (+scroll_step) 32 32 + | `Page `Up, [] -> scroll state (-scroll_step * 8) 33 33 + | `Page `Down, [] -> scroll state (+scroll_step * 8) 34 34 + | _ -> `Unhandled 35 35 + in 36 36 + let scroll_handler state ~x:_ ~y:_ = function 37 37 + | `Scroll `Up -> scroll state (-scroll_step) 38 38 + | `Scroll `Down -> scroll state (+scroll_step) 39 39 + | _ -> `Unhandled 40 40 + in 41 41 + Lwd.map2 t state ~f:(fun t state -> 42 42 + let tmh = Ui.layout_max_height t in 43 43 + t 44 44 + |> Ui.shift_area 0 state.position 45 45 + |> Ui.resize ~h:0 ~sh:1 ~mh:10000 46 46 + |> Ui.size_sensor (fun ~w:_ ~h -> 47 47 + let tchange = 48 48 + if !total <> (Ui.layout_spec t).Ui.h 49 49 + then ( 50 50 + total := (Ui.layout_spec t).Ui.h; 51 51 + true) 52 52 + else false 53 53 + in 54 54 + let vchange = 55 55 + if !visible <> h 56 56 + then ( 57 57 + visible := h; 58 58 + true) 59 59 + else false 60 60 + in 61 61 + if tchange || vchange 62 62 + then change `Content { state with bound = maxi 0 (!total - !visible) }) 63 63 + |> Ui.mouse_area (scroll_handler state) 64 64 + |> Ui.keyboard_area (focus_handler state) 65 65 + (*restore original max height*) 66 66 + |> Ui.resize ~mh:tmh) 67 67 + ;; 68 68 + 69 69 + let scroll_area_intern ?focus ~state ~change t = 70 70 + let open Lwd_utils in 71 71 + let w_visible = ref (-1) in 72 72 + let w_total = ref (-1) in 73 73 + let h_visible = ref (-1) in 74 74 + let h_total = ref (-1) in 75 75 + let scroll position bound handle delta = 76 76 + let newPos = position + delta in 77 77 + let newPos = clampi newPos ~min:0 ~max:bound in 78 78 + if newPos <> position then handle newPos; 79 79 + `Handled 80 80 + in 81 81 + let focus_handler state_w state_h = 82 82 + let scroll_w = 83 83 + scroll state_w.position state_w.bound (fun position -> 84 84 + change `ActionV ({ state_w with position }, state_h)) 85 85 + in 86 86 + let scroll_h = 87 87 + scroll state_h.position state_h.bound (fun position -> 88 88 + change `ActionH (state_w, { state_h with position })) 89 89 + in 90 90 + function 91 91 + | `Arrow `Left, [] -> scroll_w (-scroll_step) 92 92 + | `Arrow `Right, [] -> scroll_w (+scroll_step) 93 93 + | `Arrow `Up, [] -> scroll_h (-scroll_step) 94 94 + | `Arrow `Down, [] -> scroll_h (+scroll_step) 95 95 + | `Page `Up, [] -> scroll_h (-scroll_step * 8) 96 96 + | `Page `Down, [] -> scroll_h (+scroll_step * 8) 97 97 + | _ -> `Unhandled 98 98 + in 99 99 + let scroll_handler state_w state_h ~x:_ ~y:_ = 100 100 + let scroll_h = 101 101 + scroll state_h.position state_h.bound (fun position -> 102 102 + change `ActionH (state_w, { state_h with position })) 103 103 + in 104 104 + function 105 105 + | `Scroll `Up -> scroll_h (-scroll_step) 106 106 + | `Scroll `Down -> scroll_h (+scroll_step) 107 107 + | _ -> `Unhandled 108 108 + in 109 109 + Lwd.map2 t state ~f:(fun t (state_w, state_h) -> 110 110 + let tw, th = Ui.layout_width t, Ui.layout_height t in 111 111 + let tmw, tmh = Ui.layout_max_width t, Ui.layout_max_height t in 112 112 + (* let mw, mh = if max then Some tw, Some th else None, None in *) 113 113 + t 114 114 + |> Ui.resize ~w:0 ~sw:1 ~h:0 ~sh:1 ~mw:10000 ~mh:10000 115 115 + |> Ui.shift_area state_w.position state_h.position 116 116 + (* |>Ui.join_y (Ui.atom (I.string A.empty (string_of_int state_w.visible))) *) 117 117 + (*TODO: make an alternative that has this already set*) 118 118 + |> Ui.size_sensor (fun ~w ~h -> 119 119 + let sense v_spec v state total visible = 120 120 + let tchange = 121 121 + if !total <> v_spec 122 122 + then ( 123 123 + total := v_spec; 124 124 + true) 125 125 + else false 126 126 + in 127 127 + let vchange = 128 128 + if !visible <> v 129 129 + then ( 130 130 + visible := v; 131 131 + true) 132 132 + else false 133 133 + in 134 134 + if tchange || vchange 135 135 + then Some { state with bound = maxi 0 (!total - !visible) } 136 136 + else None 137 137 + in 138 138 + let w_update = sense tw w state_w w_total w_visible in 139 139 + let h_update = sense th h state_h h_total h_visible in 140 140 + match w_update, h_update with 141 141 + | Some w, Some h -> change `ContentBoth (w, h) 142 142 + | Some w, None -> change `ContentW (w, state_h) 143 143 + | None, Some h -> change `ContentH (state_w, h) 144 144 + | None, None -> ()) 145 145 + |> Ui.mouse_area (scroll_handler state_w state_h) 146 146 + |> Ui.keyboard_area ?focus (focus_handler state_w state_h) 147 147 + (*restore original mw*) 148 148 + |> Ui.resize ~mw:tmw ~mh:tmh) 149 149 + ;; 150 150 + end 151 151 + 152 152 + open Internal 153 153 + 154 154 + let v_area ui = 155 155 + let state = Lwd.var Internal.default_scroll_state in 156 156 + ui 157 157 + |> Internal.vscroll_area_intern ~change:(fun _ x -> state $= x) ~state:(Lwd.get state) 158 158 + ;; 159 159 + 160 160 + let area ?focus ui = 161 161 + let state = Lwd.var (Internal.default_scroll_state, Internal.default_scroll_state) in 162 162 + ui 163 163 + |> Internal.scroll_area_intern 164 164 + ?focus 165 165 + ~change:(fun _ x -> state $= x) 166 166 + ~state:(Lwd.get state) 167 167 + ;; 168 168 + 169 169 + let infinite_area ?(offset = 0, 0) t = 170 170 + let offset = Lwd.var offset in 171 171 + let scroll d_x d_y = 172 172 + let s_x, s_y = Lwd.peek offset in 173 173 + let s_x = maxi 0 (s_x + d_x) in 174 174 + let s_y = maxi 0 (s_y + d_y) in 175 175 + Lwd.set offset (s_x, s_y); 176 176 + `Handled 177 177 + in 178 178 + let focus_handler = function 179 179 + | `Arrow `Left, [] -> scroll (-scroll_step) 0 180 180 + | `Arrow `Right, [] -> scroll (+scroll_step) 0 181 181 + | `Arrow `Up, [] -> scroll 0 (-scroll_step) 182 182 + | `Arrow `Down, [] -> scroll 0 (+scroll_step) 183 183 + | `Page `Up, [] -> scroll 0 (-scroll_step * 8) 184 184 + | `Page `Down, [] -> scroll 0 (+scroll_step * 8) 185 185 + | _ -> `Unhandled 186 186 + in 187 187 + let scroll_handler ~x:_ ~y:_ = function 188 188 + | `Scroll `Up -> scroll 0 (-scroll_step) 189 189 + | `Scroll `Down -> scroll 0 (+scroll_step) 190 190 + | _ -> `Unhandled 191 191 + in 192 192 + Lwd.map2 t (Lwd.get offset) ~f:(fun t (s_x, s_y) -> 193 193 + t 194 194 + |> Ui.shift_area s_x s_y 195 195 + |> Ui.mouse_area scroll_handler 196 196 + |> Ui.keyboard_area focus_handler) 197 197 + ;;

+9

forks/nottui/lib/nottui/widgets/scroll.mli

reviewed

··· 1 1 + (** A keyboard scroll area that only scrolls in the vertical direction *) 2 2 + val v_area : Nottui_main.ui Lwd.t -> Nottui_main.ui Lwd.t 3 3 + 4 4 + (** A scroll area that allows keyboard scrolling in both x and y directions*) 5 5 + val area : ?focus:Nottui_main.Focus.status -> Nottui_main.ui Lwd.t -> Nottui_main.ui Lwd.t 6 6 + 7 7 + (** A scroll area that allows keyboard scrolling in both x and y directions and has no limits. 8 8 + This might be useful if you have some very dynamic content and the usual scroll area doesn't know how big things are*) 9 9 + val infinite_area : ?offset:int * int -> Nottui_main.ui Lwd.t -> Nottui_main.ui Lwd.t

+235

forks/nottui/lib/nottui/widgets/selection_list.ml

reviewed

··· 1 1 + open Notty 2 2 + open Nottui_main 3 3 + open Lwd_infix 4 4 + open Shared 5 5 + 6 6 + type 'a selectable_item = 7 7 + { data : 'a 8 8 + ; ui : bool -> Ui.t Lwd.t 9 9 + } 10 10 + 11 11 + type 'a maybeSelectable = 12 12 + | Selectable of 'a selectable_item 13 13 + | Filler of Ui.t Lwd.t 14 14 + 15 15 + let selection_list_exclusions 16 16 + ?(focus = Focus.make ()) 17 17 + ?(on_selection_change = fun _ -> ()) 18 18 + ~custom_handler 19 19 + (items : 'a maybeSelectable array Lwd.t) 20 20 + = 21 21 + (* 22 22 + The rough overview is: 23 23 + 1. Make a new list that only contains our selectable items 24 24 + 2. Render the items, making sure to tell the selected one to render as selected. 25 25 + 3. Calculate how much we should scroll by. 26 26 + 4. offset by the scroll amount, apply size sensors and output final ui 27 27 + *) 28 28 + let selected_var = Lwd.var 0 in 29 29 + let selected_position = Lwd.var (0, 0) in 30 30 + let selectable_items = 31 31 + let$ items = items in 32 32 + (*Array of selectable items and their idx in the original array*) 33 33 + let selectable_items = Array.make (Array.length items) (Obj.magic ()) in 34 34 + let _, final_len = 35 35 + items 36 36 + |> Array.fold_left 37 37 + (fun (i, selectable_count) item -> 38 38 + match item with 39 39 + | Selectable item -> 40 40 + Array.set selectable_items selectable_count (i, item); 41 41 + i + 1, selectable_count + 1 42 42 + | Filler _ -> i + 1, selectable_count + 1) 43 43 + (0, 0) 44 44 + in 45 45 + Array.sub selectable_items 0 final_len 46 46 + in 47 47 + (*handle selections*) 48 48 + let render_items = 49 49 + let$* focus = focus |> Focus.status 50 50 + and$ items, selected, selectable_items = 51 51 + (* This doesn't depend on changes in focus but it should update whenever there are new items or a selection change*) 52 52 + let$ items = items 53 53 + and$ selectable_items = selectable_items 54 54 + and$ selected = Lwd.get selected_var in 55 55 + (* First ensure if our list has gotten shorter we haven't selected off the list*) 56 56 + (* We do this here to ensure that the selected var is updated before we render to avoid double rendering*) 57 57 + let max_selected = Int.max 0 (Array.length selectable_items - 1) in 58 58 + if Int.min selected max_selected <> selected then selected_var $= max_selected; 59 59 + let selected = Lwd.peek selected_var in 60 60 + if Array.length selectable_items > 0 61 61 + then ( 62 62 + let item_idx, item = selectable_items.(selected) in 63 63 + on_selection_change item.data; 64 64 + items, item_idx, selectable_items) 65 65 + else items, 0, selectable_items 66 66 + in 67 67 + (* Ui.vcat can be a little weird when the *) 68 68 + if items |> Array.length = 0 69 69 + then Ui.empty |> Lwd.pure 70 70 + else 71 71 + items 72 72 + |> Array.mapi (fun i x -> 73 73 + match x with 74 74 + | Filler ui -> ui 75 75 + | Selectable x -> 76 76 + if selected == i 77 77 + then 78 78 + x.ui true 79 79 + |>$ Ui.transient_sensor (fun ~x ~y ~w:_ ~h:_ () -> 80 80 + if (x, y) <> Lwd.peek selected_position then selected_position $= (x, y)) 81 81 + else x.ui false) 82 82 + |> Array.to_list 83 83 + |> Shared.vbox 84 84 + |>$ Ui.keyboard_area ~focus (function 85 85 + | `Arrow `Up, [] -> 86 86 + let selected = max (Lwd.peek selected_var - 1) 0 in 87 87 + selected_var $= selected; 88 88 + `Handled 89 89 + | `Arrow `Down, [] -> 90 90 + let selected = 91 91 + Int.max 92 92 + (min (Lwd.peek selected_var + 1) ((selectable_items |> Array.length) - 1)) 93 93 + 0 94 94 + in 95 95 + selected_var $= selected; 96 96 + `Handled 97 97 + | a -> custom_handler (selectable_items.(Lwd.peek selected_var) |> snd) a) 98 98 + in 99 99 + let rendered_size_var = Lwd.var (0, 0) in 100 100 + (*Handle scrolling*) 101 101 + let scrollitems = 102 102 + let size_var = Lwd.var (0, 0) in 103 103 + let shift_amount = 104 104 + (*get the actual idx not just the selection number*) 105 105 + let$ selected_idx = 106 106 + Lwd.map2 (Lwd.get selected_var) selectable_items ~f:(fun selected selectable -> 107 107 + if Array.length selectable > selected then selectable.(selected) |> fst else 0) 108 108 + and$ size = Lwd.get size_var 109 109 + and$ length = items |>$ Array.length 110 110 + and$ ren_size = Lwd.get rendered_size_var in 111 111 + (*portion of the total size of the element that is rendered*) 112 112 + let size_ratio = 113 113 + (ren_size |> snd |> float_of_int) /. (size |> snd |> float_of_int) 114 114 + in 115 115 + (*Tries to ensure that we start scrolling the list when we've selected about a third of the way down (using 3.0 causes weird jumping, so i use just less than )*) 116 116 + let offset = size_ratio *. ((length |> float_of_int) /. 2.9) in 117 117 + (*portion of the list that is behind the selection*) 118 118 + let list_ratio = 119 119 + ((selected_idx |> float_of_int) +. offset) /. (length |> float_of_int) 120 120 + in 121 121 + (*if our position is further down the list than the portion that is shown we will shift by that amoumt *) 122 122 + Float.max (list_ratio -. size_ratio) 0.0 *. (size |> snd |> float_of_int) 123 123 + |> int_of_float 124 124 + in 125 125 + let$ items = render_items 126 126 + and$ shift_amount = shift_amount in 127 127 + items 128 128 + |> Ui.shift_area 0 shift_amount 129 129 + |> Ui.resize ~sh:1 130 130 + |> simpleSizeSensor ~size_var 131 131 + |> Ui.resize ~w:3 ~sw:1 ~h:0 132 132 + |> simpleSizeSensor ~size_var:rendered_size_var 133 133 + in 134 134 + scrollitems 135 135 + ;; 136 136 + 137 137 + let selectable_item ui is_focused = 138 138 + let height = Ui.layout_height ui in 139 139 + let prefix = 140 140 + if is_focused then I.char A.(bg blue) '>' 1 height else I.char A.empty ' ' 1 height 141 141 + in 142 142 + Ui.hcat [ prefix |> Ui.atom; ui ] |> Lwd.pure 143 143 + ;; 144 144 + 145 145 + let selectable_item_lwd ui is_focused = 146 146 + let$ ui = ui in 147 147 + let height = Ui.layout_height ui in 148 148 + let prefix = 149 149 + if is_focused then I.char A.(bg blue) '>' 1 height else I.char A.empty ' ' 1 height 150 150 + in 151 151 + Ui.hcat [ prefix |> Ui.atom; ui ] 152 152 + ;; 153 153 + 154 154 + let selection_list_custom 155 155 + ?(focus = Focus.make ()) 156 156 + ?(on_selection_change = fun _ -> ()) 157 157 + ~custom_handler 158 158 + (items : 'a selectable_item list Lwd.t) 159 159 + = 160 160 + selection_list_exclusions 161 161 + ~focus 162 162 + ~on_selection_change 163 163 + ~custom_handler 164 164 + (items 165 165 + |>$ fun items -> 166 166 + let selectable_items = Array.make (List.length items) (Obj.magic ()) in 167 167 + items |> List.iteri (fun i x -> Array.set selectable_items i (Selectable x)); 168 168 + selectable_items) 169 169 + ;; 170 170 + 171 171 + let filterable_selection_list_custom 172 172 + ?(focus = Focus.make ()) 173 173 + ~(filter_predicate : string -> 'a -> bool) 174 174 + ~custom_handler 175 175 + ~filter_text_var 176 176 + (items : 'a selectable_item list Lwd.t) 177 177 + = 178 178 + (*filter the list whenever the input changes*) 179 179 + let items = 180 180 + (* if we re-render we should always reset the selected list *) 181 181 + let items = 182 182 + let$ filter_text = filter_text_var |> Lwd.get 183 183 + and$ items = items in 184 184 + items |> List.filter (fun x -> filter_predicate filter_text x.data) 185 185 + in 186 186 + selection_list_custom 187 187 + ~focus 188 188 + ~custom_handler:(fun item x -> 189 189 + (*TODO is this needed? won't the items provided already be filtered anyway?*) 190 190 + custom_handler item x) 191 191 + items 192 192 + in 193 193 + items 194 194 + ;; 195 195 + 196 196 + let filterable_selection_list 197 197 + ?(focus = Focus.make ()) 198 198 + ~filter_predicate 199 199 + ?(on_esc = fun _ -> ()) 200 200 + ~on_confirm 201 201 + list_items 202 202 + = 203 203 + let filter_text_var = Lwd.var "" in 204 204 + let filter_text_ui = 205 205 + input_field 206 206 + ~focus 207 207 + (filter_text_var |> Lwd.get) 208 208 + ~on_change:(fun x -> filter_text_var $= x) 209 209 + ~on_submit:(fun _ -> ()) 210 210 + |>$ Ui.resize ~w:3 ~sw:1 ~mw:10000 211 211 + in 212 212 + let list_ui = 213 213 + list_items 214 214 + |> filterable_selection_list_custom 215 215 + ~filter_predicate 216 216 + ~focus 217 217 + ~filter_text_var 218 218 + ~custom_handler:(fun item key -> 219 219 + match key with 220 220 + | `Enter, [] -> 221 221 + item.data |> on_confirm; 222 222 + `Handled 223 223 + | `Escape, [] -> 224 224 + item.data |> on_esc; 225 225 + `Handled 226 226 + | _ -> `Unhandled) 227 227 + in 228 228 + vbox 229 229 + [ filter_text_ui 230 230 + (*Ensures the filter text box never expands beyond the size of the list elements*) 231 231 + |> Border_box.box 232 232 + ; list_ui |> Border_box.box 233 233 + ] 234 234 + |> Border_box.box 235 235 + ;;

+69

forks/nottui/lib/nottui/widgets/selection_list.mli

reviewed

··· 1 1 + (**Selectable list item with a ui and some data *) 2 2 + type 'a selectable_item = 3 3 + { data : 'a 4 4 + (**info attached to each ui elment in the list, used for filtering and on_select callback *) 5 5 + ; ui : bool -> Nottui_main.ui Lwd.t 6 6 + } 7 7 + 8 8 + type 'a maybeSelectable = 9 9 + | Selectable of 'a selectable_item 10 10 + | Filler of Nottui_main.ui Lwd.t 11 11 + 12 12 + (** Same as [selection_list_custom] except that it supports not all element in the list being selectable *) 13 13 + val selection_list_exclusions 14 14 + : ?focus:Nottui_main.Focus.handle 15 15 + -> ?on_selection_change:('a -> unit) 16 16 + -> custom_handler: 17 17 + ('a selectable_item -> Nottui_main.Ui.key -> Nottui_main.Ui.may_handle) 18 18 + -> 'a maybeSelectable array Lwd.t 19 19 + -> Nottui_main.ui Lwd.t 20 20 + 21 21 + (**Makes a ui element selectable. 22 22 + 23 23 + Takes [ui] and returns a function that appends '>' to the start when given [true] and ' ' when false 24 24 + 25 25 + Used in conjuction with [selection_list_custom]*) 26 26 + val selectable_item : Nottui_main.ui -> bool -> Nottui_main.ui Lwd.t 27 27 + 28 28 + val selectable_item_lwd : Nottui_main.ui Lwd.t -> bool -> Nottui_main.ui Lwd.t 29 29 + 30 30 + (** Selection list that allows for custom handling of keyboard events. 31 31 + Scrolls when the selection reaches the lower third 32 32 + Only handles up and down keyboard events. Use [~custom_handler] to do handle confirming your selection and such *) 33 33 + val selection_list_custom 34 34 + : ?focus:Nottui_main.Focus.handle 35 35 + -> ?on_selection_change:('a -> unit) 36 36 + -> custom_handler: 37 37 + ('a selectable_item -> Nottui_main.Ui.key -> Nottui_main.Ui.may_handle) 38 38 + -> 'a selectable_item list Lwd.t 39 39 + -> Nottui_main.ui Lwd.t 40 40 + 41 41 + (** A filterable selectable list. 42 42 + 43 43 + This version allows you to implement custom handlers for keys and only provides functionality for moving up and down the list. 44 44 + 45 45 + For basic usage you likely want {!filterable_selection_list} which provides `Enter` and `Esc` handlers *) 46 46 + val filterable_selection_list_custom 47 47 + : ?focus:Nottui_main.Focus.handle 48 48 + -> filter_predicate:(string -> 'a -> bool) 49 49 + -> custom_handler: 50 50 + ('a selectable_item -> Nottui_main.Ui.key -> Nottui_main.Ui.may_handle) 51 51 + -> filter_text_var:string Lwd.var 52 52 + -> 'a selectable_item list Lwd.t 53 53 + -> Nottui_main.ui Lwd.t 54 54 + 55 55 + (** Filterable selection list 56 56 + 57 57 + Allows filtering and selecting items in a list. 58 58 + Also handles shifting the list so that the selection dosen't go out of view 59 59 + @param ~filter_predicate Function called to deterimine if an items should be included 60 60 + @param ~on_confirm Called when user presses enter 61 61 + @param ?on_esc Called when user presses esc 62 62 + @param list_items List of items to be displayed/selected/filtered *) 63 63 + val filterable_selection_list 64 64 + : ?focus:Nottui_main.Focus.handle 65 65 + -> filter_predicate:(string -> 'a -> bool) 66 66 + -> ?on_esc:('a -> unit) 67 67 + -> on_confirm:('a -> unit) 68 68 + -> 'a selectable_item list Lwd.t 69 69 + -> Nottui_main.ui Lwd.t

+74

forks/nottui/lib/nottui/widgets/widgets.ml

reviewed

··· 1 1 + open Notty 2 2 + open Nottui_main 3 3 + open Lwd_infix 4 4 + include Shared 5 5 + include Nottui_widgets 6 6 + module Old = Old 7 7 + module Wip = Wip 8 8 + module Box = Border_box 9 9 + module Overlay = Overlays 10 10 + module Scroll = Scroll 11 11 + 12 12 + module Lists = struct 13 13 + include Selection_list 14 14 + include Lists 15 15 + end 16 16 + 17 17 + module W = Nottui_widgets 18 18 + 19 19 + (** Shows the size of the ui provided. Useful for debugging*) 20 20 + let size_logger ui = 21 21 + let size = Lwd.var (-1, -1) in 22 22 + W.vbox 23 23 + [ (size |> Lwd.get |>$ fun (w, h) -> W.fmt "w:%d,h:%d" w h) 24 24 + ; ui 25 25 + |>$ Ui.size_sensor (fun ~w ~h -> 26 26 + if Lwd.peek size <> (w, h) then Lwd.set size (w, h)) 27 27 + ] 28 28 + ;; 29 29 + 30 30 + (** horizontal rule, has no width by default but is very very wide so it should fill any space*) 31 31 + let h_rule = 32 32 + W.string 33 33 + "━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━" 34 34 + |> Ui.resize ~w:0 ~sw:100 35 35 + ;; 36 36 + 37 37 + (** Tab view, where exactly one element of [l] is shown at a time. Naviagted using number keys on the keyboard *) 38 38 + let keyboard_tabs (tabs : (string * (unit -> Ui.t Lwd.t)) list) : Ui.t Lwd.t = 39 39 + (* Gets an int that a char represents*) 40 40 + let char_to_int c = 41 41 + if c >= '0' && c <= '9' then Some (int_of_char c - int_of_char '0') else None 42 42 + in 43 43 + match tabs with 44 44 + | [] -> Lwd.return Ui.empty 45 45 + | _ -> 46 46 + let cur = Lwd.var 0 in 47 47 + let$* idx_sel = Lwd.get cur in 48 48 + let _, f = List.nth tabs idx_sel in 49 49 + let tab_bar = 50 50 + tabs 51 51 + |> List.mapi (fun i (s, _) -> 52 52 + let attr = if i = idx_sel then A.(st underline) else A.empty in 53 53 + let tab_annot = W.printf ~attr "%s [%d]" s (i + 1) in 54 54 + tab_annot) 55 55 + |> List.intersperse ~sep:(W.string " | ") 56 56 + |> Ui.hcat 57 57 + |> Ui.resize ~sw:1 ~mw:10000 58 58 + |> Lwd.pure 59 59 + |> Box.box ~pad_w:1 ~pad_h:0 60 60 + in 61 61 + W.vbox [ tab_bar; f () ] 62 62 + |>$ Ui.keyboard_area (function 63 63 + | `ASCII key, _ -> 64 64 + key 65 65 + |> char_to_int 66 66 + |> Option.map (fun i -> 67 67 + if i >= 1 && i <= List.length tabs 68 68 + then ( 69 69 + cur $= i - 1; 70 70 + `Handled) 71 71 + else `Unhandled) 72 72 + |> Option.value ~default:`Unhandled 73 73 + | _ -> `Unhandled) 74 74 + ;;

+129

forks/nottui/lib/nottui/widgets/wip.ml

reviewed

··· 1 1 + open Notty 2 2 + open Nottui_main 3 3 + open Lwd_infix 4 4 + open Shared 5 5 + 6 6 + let dynamic_size ?(w = 10) ~sw ?(h = 10) ~sh f = 7 7 + let size = Lwd.var (w, h) in 8 8 + let body = f (Lwd.get size) in 9 9 + body 10 10 + |> Lwd.map ~f:(fun ui -> 11 11 + ui 12 12 + |> Ui.resize ~w ~sw ~h ~sh 13 13 + |> Ui.size_sensor (fun ~w ~h -> if Lwd.peek size <> (w, h) then Lwd.set size (w, h))) 14 14 + ;; 15 15 + 16 16 + (* 17 17 + design for a windowing system: 18 18 + fundinmental primative: 19 19 + window stack: 20 20 + when inside a window stack you can navigate up and down your stack. 21 21 + if you would also like to navigate to stacks sideways you just wrap then in a horizontal window stack. 22 22 + *) 23 23 + let v_window_stack ~focus windows = 24 24 + let focused = ref 0 in 25 25 + let is_focused = ref false in 26 26 + let windows, focuses = 27 27 + windows 28 28 + |> List.map (fun window_maker -> 29 29 + let focus = Focus.make () in 30 30 + window_maker ~focus, focus) 31 31 + |> List.split 32 32 + in 33 33 + focuses |> List.hd |> Focus.request; 34 34 + (let$ ui = vbox windows 35 35 + and$ focus = focus |> Focus.status in 36 36 + if (not !is_focused) && Focus.has_focus focus 37 37 + then ( 38 38 + is_focused := true; 39 39 + List.nth focuses !focused |> Focus.request) 40 40 + else if !is_focused && not (Focus.has_focus focus) 41 41 + then is_focused := false; 42 42 + ui 43 43 + |> Ui.join_x (if !is_focused then string "f" else string "u") 44 44 + |> Ui.keyboard_area 45 45 + ~focus 46 46 + (if !is_focused 47 47 + then 48 48 + function 49 49 + | `Arrow `Down, [ `Ctrl ] -> 50 50 + let focused_idx = !focused in 51 51 + (* set the focus to be the next item if possible *) 52 52 + List.nth_opt focuses (focused_idx + 1) 53 53 + |> Option.iter (fun x -> 54 54 + List.nth focuses focused_idx |> Focus.release; 55 55 + Focus.request x; 56 56 + focused := focused_idx + 1); 57 57 + `Handled 58 58 + | `Arrow `Up, [ `Ctrl ] -> 59 59 + let focused_idx = !focused in 60 60 + let target_idx = focused_idx - 1 in 61 61 + if target_idx >= 0 62 62 + then 63 63 + (* set the focus to be the previous item if possible *) 64 64 + List.nth_opt focuses target_idx 65 65 + |> Option.iter (fun x -> 66 66 + List.nth focuses focused_idx |> Focus.release; 67 67 + Focus.request x; 68 68 + focused := focused_idx - 1); 69 69 + `Handled 70 70 + | _ -> 71 71 + `Unhandled 72 72 + else fun _ -> `Unhandled)) 73 73 + |> Border_box.with_border_attr 74 74 + (let$ focus = focus |> Focus.status |>$ Focus.has_focus in 75 75 + if focus then A.fg A.blue else A.empty) 76 76 + ;; 77 77 + 78 78 + let h_window_stack ~focus windows = 79 79 + let focused = ref 0 in 80 80 + let is_focused = ref false in 81 81 + let windows, focuses = 82 82 + windows 83 83 + |> List.map (fun window_maker -> 84 84 + let focus = Focus.make () in 85 85 + window_maker ~focus, focus) 86 86 + |> List.split 87 87 + in 88 88 + (let$ ui = hbox windows 89 89 + and$ focus = focus |> Focus.status in 90 90 + if (not !is_focused) && Focus.has_focus focus 91 91 + then ( 92 92 + is_focused := true; 93 93 + List.nth focuses !focused |> Focus.request) 94 94 + else if !is_focused && not (Focus.has_focus focus) 95 95 + then is_focused := false; 96 96 + ui 97 97 + |> Ui.keyboard_area 98 98 + ~focus 99 99 + (if !is_focused 100 100 + then 101 101 + function 102 102 + | `Arrow `Right, [ `Ctrl ] -> 103 103 + let focused_idx = !focused in 104 104 + (* set the focus to be the next item if possible *) 105 105 + List.nth_opt focuses (focused_idx + 1) 106 106 + |> Option.iter (fun x -> 107 107 + List.nth focuses focused_idx |> Focus.release; 108 108 + Focus.request x; 109 109 + focused := focused_idx + 1); 110 110 + `Handled 111 111 + | `Arrow `Left, [ `Ctrl ] -> 112 112 + let focused_idx = !focused in 113 113 + let target_idx = focused_idx - 1 in 114 114 + if target_idx >= 0 115 115 + then 116 116 + (* set the focus to be the previous item if possible *) 117 117 + List.nth_opt focuses target_idx 118 118 + |> Option.iter (fun x -> 119 119 + List.nth focuses focused_idx |> Focus.release; 120 120 + Focus.request x; 121 121 + focused := focused_idx - 1); 122 122 + `Handled 123 123 + | _ -> 124 124 + `Unhandled 125 125 + else fun _ -> `Unhandled)) 126 126 + |> Border_box.with_border_attr 127 127 + (let$ focus = focus |> Focus.status |>$ Focus.has_focus in 128 128 + if focus then A.fg A.blue else A.empty) 129 129 + ;;

+35

forks/nottui/nottui.opam

reviewed

··· 1 1 + # This file is generated by dune, edit dune-project instead 2 2 + opam-version: "2.0" 3 3 + synopsis: "UI toolkit for the terminal built on top of Notty and Lwd" 4 4 + maintainer: ["fred@tarides.com" "eli.jambu@gmail.com"] 5 5 + authors: ["Frédéric Bour" "Eli Dowling"] 6 6 + license: "MIT" 7 7 + homepage: "https://github.com/flador20/nottui" 8 8 + doc: "https://let-def.github.io/lwd/doc" 9 9 + bug-reports: "https://github.com/flador20/nottui/issues" 10 10 + depends: [ 11 11 + "dune" {>= "3.5"} 12 12 + "lwd" {= version} 13 13 + "notty" {>= "0.2"} 14 14 + "cbor" {with-test} 15 15 + "containers" {with-test} 16 16 + "odoc" {with-doc} 17 17 + ] 18 18 + build: [ 19 19 + ["dune" "subst"] {dev} 20 20 + [ 21 21 + "dune" 22 22 + "build" 23 23 + "-p" 24 24 + name 25 25 + "-j" 26 26 + jobs 27 27 + "@install" 28 28 + "@runtest" {with-test} 29 29 + "@doc" {with-doc} 30 30 + ] 31 31 + ] 32 32 + dev-repo: "git+https://github.com/flador20/nottui.git" 33 33 + pin-depends: [ 34 34 + ["lwd.dev" "git+https://github.com/faldor20/lwd#c19bc2fd55c2de977cdd283458ce06402b08febe"] 35 35 + ]

+3

forks/nottui/nottui.opam.template

reviewed

··· 1 1 + pin-depends: [ 2 2 + ["lwd.dev" "git+https://github.com/faldor20/lwd#c19bc2fd55c2de977cdd283458ce06402b08febe"] 3 3 + ]

+471

forks/nottui/tutorial/hackernews/tutorial.md

reviewed

··· 1 1 + # Building a HackerNews-like Interface with OCaml 2 2 + 3 3 + ## Introduction 4 4 + 5 5 + This tutorial will guide you through creating a HackerNews-like interface using Nottui. You'll learn how to render values, do styling, handle user input, create selection lists, and make popups. By the end of this tutorial, you'll have a functional, interactive UI that mimics some of HackerNews' core features. 6 6 + 7 7 + ## Table of Contents 8 8 + 9 9 + 1. Preliminary Setup 10 10 + 2. First Iteration: Post Rendering 11 11 + 3. Expanding the Application 12 12 + - Styling Improvements 13 13 + - Keyboard Input Handling 14 14 + - Selection Lists 15 15 + - Popups and Focus Management 16 16 + - Implementing Post Sorting 17 17 + 18 18 + ## 1. Preliminary Setup 19 19 + 20 20 + Let's start by ensuring everything works properly: 21 21 + 22 22 + 1. Create a file named `hackernews.ml` with the following test content: 23 23 + 24 24 + ```ocaml 25 25 + open Nottui 26 26 + open Notty 27 27 + open Hackernews_api 28 28 + 29 29 + (*Build a ui*) 30 30 + let main_ui = 31 31 + W.vbox[ 32 32 + W.string "hello world"|>Lwd.pure 33 33 + ] 34 34 + (*Start the nottui process with our built up ui*) 35 35 + let () = Nottui.Ui_loop.run ~quit_on_escape:false main_ui 36 36 + ``` 37 37 + 38 38 + 2. Run `dune exec hackernews.exe`. You should see a friendly greeting message. 39 39 + 40 40 + ## 2. First Iteration: Post Rendering 41 41 + 42 42 + ### 2.1 Creating the Post UI 43 43 + 44 44 + We'll begin by rendering our posts. Here's the code for our `post_ui` function: 45 45 + 46 46 + ```ocaml 47 47 + let post_ui ({ title; url; score; comments; _ } : Hackernews_api.post) : ui Lwd.t = 48 48 + let website = List.nth (String.split_on_char '/' url) 2 in 49 49 + Ui.vcat 50 50 + [ Ui.hcat 51 51 + [ W.string ~attr:A.(st bold) title; W.printf ~attr:A.(st italic) "(%s)" website ] 52 52 + ; Ui.hcat 53 53 + [ W.printf ~attr:A.(st italic) "%d points" score 54 54 + ; W.printf ~attr:A.(st italic) "%d comments" comments 55 55 + ] 56 56 + ] 57 57 + |> Lwd.pure 58 58 + |> W.Box.focusable 59 59 + ;; 60 60 + ``` 61 61 + 62 62 + Let's break it down piece by piece: 63 63 + 64 64 + 1. Extract the website domain from the URL: 65 65 + 66 66 + ```ocaml 67 67 + let website = List.nth (String.split_on_char '/' url) 2 in 68 68 + ``` 69 69 + 70 70 + 2. Create two horizontal rows stacked vertically: 71 71 + 72 72 + ```ocaml 73 73 + Ui.vcat 74 74 + [ Ui.hcat 75 75 + [(* *)] 76 76 + ; Ui.hcat 77 77 + [ (* *)] 78 78 + ] 79 79 + ``` 80 80 + 81 81 + 3. Set text styling: 82 82 + The `~attr` parameter allows us to set styling for text. In this case, we set the style to bold. 83 83 + We can also use `A.fg` to set the foreground color or `A.bg` to set the background color. 84 84 + (See: [TODO: Add link to styling documentation] for more info) 85 85 + 86 86 + ```ocaml 87 87 + W.string ~attr:A.(st bold) title; 88 88 + ``` 89 89 + 90 90 + 4. Use `Lwd.pure`: 91 91 + `Lwd.pure` has the signature `'a -> 'a Lwd.t`. It's a way to take static UI (or any data) and make it play nice with functions that take reactive `Lwd.t` values. 92 92 + You'll always need to use this to incorporate UI elements that don't depend on reactive data into the rest of your UI. 93 93 + 94 94 + ```ocaml 95 95 + |> Lwd.pure 96 96 + ``` 97 97 + 98 98 + 5. Add a focusable border: 99 99 + This puts a border around our post. Because we use a focusable box, it will highlight when focused, which can be changed using `Alt+Up` or `Alt+Down`. 100 100 + 101 101 + ```ocaml 102 102 + |> W.Box.focusable 103 103 + ``` 104 104 + 105 105 + ### 2.2 Creating the Main UI 106 106 + 107 107 + Now we need some posts to render. We'll use a fake version of the HackerNews API for now: 108 108 + 109 109 + ```ocaml 110 110 + let main_ui : ui Lwd.t = 111 111 + let posts = Hackernews_api.fake_posts () in 112 112 + posts |> List.map post_ui |> W.vbox 113 113 + ;; 114 114 + ``` 115 115 + 116 116 + Note that we used `W.vbox` rather than `Ui.vcat`. That's because each item is now a `Ui.t Lwd.t`, and `Ui.vcat` only accepts `Ui.t`. 117 117 + 118 118 + Typically, you'll use `Ui.*` functions for creating small pieces of UI and `W.*` functions for larger transformations. For example, `Ui.string` creates a single string, while `W.Scroll.area` makes any UI scrollable. 119 119 + 120 120 + ## 3. Expanding the Application 121 121 + 122 122 + Now that we have an MVP that shows our basic data rendering the way we want, let's expand it. 123 123 + 124 124 + In this chapter we will:\ 125 125 + 1. Make our styling a little nicer 126 126 + 2. learn about how to handle keybaord input 127 127 + 3. Make selection lists 128 128 + 4. Make popups and move focus around 129 129 + 5. Use all that to make a popup allowing the user to select how they want posts sorted 130 130 + 131 131 + ### 3.1 Styling Improvements 132 132 + 133 133 + Let's update our `post_ui` function with some styling enhancements: 134 134 + 135 135 + ```ocaml 136 136 + let post_ui ({ title; url; score; comments; _ } : Hackernews_api.post) = 137 137 + let website = List.nth (String.split_on_char '/' url) 2 in 138 138 + Ui.vcat 139 139 + [ Ui.hcat 140 140 + [ W.string ~attr:A.(st bold) title 141 141 + ; W.string " " 142 142 + ; W.printf ~attr:A.(st italic ++ fg lightblack) "(%s)" website 143 143 + ] 144 144 + ; Ui.hcat 145 145 + [ W.printf ~attr:A.(st italic) "%d points" score 146 146 + ; W.string " " 147 147 + ; W.printf ~attr:A.(st italic) "%d comments" comments 148 148 + ] 149 149 + ] 150 150 + |> Ui.resize ~sw:1 ~mw:10000 151 151 + |> Lwd.pure 152 152 + |> W.Box.focusable 153 153 + ;; 154 154 + 155 155 + ``` 156 156 + 157 157 + The main change here is making our items stretch to fill the entire screen. We do this by setting the **stretch width** (`sw`) to a non-zero value and also setting our **max width** (`mw`) to a value much wider than a screen could ever be. By default, `max_width` is the same as the object's width. 158 158 + 159 159 + ```ocaml 160 160 + |> Ui.resize ~sw:1 ~mw:10000 161 161 + ``` 162 162 + 163 163 + We've also added spacing between elements for improved readability. 164 164 + 165 165 + ### 3.2 Implementing Sorting 166 166 + 167 167 + First, let's set up some variables to store our state. For a simple UI, we'll keep these in the global scope, but for more modular designs, you might want to put these inside the function they are relevant to. 168 168 + 169 169 + These variables will be `Lwd.var`s. An `Lwd.var` is essentially a `ref` that can be turned into an `Lwd.t` that reacts to the var being set. 170 170 + 171 171 + - `show_prompt_var`: Defines if the prompt is shown, and if so, what content to show 172 172 + - `sorting_mode_var`: Stores how we should sort the posts 173 173 + 174 174 + ```ocaml 175 175 + let show_prompt_var = Lwd.var None 176 176 + let sorting_mode_var = Lwd.var `Points 177 177 + ``` 178 178 + 179 179 + 180 180 + ### 3.3 Creating the Sorting Prompt 181 181 + 182 182 + We will see how this function fits together. 183 183 + 184 184 + ```ocaml 185 185 + let sorting_prompt ui = 186 186 + let open W.Overlay in 187 187 + let open W.Lists in 188 188 + let res = 189 189 + ui 190 190 + |> W.Overlay.selection_list_prompt 191 191 + ~modify_body:(Lwd.map ~f:(Ui.resize ~sw:1 ~mw:20)) 192 192 + ~show_prompt_var 193 193 + |>$ Ui.keyboard_area (function 194 194 + | `ASCII 's', [] -> 195 195 + (*funcion to handle when the prompt is closed using escape or enter *) 196 196 + let on_exit x = 197 197 + match x with 198 198 + | `Closed -> () 199 199 + | `Finished sorting -> sorting_mode_var $= sorting 200 200 + in 201 201 + let prompt = 202 202 + { label = "Sorting method" 203 203 + ; items = 204 204 + Lwd.pure 205 205 + [ { data = `Points; ui = W.Lists.selectable_item (W.string "Points") } 206 206 + ; { data = `Comments; ui = W.Lists.selectable_item (W.string "Comments") } 207 207 + ] 208 208 + ; on_exit 209 209 + } 210 210 + in 211 211 + show_prompt_var $= Some prompt; 212 212 + `Handled 213 213 + | _ -> `Unhandled) 214 214 + in 215 215 + res 216 216 + ;; 217 217 + 218 218 + ``` 219 219 + 220 220 + Let's add the overlay to our main UI and give it the var that controls the prompt. We'll also make the body stretchable to give our prompt some space: 221 221 + 222 222 + ```ocaml 223 223 + |> W.Overlay.selection_list_prompt 224 224 + ~modify_body:(Lwd.map ~f:(Ui.resize ~sw:1 ~mw:20)) 225 225 + ~show_prompt_var 226 226 + ``` 227 227 + 228 228 + Next, we'll process keyboard inputs. When 's' is pressed, we'll set the `show_prompt_var` to our prompt: 229 229 + 230 230 + ```ocaml 231 231 + |>$ Ui.keyboard_area (function 232 232 + | `ASCII 's', [] -> 233 233 + (*funcion to handle when the prompt is closed using escape or enter *) 234 234 + let on_exit x = 235 235 + match x with 236 236 + | `Closed -> () 237 237 + | `Finished sorting -> sorting_mode_var $= sorting 238 238 + in 239 239 + let prompt = 240 240 + { label = "Sorting method" 241 241 + ; items = 242 242 + Lwd.pure 243 243 + [ { data = `Points; ui = W.Lists.selectable_item (W.string "Points") } 244 244 + ; { data = `Comments; ui = W.Lists.selectable_item (W.string "Comments") } 245 245 + ] 246 246 + ; on_exit 247 247 + } 248 248 + in 249 249 + show_prompt_var $= Some prompt; 250 250 + `Handled 251 251 + | _ -> `Unhandled) 252 252 + ``` 253 253 + 254 254 + Notice how we used the `$=` operator to assign a value to the `Lwd.var`. This is just an alias to `Lwd.set` that looks a little nicer: 255 255 + 256 256 + ```ocaml 257 257 + | `Finished sorting -> sorting_mode_var $= sorting 258 258 + ``` 259 259 + 260 260 + Here's a helper function to choose the sorting method: 261 261 + 262 262 + ```ocaml 263 263 + let get_sort_func sorting = 264 264 + match sorting with 265 265 + | `Points -> fun a b -> Int.compare b.score a.score 266 266 + | `Comments -> fun a b -> Int.compare b.comments a.comments 267 267 + ;; 268 268 + 269 269 + ``` 270 270 + 271 271 + ### 3.4 Putting it all together 272 272 + 273 273 + We've extended the posts generation to include a sorting step using our selected sorting function. We've also added a section at the bottom to show the key the user should press to open the sorting prompt: 274 274 + 275 275 + ```ocaml 276 276 + let shortcuts = Ui.vcat [ Ui.hcat [ W.string "[S]orting" ] ] 277 277 + 278 278 + let main_ui = 279 279 + let sorted_by_ui = 280 280 + let$ sorting = Lwd.get sorting_mode_var in 281 281 + (match sorting with 282 282 + | `Points -> "Points" 283 283 + | `Comments -> "Comments") 284 284 + |> W.fmt "Sorted by %s" 285 285 + in 286 286 + let posts = 287 287 + let$* sort_mode = Lwd.get sorting_mode_var in 288 288 + let sort_func = get_sort_func sort_mode in 289 289 + Hackernews_api.fake_posts () 290 290 + |> List.sort sort_func 291 291 + |> List.map post_ui 292 292 + |> W.vbox 293 293 + |> W.Scroll.v_area 294 294 + in 295 295 + W.vbox 296 296 + [ 297 297 + sorted_by_ui|>W.Box.box ~pad_w:1 ~pad_h:0; 298 298 + posts |> W.Box.box ~pad_w:1 ~pad_h:0 299 299 + ; shortcuts |> Ui.resize ~sw:1 ~mw:10000 |> Lwd.pure |> W.Box.box ~pad_w:1 ~pad_h:0 300 300 + ] 301 301 + |> sorting_prompt 302 302 + ;; 303 303 + 304 304 + 305 305 + ``` 306 306 + 307 307 + Note that we pass all the other UI into the sorting prompt because we want it to pop up over everything: 308 308 + 309 309 + ```ocaml 310 310 + W.vbox 311 311 + [ 312 312 + sorted_by_ui|>W.Box.box ~pad_w:1 ~pad_h:0; 313 313 + posts |> W.Box.box ~pad_w:1 ~pad_h:0 314 314 + ; shortcuts |> Ui.resize ~sw:1 ~mw:10000 |> Lwd.pure |> W.Box.box ~pad_w:1 ~pad_h:0 315 315 + ] 316 316 + |> sorting_prompt 317 317 + ;; 318 318 + 319 319 + ``` 320 320 + 321 321 + Let's add a status indicator to show the current sorting mode: 322 322 + 323 323 + ```ocaml 324 324 + let sorted_by_ui = 325 325 + let$ sorting = Lwd.get sorting_mode_var in 326 326 + (match sorting with 327 327 + | `Points -> "Points" 328 328 + | `Comments -> "Comments") 329 329 + |> W.fmt "Sorted by %s" 330 330 + in 331 331 + ``` 332 332 + 333 333 + This is our first use of `let$`! We're finally making a piece of UI that is reactive to changes. In this case, this UI will update whenever `sorting_mode_var` changes. 334 334 + 335 335 + `let$` is syntactic sugar for `Lwd.map`. Just like `List.map`, it allows us to apply a transformation function to the contents of the `Lwd.t`. We also use `Lwd.get` to turn our `Lwd.var` into an `Lwd.t` as described earlier. 336 336 + 337 337 + The equivalent code to `let$` is: 338 338 + 339 339 + ```ocaml 340 340 + Lwd.get sorting_mode_var |> Lwd.map ~f:(fun sort_mode -> 341 341 + (*..rest...*) 342 342 + ``` 343 343 + 344 344 + Here we see `let$*`, which is similar to `let$` except that it is `Lwd.bind`. It's necessary when the result of the transformation is itself an `Lwd.t`. You're likely familiar with `Result.bind`, which behaves similarly. 345 345 + 346 346 + ```ocaml 347 347 + let posts = 348 348 + let$* sort_mode = Lwd.get sorting_mode_var in 349 349 + let sort_func = get_sort_func sort_mode in 350 350 + Hackernews_api.fake_posts () 351 351 + |> List.sort sort_func 352 352 + |> List.map post_ui 353 353 + |> W.vbox 354 354 + |> W.Scroll.v_area 355 355 + in 356 356 + ``` 357 357 + 358 358 + In general, `let$*` should be avoided because it causes whatever is inside it to be fully recomputed when the `Lwd.t` it is binding on changes. However, in this case, that makes sense because our list will have to be fully re-sorted anyway. 359 359 + 360 360 + In the next chapter, you'll see more use of both `let$` and `let$*`. 361 361 + 362 362 + That's it! You've now created a HackerNews-like interface with OCaml, complete with post rendering, sorting functionality, and an interactive UI. Here's the full source code for reference: 363 363 + 364 364 + ```ocaml 365 365 + open Nottui 366 366 + open Notty 367 367 + open Hackernews_api 368 368 + open Lwd_infix 369 369 + 370 370 + let post_ui ({ title; url; score; comments; _ } : Hackernews_api.post) = 371 371 + let website = List.nth (String.split_on_char '/' url) 2 in 372 372 + Ui.vcat 373 373 + [ Ui.hcat 374 374 + [ W.string ~attr:A.(st bold) title 375 375 + ; W.string " " 376 376 + ; W.printf ~attr:A.(st italic ++ fg lightblack) "(%s)" website 377 377 + ] 378 378 + ; Ui.hcat 379 379 + [ W.printf ~attr:A.(st italic) "%d points" score 380 380 + ; W.string " " 381 381 + ; W.printf ~attr:A.(st italic) "%d comments" comments 382 382 + ] 383 383 + ] 384 384 + |> Ui.resize ~sw:1 ~mw:10000 385 385 + |> Lwd.pure 386 386 + |> W.Box.focusable 387 387 + ;; 388 388 + 389 389 + 390 390 + let show_prompt_var = Lwd.var None 391 391 + let sorting_mode_var = Lwd.var `Points 392 392 + 393 393 + let sorting_prompt ui = 394 394 + let open W.Overlay in 395 395 + let open W.Lists in 396 396 + let res = 397 397 + ui 398 398 + |> W.Overlay.selection_list_prompt 399 399 + ~modify_body:(Lwd.map ~f:(Ui.resize ~sw:1 ~mw:20)) 400 400 + ~show_prompt_var 401 401 + |>$ Ui.keyboard_area (function 402 402 + | `ASCII 's', [] -> 403 403 + (*funcion to handle when the prompt is closed using escape or enter *) 404 404 + let on_exit x = 405 405 + match x with 406 406 + | `Closed -> () 407 407 + | `Finished sorting -> sorting_mode_var $= sorting 408 408 + in 409 409 + let prompt = 410 410 + { label = "Sorting method" 411 411 + ; items = 412 412 + Lwd.pure 413 413 + [ { data = `Points; ui = W.Lists.selectable_item (W.string "Points") } 414 414 + ; { data = `Comments; ui = W.Lists.selectable_item (W.string "Comments") } 415 415 + ] 416 416 + ; on_exit 417 417 + } 418 418 + in 419 419 + show_prompt_var $= Some prompt; 420 420 + `Handled 421 421 + | _ -> `Unhandled) 422 422 + in 423 423 + res 424 424 + ;; 425 425 + 426 426 + 427 427 + let get_sort_func sorting = 428 428 + match sorting with 429 429 + | `Points -> fun a b -> Int.compare b.score a.score 430 430 + | `Comments -> fun a b -> Int.compare b.comments a.comments 431 431 + ;; 432 432 + 433 433 + 434 434 + let shortcuts = Ui.vcat [ Ui.hcat [ W.string "[S]orting" ] ] 435 435 + 436 436 + let main_ui = 437 437 + let sorted_by_ui = 438 438 + let$ sorting = Lwd.get sorting_mode_var in 439 439 + (match sorting with 440 440 + | `Points -> "Points" 441 441 + | `Comments -> "Comments") 442 442 + |> W.fmt "Sorted by %s" 443 443 + in 444 444 + let posts = 445 445 + let$* sort_mode = Lwd.get sorting_mode_var in 446 446 + let sort_func = get_sort_func sort_mode in 447 447 + Hackernews_api.fake_posts () 448 448 + |> List.sort sort_func 449 449 + |> List.map post_ui 450 450 + |> W.vbox 451 451 + |> W.Scroll.v_area 452 452 + in 453 453 + W.vbox 454 454 + [ 455 455 + sorted_by_ui|>W.Box.box ~pad_w:1 ~pad_h:0; 456 456 + posts |> W.Box.box ~pad_w:1 ~pad_h:0 457 457 + ; shortcuts |> Ui.resize ~sw:1 ~mw:10000 |> Lwd.pure |> W.Box.box ~pad_w:1 ~pad_h:0 458 458 + ] 459 459 + |> sorting_prompt 460 460 + ;; 461 461 + 462 462 + 463 463 + 464 464 + let () = Nottui.Ui_loop.run ~quit_on_escape:false main_ui 465 465 + 466 466 + ``` 467 467 + 468 468 + ## Wrap up 469 469 + 470 470 + I hope this was helpful, and you've now got some idea how to put together a nottui app. If you have any feedback please make an issue on the repo, or message me @faldor20 on the ocaml discord. 471 471 +

+7

forks/nottui/tutorial/src/build_tutorial.sh

reviewed

··· 1 1 + # Run the tangling 2 2 + 3 3 + parent_path=$( cd "$(dirname "${BASH_SOURCE[0]}")" ; pwd -P ) 4 4 + 5 5 + pushd "$parent_path" 6 6 + dune exec ../../tutorial/src/tangle.exe ./hackernews/bin ../hackernews 7 7 + popd

+5

forks/nottui/tutorial/src/dune

reviewed

··· 1 1 + (executable 2 2 + (name tangle) 3 3 + (libraries re iter base angstrom) 4 4 + (preprocess (pps ppx_let)) 5 5 + )

+91

forks/nottui/tutorial/src/hackernews/bin/comments.ml

reviewed

··· 1 1 + open! Nottui 2 2 + open! Notty 3 3 + open! Hackernews_api 4 4 + open! Lwd_infix 5 5 + 6 6 + (* Remeber to try to split your ui components into small helper functions so they can be easily composed*) 7 7 + let make_comment_ui_attr ~attr (comment : comment Lwd.t) = 8 8 + let comment_content = 9 9 + let$ { by; text; kids; _ } = comment in 10 10 + Ui.vcat [ W.string text; W.fmt "by: %s replies: %d" by (kids |> List.length) ] 11 11 + in 12 12 + W.vbox [ comment_content |> W.Box.with_border_attr attr ] 13 13 + ;; 14 14 + 15 15 + let make_comment_ui ?(focus = Focus.make ()) (comment : comment Lwd.t) = 16 16 + make_comment_ui_attr 17 17 + ~attr: 18 18 + (focus 19 19 + |> Focus.status 20 20 + |>$ fun focus -> if Focus.has_focus focus then A.(fg blue) else A.empty) 21 21 + comment 22 22 + ;; 23 23 + 24 24 + let comment_children_view ?(focus = Focus.make ()) comments_view_state = 25 25 + (* Make a view for a parent component*) 26 26 + let parent_ui = 27 27 + let$* state = Lwd.get comments_view_state in 28 28 + state 29 29 + |> List.hd 30 30 + |> fst 31 31 + |> Option.map (fun x -> make_comment_ui (x |> Lwd.pure)) 32 32 + |> Option.value ~default:(Ui.empty |> Lwd.pure) 33 33 + in 34 34 + (*Render all the children*) 35 35 + let children_ui = 36 36 + let items_ui = 37 37 + let$ state = Lwd.get comments_view_state in 38 38 + state 39 39 + |> List.hd 40 40 + |> snd 41 41 + |> List.map (fun x -> 42 42 + W.Lists. 43 43 + { data = x 44 44 + ; ui = 45 45 + W.Lists.selectable_item_lwd 46 46 + (W.hbox [ W.string "--" |> Lwd.pure; make_comment_ui (x |> Lwd.pure) ]) 47 47 + }) 48 48 + in 49 49 + (*Handle keyboard events*) 50 50 + items_ui 51 51 + |> W.Lists.selection_list_custom ~focus ~custom_handler:(fun item key -> 52 52 + match key with 53 53 + | `Enter, [] -> 54 54 + if item.data.kids |> List.length > 0 55 55 + then 56 56 + (*Because we are rendering a tree of comments we will push this new comment and it's children to the head of the list, 57 57 + that way if we want to exit we just drop the head to go up the tree of comments we have navigated through*) 58 58 + comments_view_state 59 59 + |> Lwd.update (fun x -> 60 60 + ( Some item.data 61 61 + , item.data.kids 62 62 + |> List.map (Hackernews_api.generate_fake_comment item.data.id) ) 63 63 + :: x); 64 64 + `Handled 65 65 + | _ -> `Unhandled) 66 66 + in 67 67 + (*Render all the children below the parent*) 68 68 + W.vbox [ parent_ui; children_ui ] 69 69 + |>$ Ui.resize ~sw:1 ~mw:10000 70 70 + |> W.Box.focusable ~focus ~on_key:(function 71 71 + | `Escape, [] -> 72 72 + let view_state = Lwd.peek comments_view_state in 73 73 + (*If we are at least one comment deep, we should just go back to the parent comment view state*) 74 74 + if view_state |> List.length > 1 75 75 + then comments_view_state $= (view_state |> List.tl) 76 76 + else Focus.release_reversable focus; 77 77 + `Handled 78 78 + | _ -> `Unhandled) 79 79 + ;; 80 80 + 81 81 + let comments_view ?(focus = Focus.make ()) (post : post option Lwd.t) : ui Lwd.t = 82 82 + let$* post = post in 83 83 + match post with 84 84 + | None -> Ui.empty |> Lwd.pure 85 85 + | Some post -> 86 86 + let children = post.kids |> List.map (Hackernews_api.generate_fake_comment post.id) in 87 87 + (*We are using a list instead of just one variable becasue we want to be able to "undo" if we open a child comment. 88 88 + Opening a child comment means appending that comment to the list and going back to it's parent means removing the head of the list*) 89 89 + let comment_var = [ None, children ] |> Lwd.var in 90 90 + comment_var |> comment_children_view ~focus 91 91 + ;;

+13

forks/nottui/tutorial/src/hackernews/bin/dune

reviewed

··· 1 1 + (executable 2 2 + (name hackernews_1) 3 3 + (libraries notty notty.unix nottui)) 4 4 + 5 5 + (executable 6 6 + (name hackernews_2) 7 7 + (libraries notty notty.unix nottui)) 8 8 + 9 9 + (executable 10 10 + (name hackernews_3) 11 11 + (libraries notty notty.unix nottui)) 12 12 + 13 13 +

+67

forks/nottui/tutorial/src/hackernews/bin/focus_test.ml

reviewed

··· 1 1 + (*open Nottui 2 2 + open Lwd_infix 3 3 + 4 4 + let selected_item = Lwd.var 0 5 5 + let selectable_lwd = Lwd.get selected_item 6 6 + 7 7 + let selectable ?(focus = Focus.make ()) id = 8 8 + let selected = 9 9 + let$ focus = Focus.status focus in 10 10 + (*set the focus watcher*) 11 11 + let focused = Focus.has_focus focus in 12 12 + if focused && Lwd.peek selected_item <> id then Some id else None 13 13 + in 14 14 + let a = 15 15 + let$ focus = Focus.status focus in 16 16 + (*set the focus watcher*) 17 17 + let focused = Focus.has_focus focus in 18 18 + if focused && Lwd.peek selected_item <> id then selected_item $= id; 19 19 + W.printf "hi %d focused?:%b" id focused 20 20 + |> Ui.keyboard_area ~focus (fun _ -> `Unhandled) 21 21 + in 22 22 + a, selected 23 23 + ;; 24 24 + 25 25 + let main = 26 26 + let ui, selection = [ 1; 2; 3 ] |> List.map selectable |> List.to_seq |> Seq.unzip in 27 27 + let se = 28 28 + selection 29 29 + |> List.of_seq 30 30 + |> Lwd_seq.of_list 31 31 + |> Lwd.pure 32 32 + |> Lwd_seq.lift 33 33 + |> Lwd_seq.fold_monoid 34 34 + (fun x -> x) 35 35 + (None, fun x y -> if x |> Option.is_some then x else y) 36 36 + in 37 37 + W.hbox [ W.vbox (ui |> List.of_seq); se |>$ Option.value ~default:0 |>$ W.int ] 38 38 + ;; 39 39 + *) 40 40 + 41 41 + open Nottui 42 42 + open Lwd_infix 43 43 + 44 44 + let selected_item = Lwd.var 0 45 45 + let selectable_lwd = Lwd.get selected_item 46 46 + 47 47 + let selectable ?(focus = Focus.make ()) id = 48 48 + let a = 49 49 + let$ focus = Focus.status focus in 50 50 + (*set the focus watcher*) 51 51 + let focused = Focus.has_focus focus in 52 52 + if focused && Lwd.peek selected_item <> id then selected_item $= id; 53 53 + W.printf "hi %d focused?:%b" id focused 54 54 + |> Ui.keyboard_area ~focus (fun _ -> `Unhandled) 55 55 + in 56 56 + a |> Lwd.fix ~wrt:selectable_lwd 57 57 + ;; 58 58 + 59 59 + let main = 60 60 + W.hbox 61 61 + [ W.vbox ([ 1; 2; 3 ] |> List.map selectable) |> Lwd.fix ~wrt:selectable_lwd 62 62 + ; (let$ selected_item = selectable_lwd in 63 63 + selected_item |> W.int) 64 64 + |> Lwd.fix ~wrt:selectable_lwd 65 65 + ] 66 66 + |> Lwd.fix ~wrt:selectable_lwd 67 67 + ;;

+50

forks/nottui/tutorial/src/hackernews/bin/hackernews_1.ml

reviewed

··· 1 1 + open Nottui 2 2 + open Notty 3 3 + open Hackernews_api 4 4 + 5 5 + (* 6 6 + $#S1 7 7 + open Nottui 8 8 + open Notty 9 9 + open Hackernews_api 10 10 + 11 11 + (*Build a ui*) 12 12 + let main_ui = 13 13 + W.vbox[ 14 14 + W.string "hello world"|>Lwd.pure 15 15 + ] 16 16 + (*Start the nottui process with our built up ui*) 17 17 + let () = Nottui.Ui_loop.run ~quit_on_escape:false main_ui 18 18 + $#E1 19 19 + *) 20 20 + 21 21 + 22 22 + (* We can make a heper function to render a post *) 23 23 + (*$#S2*) 24 24 + let post_ui ({ title; url; score; comments; _ } : Hackernews_api.post) : ui Lwd.t = 25 25 + (*$#S3*) 26 26 + let website = List.nth (String.split_on_char '/' url) 2 in 27 27 + (*$#E3*) 28 28 + Ui.vcat 29 29 + [ Ui.hcat 30 30 + [ W.string ~attr:A.(st bold) title; W.printf ~attr:A.(st italic) "(%s)" website ] 31 31 + ; Ui.hcat 32 32 + [ W.printf ~attr:A.(st italic) "%d points" score 33 33 + ; W.printf ~attr:A.(st italic) "%d comments" comments 34 34 + ] 35 35 + ] 36 36 + |> Lwd.pure 37 37 + |> W.Box.focusable 38 38 + ;; 39 39 + (*$#E2*) 40 40 + 41 41 + (*Generate some posts and render them using our post_renderer*) 42 42 + (*$#S4*) 43 43 + let main_ui : ui Lwd.t = 44 44 + let posts = Hackernews_api.fake_posts () in 45 45 + posts |> List.map post_ui |> W.vbox 46 46 + ;; 47 47 + (*$#E4*) 48 48 + 49 49 + (*Start the nottui process with our built up ui*) 50 50 + let () = Nottui.Ui_loop.run ~quit_on_escape:false main_ui

+123

forks/nottui/tutorial/src/hackernews/bin/hackernews_2.ml

reviewed

··· 1 1 + (*$#S13*) 2 2 + open Nottui 3 3 + open Notty 4 4 + open Hackernews_api 5 5 + open Lwd_infix 6 6 + 7 7 + (*$#S5*) 8 8 + let post_ui ({ title; url; score; comments; _ } : Hackernews_api.post) = 9 9 + let website = List.nth (String.split_on_char '/' url) 2 in 10 10 + Ui.vcat 11 11 + [ Ui.hcat 12 12 + [ W.string ~attr:A.(st bold) title 13 13 + ; W.string " " 14 14 + ; W.printf ~attr:A.(st italic ++ fg lightblack) "(%s)" website 15 15 + ] 16 16 + ; Ui.hcat 17 17 + [ W.printf ~attr:A.(st italic) "%d points" score 18 18 + ; W.string " " 19 19 + ; W.printf ~attr:A.(st italic) "%d comments" comments 20 20 + ] 21 21 + ] 22 22 + |> Ui.resize ~sw:1 ~mw:10000 23 23 + |> Lwd.pure 24 24 + |> W.Box.focusable 25 25 + ;; 26 26 + 27 27 + (*$#E5*) 28 28 + 29 29 + (*$#S6*) 30 30 + let show_prompt_var = Lwd.var None 31 31 + let sorting_mode_var = Lwd.var `Points 32 32 + (*$#E6*) 33 33 + 34 34 + (*$#S7*) 35 35 + let sorting_prompt ui = 36 36 + let open W.Overlay in 37 37 + let open W.Lists in 38 38 + let res = 39 39 + ui 40 40 + (*$#S8*) 41 41 + |> W.Overlay.selection_list_prompt 42 42 + ~modify_body:(Lwd.map ~f:(Ui.resize ~sw:1 ~mw:20)) 43 43 + ~show_prompt_var 44 44 + (*$#E8*) 45 45 + (*$#S9*) 46 46 + |>$ Ui.keyboard_area (function 47 47 + | `ASCII 's', [] -> 48 48 + (*funcion to handle when the prompt is closed using escape or enter *) 49 49 + let on_exit x = 50 50 + match x with 51 51 + | `Closed -> () 52 52 + | `Finished sorting -> sorting_mode_var $= sorting 53 53 + in 54 54 + let prompt = 55 55 + { label = "Sorting method" 56 56 + ; items = 57 57 + Lwd.pure 58 58 + [ { data = `Points; ui = W.Lists.selectable_item (W.string "Points") } 59 59 + ; { data = `Comments; ui = W.Lists.selectable_item (W.string "Comments") } 60 60 + ] 61 61 + ; on_exit 62 62 + } 63 63 + in 64 64 + show_prompt_var $= Some prompt; 65 65 + `Handled 66 66 + | _ -> `Unhandled) 67 67 + (*$#E9*) 68 68 + in 69 69 + res 70 70 + ;; 71 71 + 72 72 + (*$#E7*) 73 73 + 74 74 + (*$#S10*) 75 75 + let get_sort_func sorting = 76 76 + match sorting with 77 77 + | `Points -> fun a b -> Int.compare b.score a.score 78 78 + | `Comments -> fun a b -> Int.compare b.comments a.comments 79 79 + ;; 80 80 + 81 81 + (*$#E10*) 82 82 + 83 83 + (*$#S11*) 84 84 + let shortcuts = Ui.vcat [ Ui.hcat [ W.string "[S]orting" ] ] 85 85 + 86 86 + let main_ui = 87 87 + (*$#S15*) 88 88 + let sorted_by_ui = 89 89 + let$ sorting = Lwd.get sorting_mode_var in 90 90 + (match sorting with 91 91 + | `Points -> "Points" 92 92 + | `Comments -> "Comments") 93 93 + |> W.fmt "Sorted by %s" 94 94 + in 95 95 + (*$#E15*) 96 96 + (*$#S14*) 97 97 + let posts = 98 98 + let$* sort_mode = Lwd.get sorting_mode_var in 99 99 + let sort_func = get_sort_func sort_mode in 100 100 + Hackernews_api.fake_posts () 101 101 + |> List.sort sort_func 102 102 + |> List.map post_ui 103 103 + |> W.vbox 104 104 + |> W.Scroll.v_area 105 105 + in 106 106 + (*$#E14*) 107 107 + (*$#S12*) 108 108 + W.vbox 109 109 + [ 110 110 + sorted_by_ui|>W.Box.box ~pad_w:1 ~pad_h:0; 111 111 + posts |> W.Box.box ~pad_w:1 ~pad_h:0 112 112 + ; shortcuts |> Ui.resize ~sw:1 ~mw:10000 |> Lwd.pure |> W.Box.box ~pad_w:1 ~pad_h:0 113 113 + ] 114 114 + |> sorting_prompt 115 115 + ;; 116 116 + 117 117 + (*$#E12*) 118 118 + 119 119 + (*$#E11*) 120 120 + 121 121 + let () = Nottui.Ui_loop.run ~quit_on_escape:false main_ui 122 122 + 123 123 + (*$#E13*)

+117

forks/nottui/tutorial/src/hackernews/bin/hackernews_3.ml

reviewed

··· 1 1 + open Nottui 2 2 + open Notty 3 3 + open Hackernews_api 4 4 + open Lwd_infix 5 5 + 6 6 + let selected_post_var : post option Lwd.var = Lwd.var None 7 7 + 8 8 + let post_ui 9 9 + ?(focus = Focus.make ()) 10 10 + ({ title; url; score; comments; _ } as post : Hackernews_api.post) 11 11 + = 12 12 + let website = List.nth (String.split_on_char '/' url) 2 in 13 13 + let update_focused = 14 14 + let$ focus = Focus.status focus in 15 15 + Lwd.may_update 16 16 + (fun x -> 17 17 + if focus |> Focus.has_focus 18 18 + && x 19 19 + |> Option.map (fun (x : post) -> x.id <> post.id) 20 20 + |> Option.value ~default:true 21 21 + then Some (Some post) 22 22 + else None) 23 23 + selected_post_var 24 24 + in 25 25 + () 26 26 + |> Lwd.pure 27 27 + |> Lwd.fix ~wrt:update_focused 28 28 + (*We map on update_focused becasue we want it in our LWD tree so it updates with the rest of the ui, but we want it at the bottom becasue we don't want aything to re-render becasue of it changing*) 29 29 + |>$ (fun () -> 30 30 + Ui.vcat 31 31 + [ Ui.hcat 32 32 + [ W.string ~attr:A.(st bold) title 33 33 + ; W.string " " 34 34 + ; W.printf ~attr:A.(st italic ++ fg lightblack) "(%s)" website 35 35 + ] 36 36 + ; Ui.hcat 37 37 + [ W.printf ~attr:A.(st italic) "%d points" score 38 38 + ; W.string " " 39 39 + ; W.printf ~attr:A.(st italic) "%d comments" comments 40 40 + ] 41 41 + ] 42 42 + |> Ui.resize ~sw:1 ~mw:10000) 43 43 + |> W.Box.focusable ~focus 44 44 + ;; 45 45 + 46 46 + let shortcuts = Ui.vcat [ Ui.hcat [ W.string "[S]orting" ] ] 47 47 + let show_prompt_var = None |> Lwd.var 48 48 + let sorting_mode_var = Lwd.var `Points 49 49 + 50 50 + let sorting_prompt ui = 51 51 + let open W.Overlay in 52 52 + let open W.Lists in 53 53 + let res = 54 54 + ui 55 55 + |> W.Overlay.selection_list_prompt 56 56 + ~modify_body:(Lwd.map ~f:(Ui.resize ~sw:1 ~mw:20)) 57 57 + ~show_prompt_var 58 58 + |>$ Ui.keyboard_area (function 59 59 + | `ASCII 's', _ -> 60 60 + let on_exit x = 61 61 + match x with 62 62 + | `Closed -> () 63 63 + | `Finished sorting -> sorting_mode_var $= sorting 64 64 + in 65 65 + let prompt = 66 66 + { label = "Sorting method" 67 67 + ; items = 68 68 + Lwd.pure 69 69 + [ { data = `Points; ui = W.Lists.selectable_item (W.string "Points") } 70 70 + ; { data = `Comments; ui = W.Lists.selectable_item (W.string "Comments") } 71 71 + ] 72 72 + ; on_exit 73 73 + } 74 74 + in 75 75 + show_prompt_var $= Some prompt; 76 76 + `Handled 77 77 + | _ -> `Unhandled) 78 78 + in 79 79 + res 80 80 + ;; 81 81 + 82 82 + let get_sort_func sorting = 83 83 + match sorting with 84 84 + | `Points -> fun a b -> Int.compare b.score a.score 85 85 + | `Comments -> fun a b -> Int.compare b.comments a.comments 86 86 + ;; 87 87 + 88 88 + let main_ui = 89 89 + let posts = 90 90 + let$* sort_mode = Lwd.get sorting_mode_var in 91 91 + let sort_func = get_sort_func sort_mode in 92 92 + Hackernews_api.fake_posts () 93 93 + |> List.sort sort_func 94 94 + |> List.map post_ui 95 95 + |> W.vbox 96 96 + |> W.Scroll.v_area 97 97 + in 98 98 + let comments_focus = Focus.make () in 99 99 + W.vbox 100 100 + [ W.hbox 101 101 + [ posts 102 102 + |> W.Box.box ~pad_w:1 ~pad_h:0 103 103 + |>$ Ui.keyboard_area (function 104 104 + | `Enter, [] -> 105 105 + Focus.request_reversable comments_focus; 106 106 + `Handled 107 107 + | _ -> `Unhandled) 108 108 + ; (let _post = Lwd.get selected_post_var in 109 109 + (* "hi"|>W.string|>Lwd.pure *) 110 110 + Comments.comments_view ~focus:comments_focus _post) 111 111 + ] 112 112 + ; shortcuts |> Ui.resize ~sw:1 ~mw:10000 |> Lwd.pure |> W.Box.box ~pad_w:1 ~pad_h:0 113 113 + ] 114 114 + |> sorting_prompt 115 115 + ;; 116 116 + 117 117 + let () = Nottui.Ui_loop.run ~quit_on_escape:false main_ui

+90

forks/nottui/tutorial/src/hackernews/bin/hackernews_api.ml

reviewed

··· 1 1 + type post = { 2 2 + id : int; 3 3 + title : string; 4 4 + url : string; 5 5 + score : int; 6 6 + comments : int; 7 7 + kids: int list; 8 8 + } 9 9 + 10 10 + (** generates a list of child ids, skewed twards low numbers *) 11 11 + let generate_kids_list()= 12 12 + 13 13 + List.init (Float.pow ((Random.float 10.0)/. 3.0) 6.0|>Int.of_float) (fun _ -> Random.int 10000000 + 2000000) 14 14 + 15 15 + (** returns a list of posts from hackernews*) 16 16 + let fake_posts () = 17 17 + let titles = [ 18 18 + "OCaml 5.0 Released: What’s New?"; 19 19 + "Why Functional Programming Matters"; 20 20 + "Building Scalable Systems with OCaml"; 21 21 + "Understanding Type Systems"; 22 22 + "Introduction to Category Theory"; 23 23 + "The Future of Multi-Core OCaml"; 24 24 + "How to Contribute to Open Source Projects"; 25 25 + "OCaml vs Haskell: A Comparison"; 26 26 + "Getting Started with MirageOS"; 27 27 + "Real-World Applications of OCaml" 28 28 + ] in 29 29 + let urls = [ 30 30 + "https://ocaml.com/ocaml-5-released"; 31 31 + "https://functional.com/functional-programming-matters"; 32 32 + "https://scaleable.com/building-scalable-systems"; 33 33 + "https://understanding.com/understanding-type-systems"; 34 34 + "https://theory.com/introduction-to-category-theory"; 35 35 + "https://multicore.com/future-of-multicore-ocaml"; 36 36 + "https://contrib.com/contributing-to-open-source"; 37 37 + "https://haskell.com/ocaml-vs-haskell"; 38 38 + "https://migrations.com/getting-started-mirageos"; 39 39 + "https://realworldocaml.com/real-world-applications-ocaml" 40 40 + ] in 41 41 + let rec make_posts ids titles urls scores comments acc = 42 42 + match (ids, titles, urls, scores, comments) with 43 43 + | ([], [], [], [], []) -> List.rev acc 44 44 + | (id::ids_tail, title::titles_tail, url::urls_tail, score::scores_tail, comment::comments_tail) -> 45 45 + let post = {id; title; url; score; comments = comment; kids=generate_kids_list()} in 46 46 + make_posts ids_tail titles_tail urls_tail scores_tail comments_tail (post :: acc) 47 47 + | _ -> acc 48 48 + in 49 49 + let ids = [1; 2; 3; 4; 5; 6; 7; 8; 9; 10] in 50 50 + let scores = [120; 85; 99; 75; 110; 95; 130; 90; 70; 80] in 51 51 + let comments = [15; 25; 30; 20; 35; 40; 50; 45; 10; 5] in 52 52 + make_posts ids titles urls scores comments [] 53 53 + 54 54 + type comment = { 55 55 + by : string; 56 56 + id : int; 57 57 + kids : int list; 58 58 + parent : int; 59 59 + text : string; 60 60 + time : int; 61 61 + comment_type : string; 62 62 + } 63 63 + 64 64 + let generate_fake_comment parent_id comment_id = 65 65 + let authors = ["ocaml_fan"; "functional_guru"; "type_safety_advocate"; "pattern_matcher"; "monad_master"] in 66 66 + let texts = [ 67 67 + "Great article! I've been using OCaml for years and it never ceases to amaze me."; 68 68 + "I disagree with some points, but overall a good read."; 69 69 + "Has anyone tried implementing this in a production environment?"; 70 70 + "This reminds me of a similar approach we took in our project. It worked wonders!"; 71 71 + "I'd love to see a follow-up article exploring this topic further."; 72 72 + "The author makes some interesting points, but I think they're overlooking some key issues."; 73 73 + "This is a game-changer for functional programming. Can't wait to try it out!"; 74 74 + "I'm skeptical about the performance claims. Has anyone done benchmarks?"; 75 75 + "As always, it depends on the specific use case. YMMV."; 76 76 + "I've been waiting for something like this for a long time. Thanks for sharing!" 77 77 + ] in 78 78 + { 79 79 + by = List.nth authors (Random.int (List.length authors)); 80 80 + id = comment_id; 81 81 + kids = generate_kids_list(); 82 82 + parent = parent_id; 83 83 + text = List.nth texts (Random.int (List.length texts)); 84 84 + time = int_of_float (Unix.time ()) - Random.int 86400; (* Random time within last 24 hours *) 85 85 + comment_type = "comment"; 86 86 + } 87 87 + 88 88 + (*generates a comment with some number of children mostly those comments will have no children, but some will*) 89 89 + let generate_fake_comments count parent_id = 90 90 + List.init count (fun _ -> generate_fake_comment parent_id (Random.int 10000000 + 2000000))

+188

forks/nottui/tutorial/src/hackernews/bin/tutorial.md

reviewed

··· 1 1 + # Building a HackerNews-like Interface with OCaml 2 2 + 3 3 + ## Introduction 4 4 + 5 5 + This tutorial will guide you through creating a HackerNews-like interface using Nottui. You'll learn how to render values, do styling, handle user input, create selection lists, and make popups. By the end of this tutorial, you'll have a functional, interactive UI that mimics some of HackerNews' core features. 6 6 + 7 7 + ## Table of Contents 8 8 + 9 9 + 1. Preliminary Setup 10 10 + 2. First Iteration: Post Rendering 11 11 + 3. Expanding the Application 12 12 + - Styling Improvements 13 13 + - Keyboard Input Handling 14 14 + - Selection Lists 15 15 + - Popups and Focus Management 16 16 + - Implementing Post Sorting 17 17 + 18 18 + ## 1. Preliminary Setup 19 19 + 20 20 + Let's start by ensuring everything works properly: 21 21 + 22 22 + 1. Create a file named `hackernews.ml` with the following test content: 23 23 + 24 24 + $#1 25 25 + 26 26 + 2. Run `dune exec hackernews.exe`. You should see a friendly greeting message. 27 27 + 28 28 + ## 2. First Iteration: Post Rendering 29 29 + 30 30 + ### 2.1 Creating the Post UI 31 31 + 32 32 + We'll begin by rendering our posts. Here's the code for our `post_ui` function: 33 33 + 34 34 + $#2 35 35 + 36 36 + Let's break it down piece by piece: 37 37 + 38 38 + 1. Extract the website domain from the URL: 39 39 + 40 40 + $#3 41 41 + 42 42 + 2. Create two horizontal rows stacked vertically: 43 43 + 44 44 + ```ocaml 45 45 + Ui.vcat 46 46 + [ Ui.hcat 47 47 + [(* *)] 48 48 + ; Ui.hcat 49 49 + [ (* *)] 50 50 + ] 51 51 + ``` 52 52 + 53 53 + 3. Set text styling: 54 54 + The `~attr` parameter allows us to set styling for text. In this case, we set the style to bold. 55 55 + We can also use `A.fg` to set the foreground color or `A.bg` to set the background color. 56 56 + (See: [TODO: Add link to styling documentation] for more info) 57 57 + 58 58 + ```ocaml 59 59 + W.string ~attr:A.(st bold) title; 60 60 + ``` 61 61 + 62 62 + 4. Use `Lwd.pure`: 63 63 + `Lwd.pure` has the signature `'a -> 'a Lwd.t`. It's a way to take static UI (or any data) and make it play nice with functions that take reactive `Lwd.t` values. 64 64 + You'll always need to use this to incorporate UI elements that don't depend on reactive data into the rest of your UI. 65 65 + 66 66 + ```ocaml 67 67 + |> Lwd.pure 68 68 + ``` 69 69 + 70 70 + 5. Add a focusable border: 71 71 + This puts a border around our post. Because we use a focusable box, it will highlight when focused, which can be changed using `Alt+Up` or `Alt+Down`. 72 72 + 73 73 + ```ocaml 74 74 + |> W.Box.focusable 75 75 + ``` 76 76 + 77 77 + ### 2.2 Creating the Main UI 78 78 + 79 79 + Now we need some posts to render. We'll use a fake version of the HackerNews API for now: 80 80 + 81 81 + $#4 82 82 + 83 83 + Note that we used `W.vbox` rather than `Ui.vcat`. That's because each item is now a `Ui.t Lwd.t`, and `Ui.vcat` only accepts `Ui.t`. 84 84 + 85 85 + Typically, you'll use `Ui.*` functions for creating small pieces of UI and `W.*` functions for larger transformations. For example, `Ui.string` creates a single string, while `W.Scroll.area` makes any UI scrollable. 86 86 + 87 87 + ## 3. Expanding the Application 88 88 + 89 89 + Now that we have an MVP that shows our basic data rendering the way we want, let's expand it. 90 90 + 91 91 + In this chapter we will:\ 92 92 + 1. Make our styling a little nicer 93 93 + 2. learn about how to handle keybaord input 94 94 + 3. Make selection lists 95 95 + 4. Make popups and move focus around 96 96 + 5. Use all that to make a popup allowing the user to select how they want posts sorted 97 97 + 98 98 + ### 3.1 Styling Improvements 99 99 + 100 100 + Let's update our `post_ui` function with some styling enhancements: 101 101 + 102 102 + $#5 103 103 + 104 104 + The main change here is making our items stretch to fill the entire screen. We do this by setting the **stretch width** (`sw`) to a non-zero value and also setting our **max width** (`mw`) to a value much wider than a screen could ever be. By default, `max_width` is the same as the object's width. 105 105 + 106 106 + ```ocaml 107 107 + |> Ui.resize ~sw:1 ~mw:10000 108 108 + ``` 109 109 + 110 110 + We've also added spacing between elements for improved readability. 111 111 + 112 112 + ### 3.2 Implementing Sorting 113 113 + 114 114 + First, let's set up some variables to store our state. For a simple UI, we'll keep these in the global scope, but for more modular designs, you might want to put these inside the function they are relevant to. 115 115 + 116 116 + These variables will be `Lwd.var`s. An `Lwd.var` is essentially a `ref` that can be turned into an `Lwd.t` that reacts to the var being set. 117 117 + 118 118 + - `show_prompt_var`: Defines if the prompt is shown, and if so, what content to show 119 119 + - `sorting_mode_var`: Stores how we should sort the posts 120 120 + 121 121 + $#6 122 122 + 123 123 + 124 124 + ### 3.3 Creating the Sorting Prompt 125 125 + 126 126 + We will see how this function fits together. 127 127 + 128 128 + $#7 129 129 + 130 130 + Let's add the overlay to our main UI and give it the var that controls the prompt. We'll also make the body stretchable to give our prompt some space: 131 131 + 132 132 + $#8 133 133 + 134 134 + Next, we'll process keyboard inputs. When 's' is pressed, we'll set the `show_prompt_var` to our prompt: 135 135 + 136 136 + $#9 137 137 + 138 138 + Notice how we used the `$=` operator to assign a value to the `Lwd.var`. This is just an alias to `Lwd.set` that looks a little nicer: 139 139 + 140 140 + ```ocaml 141 141 + | `Finished sorting -> sorting_mode_var $= sorting 142 142 + ``` 143 143 + 144 144 + Here's a helper function to choose the sorting method: 145 145 + 146 146 + $#10 147 147 + 148 148 + ### 3.4 Putting it all together 149 149 + 150 150 + We've extended the posts generation to include a sorting step using our selected sorting function. We've also added a section at the bottom to show the key the user should press to open the sorting prompt: 151 151 + 152 152 + $#11 153 153 + 154 154 + Note that we pass all the other UI into the sorting prompt because we want it to pop up over everything: 155 155 + 156 156 + $#12 157 157 + 158 158 + Let's add a status indicator to show the current sorting mode: 159 159 + 160 160 + $#15 161 161 + 162 162 + This is our first use of `let$`! We're finally making a piece of UI that is reactive to changes. In this case, this UI will update whenever `sorting_mode_var` changes. 163 163 + 164 164 + `let$` is syntactic sugar for `Lwd.map`. Just like `List.map`, it allows us to apply a transformation function to the contents of the `Lwd.t`. We also use `Lwd.get` to turn our `Lwd.var` into an `Lwd.t` as described earlier. 165 165 + 166 166 + The equivalent code to `let$` is: 167 167 + 168 168 + ```ocaml 169 169 + Lwd.get sorting_mode_var |> Lwd.map ~f:(fun sort_mode -> 170 170 + (*..rest...*) 171 171 + ``` 172 172 + 173 173 + Here we see `let$*`, which is similar to `let$` except that it is `Lwd.bind`. It's necessary when the result of the transformation is itself an `Lwd.t`. You're likely familiar with `Result.bind`, which behaves similarly. 174 174 + 175 175 + $#14 176 176 + 177 177 + In general, `let$*` should be avoided because it causes whatever is inside it to be fully recomputed when the `Lwd.t` it is binding on changes. However, in this case, that makes sense because our list will have to be fully re-sorted anyway. 178 178 + 179 179 + In the next chapter, you'll see more use of both `let$` and `let$*`. 180 180 + 181 181 + That's it! You've now created a HackerNews-like interface with OCaml, complete with post rendering, sorting functionality, and an interactive UI. Here's the full source code for reference: 182 182 + 183 183 + $#13 184 184 + 185 185 + ## Wrap up 186 186 + 187 187 + I hope this was helpful, and you've now got some idea how to put together a nottui app. If you have any feedback please make an issue on the repo, or message me @faldor20 on the ocaml discord. 188 188 +

forks/nottui/tutorial/src/hackernews/pics/Pasted image.png

reviewed

This is a binary file and will not be displayed.

+215

forks/nottui/tutorial/src/tangle.ml

reviewed

··· 1 1 + (** This is a system for templating code into markdown files for building tutorials. It's a little like literate programming but in reverse. 2 2 + The code has lines with comments that indicate the start and end of a templated section. ($#S10 $#E10) 3 3 + The markdown has lines that show where those sections should go ($#10) *) 4 4 + 5 5 + open Printf 6 6 + 7 7 + type code_block = 8 8 + { language : string 9 9 + ; content : string 10 10 + } 11 11 + 12 12 + let write_file filename content = 13 13 + let ch = open_out filename in 14 14 + output_string ch content; 15 15 + close_out ch 16 16 + ;; 17 17 + 18 18 + open! Base 19 19 + 20 20 + module Parsing = struct 21 21 + open Angstrom 22 22 + 23 23 + (* Define the variant type for different sequences *) 24 24 + type tangle_type = 25 25 + | Start of int 26 26 + | End of int 27 27 + | Id of int 28 28 + | Fold of int * string 29 29 + 30 30 + (* Helper function to parse a number *) 31 31 + let parse_number = 32 32 + take_while1 (function 33 33 + | '0' .. '9' -> true 34 34 + | _ -> false) 35 35 + >>| Int.of_string 36 36 + ;; 37 37 + 38 38 + let parse_cmd letter = string ("$#" ^ letter) *> parse_number 39 39 + 40 40 + (* Parser for $#S<number> *) 41 41 + let parse_start = parse_cmd "S" >>| fun x -> Start x 42 42 + 43 43 + (* Parser for $#E<number> *) 44 44 + let parse_end = parse_cmd "E" >>| fun x -> End x 45 45 + 46 46 + (* Parser for $#<number> *) 47 47 + let parse_id = parse_cmd "" >>| fun x -> Id x 48 48 + 49 49 + (* Parser for $#<number> fold <name> *) 50 50 + let parse_fold = 51 51 + string "$#" *> parse_number 52 52 + <* string " fold " 53 53 + >>= fun n -> take_while1 Char.(fun c -> c <> '\n') >>| fun name -> Fold (n, name) 54 54 + ;; 55 55 + 56 56 + (* Combine all parsers *) 57 57 + let sequence_parser = 58 58 + choice 59 59 + [ parse_start 60 60 + ; parse_end 61 61 + ; parse_fold 62 62 + ; (* Use attempt to backtrack if it's not a fold *) 63 63 + parse_id 64 64 + ] 65 65 + ;; 66 66 + 67 67 + (* Parser for finding sequences in a line of text *) 68 68 + let line_parser = many (not_char '$' *> advance 1) *> sequence_parser 69 69 + 70 70 + (* Function to parse a line and return the first found sequence, if any *) 71 71 + let parse_line line = 72 72 + match parse_string ~consume:Prefix line_parser line with 73 73 + | Ok result -> Some result 74 74 + | Error _ -> None 75 75 + ;; 76 76 + 77 77 + let lang_from_ext ext = 78 78 + match ext with 79 79 + | "ml" | "mli" -> "ocaml" 80 80 + | "py" -> "python" 81 81 + | "js" -> "javascript" 82 82 + | "ts" -> "typescript" 83 83 + | "rb" -> "ruby" 84 84 + | "rs" -> "rust" 85 85 + | "go" -> "go" 86 86 + | "java" -> "java" 87 87 + | "c" | "h" -> "c" 88 88 + | "cpp" | "hpp" | "cxx" | "hxx" -> "cpp" 89 89 + | "cs" -> "csharp" 90 90 + | "php" -> "php" 91 91 + | "sh" | "bash" -> "bash" 92 92 + | "html" | "htm" -> "html" 93 93 + | "css" -> "css" 94 94 + | "json" -> "json" 95 95 + | "xml" -> "xml" 96 96 + | "md" -> "markdown" 97 97 + | "sql" -> "sql" 98 98 + | "hs" -> "haskell" 99 99 + | "swift" -> "swift" 100 100 + | "kt" | "kts" -> "kotlin" 101 101 + | _ -> "unknown" 102 102 + ;; 103 103 + end 104 104 + 105 105 + open Parsing 106 106 + 107 107 + type pre_code_block = 108 108 + { id : int 109 109 + ; language : string 110 110 + ; lines : string list 111 111 + } 112 112 + 113 113 + let extract_code_blocks filename output_tbl = 114 114 + let lines = Iter.IO.lines_of filename in 115 115 + let language = filename |> String.rsplit2_exn ~on:'.' |> snd |> lang_from_ext in 116 116 + let iter state line = 117 117 + match parse_line line with 118 118 + | Some (Start id) -> { id; language; lines = [] } :: state 119 119 + | Some (End id) -> 120 120 + state 121 121 + |> List.filter ~f:(fun x -> 122 122 + if x.id = id 123 123 + then ( 124 124 + output_tbl 125 125 + |> Hashtbl.set 126 126 + ~key:id 127 127 + ~data: 128 128 + { language = x.language 129 129 + ; content = x.lines |> List.rev |> String.concat_lines 130 130 + }; 131 131 + false) 132 132 + else true) 133 133 + | None -> 134 134 + state |> List.map ~f:(fun block -> { block with lines = line :: block.lines }) 135 135 + | _ -> failwith (Printf.sprintf "Found incorrect tangle command on line: %s" line) 136 136 + in 137 137 + lines |> Iter.fold iter [] |> ignore; 138 138 + output_tbl 139 139 + ;; 140 140 + 141 141 + let process_markdown filename (code_blocks : (int, code_block) Hashtbl.t) = 142 142 + let open Option.Let_syntax in 143 143 + Iter.IO.lines_of filename 144 144 + |> Iter.map (fun line -> 145 145 + let out = 146 146 + let%bind id, formatter = 147 147 + match line |> parse_line with 148 148 + | Some (Id id) -> Some (id, fun x -> x) 149 149 + | Some (Fold (id, name)) -> 150 150 + Some 151 151 + ( id 152 152 + , fun content -> 153 153 + sprintf 154 154 + "<details>\n <summary>%s</summary>\n\n%s</details>\n" 155 155 + name 156 156 + content ) 157 157 + | _ -> None 158 158 + in 159 159 + let%map block = Hashtbl.find code_blocks id in 160 160 + sprintf "```%s\n%s```\n" block.language block.content |> formatter 161 161 + in 162 162 + out |> Option.value ~default:(line ^ "\n")) 163 163 + |> Iter.concat_str 164 164 + ;; 165 165 + 166 166 + let process_folder input_path output_path = 167 167 + let files = Stdlib.Sys.readdir input_path |> Array.to_list in 168 168 + let code_files = 169 169 + files 170 170 + |> List.filter_map ~f:(fun f -> 171 171 + let path = Stdlib.Filename.concat input_path f in 172 172 + if (not (Stdlib.Filename.check_suffix f ".md")) 173 173 + && not (Stdlib.Sys.is_directory path) 174 174 + then Some path 175 175 + else None) 176 176 + in 177 177 + let markdown_files = 178 178 + files |> List.filter ~f:(fun f -> Stdlib.Filename.check_suffix f ".md") 179 179 + in 180 180 + let code_blocks = 181 181 + Base.List.fold 182 182 + ~init:(Hashtbl.create (module Int)) 183 183 + ~f:(fun hash_tbl path -> extract_code_blocks path hash_tbl) 184 184 + code_files 185 185 + in 186 186 + markdown_files 187 187 + |> List.iter ~f:(fun f -> 188 188 + let input_file = Stdlib.Filename.concat input_path f in 189 189 + let output_file = 190 190 + let out_path = 191 191 + Option.value 192 192 + output_path 193 193 + ~default:(input_path ^ Stdlib.Filename.dir_sep ^ "tangled") 194 194 + in 195 195 + if not (Stdlib.Sys.file_exists out_path) then Stdlib.Sys.mkdir out_path 0o755; 196 196 + Stdlib.Filename.concat out_path f 197 197 + in 198 198 + let processed_content = process_markdown input_file code_blocks in 199 199 + write_file output_file processed_content; 200 200 + printf "Processed %s -> %s\n" input_file output_file) 201 201 + ;; 202 202 + 203 203 + let () = 204 204 + let open Stdlib in 205 205 + match Array.to_list Sys.argv with 206 206 + | [ _; input_path ] -> 207 207 + if Sys.is_directory input_path 208 208 + then process_folder input_path None 209 209 + else printf "Error: %s is not a valid directory\n" input_path 210 210 + | [ _; input_path; output_path ] -> 211 211 + if Sys.is_directory input_path 212 212 + then process_folder input_path (Some output_path) 213 213 + else printf "Error: %s is not a valid directory\n" input_path 214 214 + | _ -> printf "Usage: %s <input_folder_path> [output_folder_path]\n" Sys.argv.(0) 215 215 + ;;

+4 -2

jj_tui.opam

reviewed

··· 10 10 doc: "https://url/to/documentation" 11 11 bug-reports: "https://github.com/username/reponame/issues" 12 12 depends: [ 13 13 + "lwd" 13 14 "ocaml" 14 15 "dune" {>= "3.12"} 15 16 "stdio" 16 16 - "lwd" 17 17 + "nottui" 17 18 "base" 18 19 "eio_main" 19 20 "angstrom" 20 21 "ppx_expect" 21 22 "ppx_jane" 22 22 - "lwd" 23 23 "eio-process" 24 24 "uutf" 25 25 "odoc" {with-doc} ··· 44 44 #This is needed because eio-process doesn't exict 45 45 pin-depends:[ 46 46 ["eio-process.dev" "git+https://github.com/mbarbin/eio-process#ac1e965eb33f19fcedc7ce203111bca0c3fc8278"] 47 47 + ["nottui.dev" "git+https://github.com/faldor20/nottui#085cbd489600fa7c0279352d0a773dfa133ab39a"] 48 48 + ["lwd.dev" "git+https://github.com/faldor20/lwd#c19bc2fd55c2de977cdd283458ce06402b08febe"] 47 49 ] 48 50

+2

jj_tui.opam.template

reviewed

··· 3 3 #This is needed because eio-process doesn't exict 4 4 pin-depends:[ 5 5 ["eio-process.dev" "git+https://github.com/mbarbin/eio-process#ac1e965eb33f19fcedc7ce203111bca0c3fc8278"] 6 6 + ["nottui.dev" "git+https://github.com/faldor20/nottui#085cbd489600fa7c0279352d0a773dfa133ab39a"] 7 7 + ["lwd.dev" "git+https://github.com/faldor20/lwd#c19bc2fd55c2de977cdd283458ce06402b08febe"] 6 8 ] 7 9

+1 -1

jj_tui/bin/dune

reviewed

··· 1 1 (executable 2 2 (public_name jj_tui) 3 3 (name main) 4 4 - (libraries jj_tui lwd nottui base stdio eio_main eio-process ) 4 4 + (libraries jj_tui nottui base stdio eio_main eio-process ) 5 5 ) 6 6 7 7 (env

+3 -5

jj_tui/bin/file_view.ml

reviewed

··· 3 3 open Vars 4 4 open Jj_process.Make (Vars) 5 5 open Notty 6 6 - module W = Nottui_widgets 7 6 open Nottui 8 7 open! Jj_tui.Util 9 9 - module Wd = Jj_tui.Widgets 10 8 open Jj_commands.Make (Vars) 11 9 12 10 let selected_file = Lwd.var "" ··· 59 57 let$ files = Lwd.get Vars.ui_state.jj_change_files in 60 58 files 61 59 |> List.map (fun (_modifier, file) -> 62 62 - Wd.{ data = file; ui = Wd.selectable_item (W.string file) }) 60 60 + W.Lists.{ data = file; ui = W.Lists.selectable_item (W.string file) }) 63 61 in 64 64 - Wd.selection_list_custom 62 62 + W.Lists.selection_list_custom 65 63 ~on_selection_change:(fun x -> 66 64 Eio.Fiber.fork ~sw @@ fun _ -> 67 65 Vars.update_ui_state @@ fun _ -> Lwd.set selected_file x) 68 68 - ~custom_handler:(fun _ _ key -> 66 66 + ~custom_handler:(fun _ key -> 69 67 match key with `ASCII k, [] -> handleInputs command_mapping k | _ -> `Unhandled) 70 68 file_uis 71 69 ;;

+1 -2

jj_tui/bin/global_vars.ml

reviewed

··· 25 25 Lwd.var 26 26 ; input : [ `Normal | `Mode of char -> Ui.may_handle ] Lwd.var 27 27 ; show_popup : (ui Lwd.t * string) option Lwd.var 28 28 - ; show_prompt : 29 29 - (string * string * ([ `Finished of string | `Closed ] -> unit)) option Lwd.var 28 28 + ; show_prompt :W.Overlay.text_prompt_data option Lwd.var 30 29 ; command_log : string list Lwd.var 31 30 ; jj_tree : I.t Lwd.var 32 31 ; jj_show : I.t Lwd.var

+6 -8

jj_tui/bin/graph_view.ml

reviewed

··· 4 4 open Jj_process.Make (Vars) 5 5 open Notty 6 6 open Jj_tui 7 7 - module W = Nottui_widgets 8 7 open Nottui 9 8 open! Jj_tui.Util 10 10 - module Wd = Widgets 11 9 open Jj_commands.Make (Vars) 12 10 open Jj_widgets.Make (Vars) 13 11 ··· 259 257 match x with 260 258 | `Selectable x -> 261 259 let ui = 262 262 - Wd.selectable_item 260 260 + W.Lists.selectable_item 263 261 (x ^ "\n" 264 262 (* TODO This won't work if we are on a branch, because that puts the @ further out*) 265 263 |> Jj_tui.AnsiReverse.colored_string 266 264 |> Ui.atom) 267 265 in 268 268 - let data = Wd.{ ui; data = rev_ids.(!selectable_idx) } in 266 266 + let data = W.Lists.{ ui; data = rev_ids.(!selectable_idx) } in 269 267 selectable_idx := !selectable_idx + 1; 270 270 - Wd.(Selectable data) 268 268 + W.Lists.(Selectable data) 271 269 | `Filler x -> 272 272 - Wd.(Filler (" " ^ x ^ "\n" |> Jj_tui.AnsiReverse.colored_string |> Ui.atom))) 270 270 + W.Lists.(Filler (" " ^ x ^ "\n" |> Jj_tui.AnsiReverse.colored_string |> Ui.atom|>Lwd.pure))) 273 271 in 274 272 ui 275 275 - |> Wd.selection_list_exclusions 273 273 + |> W.Lists.selection_list_exclusions 276 274 ~on_selection_change:(fun revision -> 277 275 Eio.Fiber.fork ~sw @@ fun _ -> 278 276 Vars.update_ui_state @@ fun _ -> 279 277 Lwd.set Vars.ui_state.selected_revision revision; 280 278 Global_funcs.update_views ()) 281 281 - ~custom_handler:(fun _ _ key -> 279 279 + ~custom_handler:(fun _ key -> 282 280 match key with 283 281 | `ASCII k, [] -> 284 282 handleInputs command_mapping k

+22 -22

jj_tui/bin/jj_commands.ml

reviewed

··· 43 43 open Vars 44 44 open Jj_process.Make (Vars) 45 45 open Notty 46 46 - module W = Nottui_widgets 47 46 open Nottui 48 47 open! Jj_tui.Util 49 49 - module Wd = Jj_tui.Widgets 50 48 51 49 exception Handled 52 50 ··· 97 95 |> I.vcat 98 96 |> Ui.atom 99 97 |> Lwd.pure 100 100 - |> Wd.scroll_area 98 98 + |> W.Scroll.area 101 99 ;; 102 100 103 101 let rec handleCommand description cmd = ··· 109 107 let prompt str cmd = 110 108 ui_state.show_prompt 111 109 $= Some 112 112 - ( str 113 113 - , "" 114 114 - , function 115 115 - | `Finished str -> 116 116 - safe_jj (fun _ -> 117 117 - match cmd with 118 118 - | `Cmd args -> 119 119 - let _result = jj (args @ [ str ]) in 120 120 - Global_funcs.update_status (); 121 121 - () 122 122 - (* v_cmd_out $= jj (args @ [ str ]); *) 123 123 - | `Cmd_I args -> 124 124 - Lwd.set ui_state.view (`Cmd_I (args @ [ str ])) 125 125 - | `Fun func -> 126 126 - func str) 127 127 - | `Closed -> 128 128 - () ) 110 110 + W.Overlay. 111 111 + { 112 112 + label = str 113 113 + ; pre_fill = "" 114 114 + ; on_exit = 115 115 + (function 116 116 + | `Finished str -> 117 117 + safe_jj (fun _ -> 118 118 + match cmd with 119 119 + | `Cmd args -> 120 120 + let _result = jj (args @ [ str ]) in 121 121 + Global_funcs.update_status (); 122 122 + () 123 123 + (* v_cmd_out $= jj (args @ [ str ]); *) 124 124 + | `Cmd_I args -> 125 125 + Lwd.set ui_state.view (`Cmd_I (args @ [ str ])) 126 126 + | `Fun func -> 127 127 + func str) 128 128 + | `Closed -> 129 129 + ()) 130 130 + } 129 131 in 130 132 let change_view view = Lwd.set ui_state.view view in 131 133 let send_cmd args = change_view (`Cmd_I args) in ··· 207 209 open Vars 208 210 open Jj_process.Make (Vars) 209 211 open Notty 210 210 - module W = Nottui_widgets 211 212 open! Jj_tui.Util 212 213 open Intern (Vars) 213 213 - module Wd = Jj_tui.Widgets 214 214 include Shared 215 215 216 216 (** A handy command_list that just has this help command for areas that don't have any commands to still show help*)

+18 -18

jj_tui/bin/jj_ui.ml

reviewed

··· 4 4 open Global_funcs 5 5 open Jj_tui.Util 6 6 open Jj_tui 7 7 - module W = Nottui_widgets 8 8 - module Wd = Widgets 7 7 + 9 8 10 9 module Ui = struct 11 10 include Nottui.Ui ··· 28 27 let full_term_sized_background = 29 28 let$ term_width, term_height = Lwd.get Vars.term_width_height in 30 29 Notty.I.void term_width term_height |> Nottui.Ui.atom 30 30 + let blue= I.string A.((fg blue)++(bg blue)++(st bold)) "blue" 31 31 ;; 32 32 33 33 let _quitButton = ··· 69 69 in 70 70 W.string message 71 71 |> Lwd.pure 72 72 - |> Wd.border_box 72 72 + |> W.Box.box 73 73 |>$ Ui.resize 74 74 ~sw:1 75 75 ~sh:1 76 76 ~mw:10000 77 77 ~mh:10000 78 78 - ~crop:Wd.neutral_grav 79 79 - ~pad:Wd.neutral_grav 78 78 + ~crop:W.neutral_grav 79 79 + ~pad:W.neutral_grav 80 80 |> inputs 81 81 ;; 82 82 ··· 94 94 [ 95 95 File_view.file_view sw () 96 96 |>$ Ui.resize ~w:5 ~sw:1 ~mw:1000 97 97 - |> Wd.border_box_focusable ~focus:file_focus ~pad_h:0 ~pad_w:1 97 97 + |> W.Box.focusable ~focus:file_focus ~pad_h:0 ~pad_w:1 98 98 ; Graph_view.graph_view ~sw () 99 99 |>$ Ui.resize ~sh:3 ~w:5 ~sw:1 ~mw:1000 ~h:10 ~mh:1000 100 100 - |> Wd.border_box_focusable ~focus:graph_focus ~pad_h:0 ~pad_w:1 101 101 - ; Wd.scroll_area (ui_state.jj_branches $-> Ui.atom) 102 102 - |> Wd.is_focused ~focus:branch_focus (fun ui focused -> 100 100 + |> W.Box.focusable ~focus:graph_focus ~pad_h:0 ~pad_w:1 101 101 + ; W.Scroll.area(ui_state.jj_branches $-> Ui.atom) 102 102 + |> W.is_focused ~focus:branch_focus (fun ui focused -> 103 103 ui 104 104 |> Ui.keyboard_area (function 105 105 | `ASCII k, [] -> ··· 113 113 ~h:2 114 114 ~mh:1000 115 115 ~mw:1000) 116 116 - |> Wd.border_box_focusable ~focus:branch_focus ~pad_h:0 ~pad_w:1 116 116 + |> W.Box.focusable ~focus:branch_focus ~pad_h:0 ~pad_w:1 117 117 ] 118 118 ; (*Right side summary/status/fileinfo view*) 119 119 (let$* file_focus = file_focus |> Focus.status in ··· 122 122 let$ status = File_view.file_status () in 123 123 status |> AnsiReverse.colored_string |> Ui.atom 124 124 else (fun x -> x |> Ui.atom) <-$ ui_state.jj_show) 125 125 - |> Wd.scroll_area 125 125 + |> W.Scroll.area 126 126 (* let mw=Int.max (Ui.layout_max_width ui) 100 in *) 127 127 |>$ Ui.resize ~w:0 ~sh:3 ~sw:2 ~mw:100 ~mh:10000 128 128 - |> Wd.on_focus ~focus:summary_focus (Ui.resize ~sw:3 ~mw:1000) 129 129 - |> Wd.border_box_focusable ~focus:summary_focus ~pad_h:0 ~pad_w:1 128 128 + |> W.on_focus ~focus:summary_focus (Ui.resize ~sw:3 ~mw:1000) 129 129 + |> W.Box.focusable ~focus:summary_focus ~pad_h:0 ~pad_w:1 130 130 ] 131 131 (*These outer prompts can popup and show them selves over the main view*) 132 132 - |> Widgets.general_prompt ~char_count:true ~show_prompt_var:ui_state.show_prompt 133 133 - |> Widgets.popup ~show_popup_var:ui_state.show_popup 132 132 + |> W.Overlay.text_prompt ~char_count:true ~show_prompt_var:ui_state.show_prompt 133 133 + |> W.Overlay.popup ~show_popup_var:ui_state.show_popup 134 134 |> inputs 135 135 ;; 136 136 ··· 141 141 |> Ui.atom 142 142 |> Ui.resize ~mh:1000 ~mw:10000 143 143 |> Lwd.pure 144 144 - |> Wd.scroll_area 145 145 - |> Wd.border_box ~pad_w:1 ~pad_h:0 144 144 + |> W.Scroll.area 145 145 + |> W.Box.box ~pad_w:1 ~pad_h:0 146 146 |> inputs 147 147 ;; 148 148 ··· 170 170 | `RunCmd cmd -> 171 171 Jj_widgets.interactive_process env ("jj" :: cmd) 172 172 | `Main -> 173 173 - Wd.keyboard_tabs [ ("Main", fun _ -> main_view ~sw); "Op log", log_view ]) 173 173 + W.keyboard_tabs [ ("Main", fun _ -> main_view ~sw); "Op log", log_view ]) 174 174 | (`CantStartProcess | `NotInRepo | `OtherError _) as other -> 175 175 render_startup_error other 176 176 ;;

-2

jj_tui/bin/jj_widgets.ml

reviewed

··· 3 3 open Lwd_infix 4 4 open Jj_tui 5 5 open! Util 6 6 - module W = Nottui_widgets 7 6 8 7 (** Collection of JJ specific widgets*) 9 9 - module Wd = Widgets 10 8 11 9 module Make (Vars : Global_vars.Vars) = struct 12 10 open Vars

+1 -1

jj_tui/bin/main.ml

reviewed

··· 1 1 open Eio.Std 2 2 open Lwd_infix 3 3 - module W = Nottui_widgets 4 3 module Vars = Global_vars.Vars 5 4 open Nottui 6 5 module Jj_ui = Jj_ui.Make (Vars) 6 6 + 7 7 8 8 let ui_loop ~quit ~term root = 9 9 print_endline "starting loop";

+1 -1

jj_tui/lib/dune

reviewed

··· 3 3 4 4 (name jj_tui) 5 5 (inline_tests) 6 6 - (libraries stdio notty nottui angstrom bigstringaf eio_main eio-process lwd) 6 6 + (libraries stdio notty nottui angstrom bigstringaf eio_main eio-process) 7 7 (preprocess 8 8 (pps ppx_expect)) 9 9 )

jj_tui/lib/widgets/Shared.ml jj_tui/lib/widgets/Shared.ml-

reviewed

jj_tui/lib/widgets/border_box.ml jj_tui/lib/widgets/border_box.ml-

reviewed

jj_tui/lib/widgets/selection_list.ml jj_tui/lib/widgets/selection_list.ml-

reviewed

jj_tui/lib/widgets/widgets.ml jj_tui/lib/widgets/widgets.ml-

reviewed

jj_tui/lib/widgets/wip.ml jj_tui/lib/widgets/wip.ml-

reviewed

+1 -126

jj_tui/lib/widgets_citty.ml

reviewed

··· 173 173 `Unhandled 174 174 ;; 175 175 176 176 - let button attr text f = Ui.mouse_area (on_click f) (Nottui_widgets.string ~attr text) 177 177 - 178 178 - (* Render a vertical scroll representing a [Nottui_widgets.scroll_state]. 179 179 - The [set_scroll] function is called when the state should be updated to 180 180 - reflect a user interaction. *) 181 181 - let vertical_scrollbar ~set_scroll (st : Nottui_widgets.scroll_state) = 182 182 - Eio.Switch.run @@ fun sw -> 183 183 - let bar color h = Notty.(I.char A.(bg color) ' ' 1 h) in 184 184 - let gray = Notty.A.gray 1 in 185 185 - let lightgray = Notty.A.white in 186 186 - if st.visible = 0 187 187 - then Ui.atom Notty.I.empty 188 188 - else if st.total > st.visible 189 189 - then ( 190 190 - (* Compute size of the handle inside the bar *) 191 191 - let ratio = max 1 (st.visible * st.visible / st.total) in 192 192 - let rest = st.visible - ratio in 193 193 - let prefix = rest * st.position / st.bound in 194 194 - let suffix = rest - prefix in 195 195 - (* React to mouse events on the scroll bar *) 196 196 - let mouse_handler ~x:_ ~y = function 197 197 - | `Left -> 198 198 - if y < prefix 199 199 - then ( 200 200 - let position = ref st.position in 201 201 - grab_and_repeat ~sw (fun () -> 202 202 - position := max 0 (!position - (st.visible / 2)); 203 203 - set_scroll { st with position = !position }; 204 204 - ())) 205 205 - else if y > prefix + ratio 206 206 - then ( 207 207 - let position = ref st.position in 208 208 - grab_and_repeat ~sw (fun () -> 209 209 - position := min st.bound (!position + (st.visible / 2)); 210 210 - set_scroll { st with position = !position }; 211 211 - ())) 212 212 - else 213 213 - `Grab 214 214 - ( (fun ~x:_ ~y:y' -> 215 215 - let dy = y' - y in 216 216 - let position = 217 217 - float st.position +. (float dy /. float st.visible *. float st.total) 218 218 - in 219 219 - let position = max 0 (min st.bound (int_of_float position)) in 220 220 - set_scroll { st with position }) 221 221 - , fun ~x:_ ~y:_ -> () ) 222 222 - | _ -> 223 223 - `Unhandled 224 224 - in 225 225 - Notty.I.vcat [ bar gray prefix; bar lightgray ratio; bar gray suffix ] 226 226 - |> Ui.atom 227 227 - |> Ui.mouse_area mouse_handler) 228 228 - else Ui.atom (bar gray st.visible) 229 229 - ;; 230 230 - 231 231 - let list_box ~items ~render ~select = 232 232 - let prev_highlight = ref (Lwd.var false) in 233 233 - let select_item (var, item) = 234 234 - Lwd.set !prev_highlight false; 235 235 - Lwd.set var true; 236 236 - prev_highlight := var; 237 237 - select item 238 238 - in 239 239 - let select_next list = 240 240 - let rec seek = function 241 241 - | [] -> 242 242 - false 243 243 - | ((x, _), _) :: (item, _) :: _ when Lwd.peek x -> 244 244 - select_item item; 245 245 - true 246 246 - | _ :: rest -> 247 247 - seek rest 248 248 - in 249 249 - if seek list 250 250 - then () 251 251 - else (match list with (item, _) :: _ -> select_item item | [] -> ()) 252 252 - and select_prev list = 253 253 - let rec seek = function 254 254 - | [] -> 255 255 - () 256 256 - | (item, _) :: ((y, _), _) :: _ when Lwd.peek y -> 257 257 - select_item item 258 258 - | [ (item, _) ] -> 259 259 - select_item item 260 260 - | _ :: rest -> 261 261 - seek rest 262 262 - in 263 263 - seek list 264 264 - and activate list = 265 265 - let rec seek = function 266 266 - | [] -> 267 267 - false 268 268 - | (item, _) :: _ when Lwd.peek (fst item) -> 269 269 - select_item item; 270 270 - true 271 271 - | _ :: rest -> 272 272 - seek rest 273 273 - in 274 274 - if seek list 275 275 - then () 276 276 - else (match list with (item, _) :: _ -> select_item item | [] -> ()) 277 277 - in 278 278 - let show_item x = 279 279 - let item = Lwd.var false, x in 280 280 - let ui = 281 281 - Lwd.map 282 282 - (Lwd.get (fst item)) 283 283 - ~f:(fun highlight -> 284 284 - Ui.mouse_area 285 285 - (on_click @@ fun () -> select_item item) 286 286 - (render (snd item) highlight)) 287 287 - in 288 288 - item, ui 289 289 - in 290 290 - let items = List.map show_item items in 291 291 - let view = Lwd_utils.pack Ui.pack_y (List.map snd items) in 292 292 - let dispatch = function 293 293 - | `Select_prev -> 294 294 - select_prev items 295 295 - | `Select_next -> 296 296 - select_next items 297 297 - | `Activate -> 298 298 - activate items 299 299 - in 300 300 - view, dispatch 301 301 - ;; 176 176 + let button attr text f = Ui.mouse_area (on_click f) (W.string ~attr text) 302 177 303 178 let fit_string str len = 304 179 let len0 = String.length str in

+1 -1

jj_tui/test/lib/ansi.ml

reviewed

··· 31 31 |} 32 32 in 33 33 jjtest 34 34 - |> string_to_image 34 34 + |> ansi_string_to_image 35 35 |> Result.get_ok 36 36 |> Notty.Render.pp_image @@ Format.str_formatter; 37 37 let res = Format.flush_str_formatter () in

+1 -1

jj_tui/widget-test/dune

reviewed

··· 1 1 (executable 2 2 (public_name widget_test) 3 3 (name main) 4 4 - (libraries jj_tui lwd nottui base stdio eio_main eio-process ) 4 4 + (libraries jj_tui nottui base stdio eio_main eio-process ) 5 5 )

-2

jj_tui/widget-test/main.ml

reviewed

··· 2 2 open Nottui 3 3 open Notty 4 4 open Jj_tui.Util 5 5 - module W = Nottui_widgets 6 6 - module Wd = Jj_tui.Widgets 7 5 (* 8 6 thoughts on my layout 9 7 1. I want my box to be at most the size of my content

+26

log

reviewed

··· 2099 2099 make[1]: *** [Makefile:370: world] Error 2 2100 2100 make[1]: Leaving directory '/build/ocaml-5.1.1' 2101 2101 // make: *** [/nix/store/0rawfy9g1y4c2h4s60sjm6m80cri92n3-Makefile.nixpkgs:14: nixpkgs_world_bootstrap_world_opt] Error 2 2102 2102 + @nix { "action": "setPhase", "phase": "unpackPhase" } 2103 2103 + Running phase: unpackPhase 2104 2104 + unpacking source archive /nix/store/yc6xa1xq75042vaaqv9vwj9zgg03zbpj-q1ip79qzn7xj5zkwdysl65vwv07yhqka-source 2105 2105 + source root is q1ip79qzn7xj5zkwdysl65vwv07yhqka-source 2106 2106 + @nix { "action": "setPhase", "phase": "patchPhase" } 2107 2107 + Running phase: patchPhase 2108 2108 + @nix { "action": "setPhase", "phase": "updateAutotoolsGnuConfigScriptsPhase" } 2109 2109 + Running phase: updateAutotoolsGnuConfigScriptsPhase 2110 2110 + @nix { "action": "setPhase", "phase": "configurePhase" } 2111 2111 + Running phase: configurePhase 2112 2112 + no configure script, doing nothing 2113 2113 + @nix { "action": "setPhase", "phase": "buildPhase" } 2114 2114 + Running phase: buildPhase 2115 2115 + Done: 80% (4/5, 1 left) (jobs: 0) Done: 81% (13/16, 3 left) (jobs: 0) Done: 72% (13/18, 5 left) (jobs: 0) Error: Conflict between the following libraries: 2116 2116 + - "notty" in _build/default/forks/notty/src 2117 2117 + - "notty" in 2118 2118 + /nix/store/8qvjlw61pql9rmq9wajr87hgi0a1lbic-ocaml5.1.1-notty-0.2.3/lib/ocaml/5.1.1/site-lib/notty 2119 2119 + -> required by library "nottui" in 2120 2120 + /nix/store/hvl9n9szs8zhdx78nd96wszl66szlcgg-ocaml5.1.1-nottui-dev/lib/ocaml/5.1.1/site-lib/nottui 2121 2121 + -> required by library "jj_tui" in _build/default/jj_tui/lib 2122 2122 + -> required by executable main in jj_tui/bin/dune:3 2123 2123 + -> required by _build/default/jj_tui/bin/main.exe 2124 2124 + -> required by _build/install/default/bin/jj_tui 2125 2125 + -> required by _build/default/jj_tui.install 2126 2126 + -> required by alias install 2127 2127 + Done: 72% (13/18, 5 left) (jobs: 0) Done: 65% (15/23, 8 left, 1 failed) (jobs: 0) Done: 65% (17/26, 9 left, 1 failed) (jobs: 1) Done: 61% (46/75, 29 left, 1 failed) (jobs: 1)

+2

test.js

reviewed

··· 1 1 + hi; 2 2 + n hi;