├── .editorconfig ├── .github ├── linters │ └── .ecrc └── workflows │ ├── ci-lib.yml │ └── ci-super-linter.yml ├── .gitignore ├── LICENSE ├── Makefile ├── README.md ├── docs ├── docs.ipkg └── src │ └── Examples │ ├── Balls.md │ ├── CSS.md │ ├── CSS │ ├── Balls.idr │ ├── Colors.idr │ ├── Core.idr │ ├── Fractals.idr │ ├── MathGame.idr │ ├── Performance.idr │ ├── Requests.idr │ └── Reset.idr │ ├── Fractals.idr │ ├── Fractals │ └── Dragon.idr │ ├── Main.md │ ├── MathGame.md │ ├── Performance.md │ ├── Requests.md │ ├── Reset.md │ ├── Selector.md │ └── Util.idr ├── dom-mvc.ipkg ├── extra ├── dom-mvc-extra.ipkg └── src │ ├── Text │ └── HTML │ │ ├── Class.idr │ │ ├── Confirm.idr │ │ ├── DomID.idr │ │ ├── Extra.idr │ │ ├── File.idr │ │ └── Validation.idr │ └── Web │ └── MVC │ ├── Controller.idr │ └── Controller │ ├── Confirm.idr │ ├── File.idr │ ├── Form.idr │ ├── List.idr │ └── Validation.idr ├── js └── README.md ├── mvc.html ├── pack.toml ├── pics ├── pic1.jpg ├── pic10.jpg ├── pic11.jpg ├── pic2.jpg ├── pic3.jpg ├── pic4.jpg ├── pic5.jpg ├── pic6.jpg ├── pic7.jpg ├── pic8.jpg └── pic9.jpg └── src ├── Text ├── CSS.idr ├── CSS │ ├── Angle.idr │ ├── Color.idr │ ├── Cursor.idr │ ├── Declaration.idr │ ├── Dir.idr │ ├── Flexbox.idr │ ├── Gradient.idr │ ├── Grid.idr │ ├── Length.idr │ ├── ListStyleType.idr │ ├── Percentage.idr │ ├── Property.idr │ ├── Rule.idr │ └── Selector.idr ├── HTML.idr └── HTML │ ├── Attribute.idr │ ├── Event.idr │ ├── Node.idr │ ├── Ref.idr │ ├── Select.idr │ └── Tag.idr └── Web ├── MVC.idr └── MVC ├── Animate.idr ├── Canvas.idr ├── Canvas ├── Angle.idr ├── Scene.idr ├── Shape.idr ├── Style.idr └── Transformation.idr ├── Cmd.idr ├── Event.idr ├── Http.idr ├── Util.idr ├── View.idr └── Widget.idr /.editorconfig: -------------------------------------------------------------------------------- 1 | # top-most EditorConfig file 2 | root = true 3 | 4 | # Defaults for every file 5 | [*] 6 | end_of_line = lf 7 | insert_final_newline = true 8 | trim_trailing_whitespace = true 9 | charset = utf-8 10 | 11 | # Idris source files 12 | [*.{idr,ipkg,tex,yaff,lidr}] 13 | indent_style = space 14 | indent_size = 2 15 | 16 | # Various configuration files 17 | [{*.yml,.ecrc}] 18 | indent_style = space 19 | indent_size = 2 20 | 21 | [*.py] 22 | indent_style = space 23 | indent_size = 4 24 | 25 | [*.{c,h}] 26 | indent_style = space 27 | indent_size = 4 28 | 29 | [*.{md,rst}] 30 | indent_style = space 31 | indent_size = 2 32 | 33 | [*.sh] 34 | indent_style = space 35 | indent_size = 4 36 | shell_variant = posix 37 | switch_case_indent = true 38 | 39 | [*.bat] 40 | indent_style = space 41 | indent_size = 4 42 | 43 | [{Makefile,*.mk}] 44 | indent_style = tab 45 | 46 | [*.nix] 47 | indent_style = space 48 | indent_size = 2 49 | 50 | [expected] 51 | trim_trailing_whitespace = false 52 | -------------------------------------------------------------------------------- /.github/linters/.ecrc: -------------------------------------------------------------------------------- 1 | { 2 | "Disable": { 3 | "IndentSize": true 4 | } 5 | } 6 | -------------------------------------------------------------------------------- /.github/workflows/ci-lib.yml: -------------------------------------------------------------------------------- 1 | --- 2 | name: Build 3 | 4 | on: 5 | push: 6 | branches: 7 | - '**' 8 | tags: 9 | - '**' 10 | pull_request: 11 | branches: 12 | - main 13 | schedule: 14 | - cron: '0 1 * * *' 15 | 16 | defaults: 17 | run: 18 | shell: bash 19 | 20 | jobs: 21 | build: 22 | name: Build ${{ github.repository }} with Idris2 latest 23 | runs-on: ubuntu-latest 24 | env: 25 | PACK_DIR: /root/.pack 26 | strategy: 27 | fail-fast: false 28 | container: ghcr.io/stefan-hoeck/idris2-pack:latest 29 | steps: 30 | - name: Checkout 31 | uses: actions/checkout@v2 32 | - name: Build library 33 | run: pack install dom-mvc 34 | - name: Check docs 35 | run: pack typecheck dom-mvc-docs 36 | - name: Check extra 37 | run: pack typecheck dom-mvc-extra 38 | -------------------------------------------------------------------------------- /.github/workflows/ci-super-linter.yml: -------------------------------------------------------------------------------- 1 | --- 2 | name: Lint 3 | 4 | on: 5 | push: 6 | branches: 7 | - '*' 8 | tags: 9 | - '*' 10 | pull_request: 11 | branches: 12 | - main 13 | - master 14 | 15 | jobs: 16 | build: 17 | name: Lint Code Base 18 | runs-on: ubuntu-latest 19 | steps: 20 | 21 | - name: Checkout 22 | uses: actions/checkout@v2 23 | with: 24 | # Full git history is needed to get a proper list of changed files within `super-linter` 25 | fetch-depth: 0 26 | 27 | - name: Lint Code Base 28 | uses: github/super-linter/slim@v4 29 | env: 30 | VALIDATE_ALL_CODEBASE: false 31 | DEFAULT_BRANCH: main 32 | GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} 33 | IGNORE_GENERATED_FILES: true 34 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | build/ 2 | generated/ 3 | *.*~ 4 | js/mvc.js 5 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | BSD 3-Clause License 2 | 3 | Copyright (c) 2023, Stefan Höck 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | 1. Redistributions of source code must retain the above copyright notice, this 9 | list of conditions and the following disclaimer. 10 | 11 | 2. Redistributions in binary form must reproduce the above copyright notice, 12 | this list of conditions and the following disclaimer in the documentation 13 | and/or other materials provided with the distribution. 14 | 15 | 3. Neither the name of the copyright holder nor the names of its 16 | contributors may be used to endorse or promote products derived from 17 | this software without specific prior written permission. 18 | 19 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 20 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 21 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 22 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 23 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 24 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 25 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 26 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 27 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 28 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | export IDRIS2 ?= idris2 2 | 3 | .PHONY: page 4 | page: 5 | pack build docs/docs.ipkg 6 | cp docs/build/exec/mvc.js js/mvc.js 7 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # idris2-dom-mvc: Single Page Web Applications in Idris 2 | 3 | This is an experimental library about putting a nice API on top 4 | of [idris2-dom](https://github.com/stefan-hoeck/idris2-dom) 5 | for writing interactive single page web applications. 6 | Unlike the [idris2-rhone-js](https://github.com/stefan-hoeck/idris2-rhone-js) 7 | library, which takes a functional reactive programming approach 8 | to GUI programming, the concept of this library is much simpler: 9 | Events fired from user interaction update the current application 10 | state via pure functions, and the UI is updated according to 11 | the current event and new application state. This is a similar 12 | approach to what the [Elm programming language](https://elm-lang.org/) 13 | does. However, we take a more fine-grained approach to updating the DOM 14 | and therefore don't need an extra step via a virtual DOM, which 15 | can be beneficial for performance. 16 | 17 | This is still very much work in progress, but I transferred the 18 | whole rhone-js tutorial to this library and the resulting code is 19 | a lot simpler compared to the one from rhone-js. 20 | Here's the link to the [tutorial](docs/src/Examples/Main.md). 21 | 22 | ## Dependencies 23 | 24 | This project makes use of several other Idris2 projects: 25 | 26 | * [idris2-elab-util](https://github.com/stefan-hoeck/idris2-elab-util) 27 | * [idris2-dom](https://github.com/stefan-hoeck/idris2-dom) 28 | * [idris2-refined](https://github.com/stefan-hoeck/idris2-refined) 29 | * [idris2-tailrec](https://github.com/stefan-hoeck/idris2-tailrec) 30 | * [idris2-json-simple](https://github.com/stefan-hoeck/idris2-json) 31 | 32 | It is strongly suggested to use 33 | a package manager like [pack](https://github.com/stefan-hoeck/idris2-pack) 34 | to install and maintain the required dependencies and build the project. 35 | 36 | ## Building the Example Page 37 | 38 | If you have installed pack as suggested above, 39 | you can build the example page with `make page` and have a look at 40 | it by loading `mvc.html` into your browser. 41 | 42 | ## Package `dom-mvc-extra` 43 | 44 | This additional library contains an opinionated set of utilities I find 45 | generally useful in my own projects. It takes a slightly different 46 | approach towards the "model, view, update" concept, by introducing 47 | stateful computations (from `Control.Monad.State`) paired with optics 48 | (from `idris2-monocle`) for operating on smaller parts of a large 49 | application state. 50 | 51 | In addition, it introduces several new data types and interactive DOM 52 | elements that I typically like to have around. 53 | -------------------------------------------------------------------------------- /docs/docs.ipkg: -------------------------------------------------------------------------------- 1 | package dom-mvc-docs 2 | version = 0.0.1 3 | authors = "Stefan Höck" 4 | depends = dom-mvc 5 | , contrib 6 | , finite 7 | , monocle 8 | , rio 9 | 10 | opts = "--codegen javascript" 11 | 12 | main = Examples.Main 13 | executable = "mvc.js" 14 | 15 | modules = Examples.CSS 16 | , Examples.CSS.Colors 17 | , Examples.CSS.Core 18 | , Examples.CSS.Fractals 19 | , Examples.CSS.MathGame 20 | , Examples.CSS.Performance 21 | , Examples.CSS.Reset 22 | 23 | , Examples.Fractals 24 | , Examples.Fractals.Dragon 25 | 26 | , Examples.Balls 27 | , Examples.MathGame 28 | , Examples.Performance 29 | , Examples.Reset 30 | , Examples.Selector 31 | , Examples.Util 32 | 33 | sourcedir = "src" 34 | -------------------------------------------------------------------------------- /docs/src/Examples/Balls.md: -------------------------------------------------------------------------------- 1 | # Running Animations: Bouncing Balls 2 | 3 | In this tutorial we are going to have a look at 4 | running a (non-interactive) animation. We simulate 5 | the frictionless movement of a group of balls under 6 | the influence of gravitation in a two-dimensional 7 | room. 8 | 9 | The user interface will be very simple: Just a 10 | validated text input for defining the number of 11 | balls to animate and a button to (re)start the 12 | animation. The main focus of the tutorial will 13 | be the animation itself. 14 | 15 | ```idris 16 | module Examples.Balls 17 | 18 | import Data.Either 19 | import Data.Nat 20 | import Data.Refined.Integer 21 | import Data.Vect 22 | 23 | import Derive.Prelude 24 | import Derive.Refined 25 | 26 | import Examples.CSS.Colors 27 | import Examples.CSS.Balls 28 | import Examples.Util 29 | 30 | import Text.CSS.Color 31 | import Web.MVC 32 | import Web.MVC.Animate 33 | import Web.MVC.Canvas 34 | 35 | %default total 36 | %language ElabReflection 37 | ``` 38 | 39 | ## Model 40 | 41 | We first define a couple of physical entities: 42 | 43 | ```idris 44 | -- 2D Vector 45 | V2 : Type 46 | V2 = Vect 2 Double 47 | 48 | -- Velocity of a point in 2D space 49 | Velocity : Type 50 | Velocity = V2 51 | 52 | -- Acceleration of a point in 2D space 53 | Acceleration : Type 54 | Acceleration = V2 55 | 56 | -- constant acceleration vector 57 | acc : Acceleration 58 | acc = [0,-9.81] 59 | 60 | -- height and width of the room in m 61 | w : Double 62 | w = 10 63 | 64 | -- start height of all balls 65 | h0 : Double 66 | h0 = 9 67 | 68 | -- ball radius in m 69 | r : Double 70 | r = 0.1 71 | 72 | -- start velocity in m/s 73 | v0 : Double 74 | v0 = 4 75 | 76 | -- vector addition 77 | (+) : V2 -> V2 -> V2 78 | [u,v] + [x,y] = [u+x, v+y] 79 | 80 | -- multiplication with a scalar 81 | (*) : Double -> V2 -> V2 82 | m * [x,y] = [m * x, m * y] 83 | ``` 84 | 85 | We need a data type to hold the current state of a 86 | ball in motion: Its color, position and velocity: 87 | 88 | ```idris 89 | record Ball where 90 | constructor MkBall 91 | col : Color 92 | pos : V2 93 | vel : Velocity 94 | ``` 95 | 96 | Next, we define the event type and application state. 97 | We use again a refined primitive to make sure user input 98 | has been properly validated: 99 | 100 | ```idris 101 | MinBalls, MaxBalls : Integer 102 | MinBalls = 1 103 | MaxBalls = 5000 104 | 105 | record NumBalls where 106 | constructor B 107 | value : Integer 108 | {auto 0 prf : FromTo MinBalls MaxBalls value} 109 | 110 | %runElab derive "NumBalls" [Show,Eq,Ord,RefinedInteger] 111 | 112 | public export 113 | data BallsEv : Type where 114 | BallsInit : BallsEv 115 | GotCleanup : IO () -> BallsEv 116 | Run : BallsEv 117 | NumIn : Either String NumBalls -> BallsEv 118 | Next : DTime -> BallsEv 119 | 120 | public export 121 | record BallsST where 122 | constructor BS 123 | balls : List Ball 124 | count : Nat 125 | dtime : DTime 126 | numBalls : Maybe NumBalls 127 | cleanup : IO () 128 | 129 | fpsCount : Nat 130 | fpsCount = 15 131 | 132 | export 133 | init : BallsST 134 | init = BS [] fpsCount 0 Nothing (pure ()) 135 | 136 | read : String -> Either String NumBalls 137 | read = 138 | let err := "expected integer between \{show MinBalls} and \{show MaxBalls}" 139 | in maybeToEither err . refineNumBalls . cast 140 | ``` 141 | 142 | A couple of things require some explanation: 143 | 144 | First: We want to display the performance of our animation and display 145 | the number of frames per second. For this, we accumulate the time 146 | taken to animate 15 frames (`fpsCount`) and reduce a counter 147 | (`count`) on every frame. 148 | 149 | Second: We want to make sure the animation is stopped once the user 150 | selects another example application. Field `cleanup` is used for this. 151 | It is set to a dummy initially, but once the controller starts the 152 | animation, it is replace with a proper cleanup hook. 153 | This is then invoked in the cleanup routine of the main selector application 154 | when applications are switched. 155 | 156 | Third: We are going to react on an event that is not fired due 157 | to user interaction in this example app. Event `Next dt` will be 158 | fired from the animation we start. It is registered in main 159 | controller at the end of this source file. 160 | 161 | ## View 162 | 163 | We draw our set of balls in a canvas, so we need 164 | some instructions for doing so. A ball will sometimes 165 | move beyond its physical boundaries, in which case the 166 | controller (see below) will adjust its direction 167 | of movement and it will move back into the room. 168 | To get the illusion of reflecting the ball at the 169 | correct location, we hide the ball as long as it is 170 | outside the room (this happens only for very short 171 | moments due to the limited time resolution of 172 | our animation): 173 | 174 | ```idris 175 | inBounds : Ball -> Bool 176 | inBounds (MkBall _ [x,y] _) = y >= 0 && x >= 0 && x <= w 177 | 178 | ballToScene : Ball -> Scene 179 | ballToScene b@(MkBall _ [x,y] _) = 180 | S1 [Fill $ if inBounds b then b.col else transparent] Id $ 181 | circle x (w - y) r Fill 182 | ``` 183 | 184 | The utilities for describing and rendering a canvas scene 185 | can be found at `Web.MVC.Canvas` and its submodules. 186 | 187 | We also draw some primitive walls and a floor to visualize 188 | the room: 189 | 190 | ```idris 191 | -- room wall thickness in meters 192 | wallThickness : Double 193 | wallThickness = 0.20 194 | 195 | -- walls and floor of the room. 196 | walls : Shape 197 | walls = 198 | let hwt := wallThickness / 2 199 | in polyLine [(-hwt, 0), (-hwt, w+hwt), (w+hwt,w+hwt), (w+hwt,0)] 200 | ``` 201 | 202 | We can now describe a scene of balls plus the room 203 | at a given point in time: 204 | 205 | ```idris 206 | ballsToScene : List Ball -> Scene 207 | ballsToScene bs = 208 | SM [] (Transform 50 0 0 50 10 10) $ 209 | [ SM [] Id $ map ballToScene bs 210 | , S1 [Stroke base80, LineWidth wallThickness] Id walls 211 | ] 212 | ``` 213 | 214 | Of course, we also need to set up the HTML objects of 215 | our application: 216 | 217 | ```idris 218 | -- canvas width and height 219 | wcanvas : Bits32 220 | wcanvas = 520 221 | 222 | content : Node BallsEv 223 | content = 224 | div [ class ballsContent ] 225 | [ lbl "Number of balls:" lblCount 226 | , input 227 | [ Id txtCount 228 | , onInput (NumIn . read) 229 | , onEnterDown Run 230 | , class widget 231 | , placeholder "Range: [\{show MinBalls}, \{show MaxBalls}]" 232 | ] [] 233 | , button [Id btnRun, onClick Run, disabled True, classes [widget,btn]] ["Run"] 234 | , div [Id log] [] 235 | , canvas [Id out, width wcanvas, height wcanvas] [] 236 | ] 237 | ``` 238 | 239 | ## Controller 240 | 241 | The main focus of the controller will be to properly 242 | animate the bouncing balls. 243 | 244 | For calculating the next position and velocity vector 245 | of a ball, we use simple Newtonian physics and some 246 | help from the `VectorSpace` interface. We 247 | also need some form of collision detection to make 248 | sure our balls don't leave the room: 249 | 250 | ```idris 251 | -- Collision detection: We verify that the given ball 252 | -- is still in the room. If this is not the case, we simulate 253 | -- a bouncing off the walls by inverting the x-velocity (if the 254 | -- ball hit a wall) or the y-velocity (if the ball hit the ground) 255 | checkBounds : Ball -> Ball 256 | checkBounds b@(MkBall c [px,py] [vx,vy]) = 257 | if (py <= r && vy < 0) then (MkBall c [px,py] [vx,-vy]) 258 | else if (px <= r && vx < 0) then (MkBall c [px,py] [-vx,vy]) 259 | else if (px >= (w - r) && vx > 0) then (MkBall c [px,py] [-vx,vy]) 260 | else b 261 | 262 | -- moves a ball after a given time delta 263 | -- by adjusting its position and velocity 264 | nextBall : DTime -> Ball -> Ball 265 | nextBall delta (MkBall c p v) = 266 | let dt := cast delta / the Double 1000 -- time in seconds 267 | v2 := v + (dt * acc) 268 | p2 := p + (dt / 2 * (v + v2)) 269 | in checkBounds (MkBall c p2 v2) 270 | ``` 271 | 272 | We also need a way to create an initial set of 273 | balls based on user input. We evenly distribute 274 | them at a height of nine meters, giving them 275 | slightly different colors and starting velocities: 276 | 277 | ```idris 278 | initialBalls : NumBalls -> List Ball 279 | initialBalls (B n) = go (cast n) Nil 280 | 281 | where 282 | col : Bits8 -> Color 283 | col 0 = comp100 284 | col 1 = comp80 285 | col 2 = comp60 286 | col 3 = comp40 287 | col _ = comp20 288 | 289 | ball : Nat -> Ball 290 | ball k = 291 | let factor := cast {to = Double} k / (cast n - 1.0) 292 | phi := pi * factor 293 | x0 := 1.0 + factor * 8 294 | in MkBall (col $ cast k `mod` 5) [x0,9] (v0 * [sin phi, cos phi]) 295 | 296 | go : (k : Nat) -> List Ball -> List Ball 297 | go 0 bs = bs 298 | go (S k) bs = go k $ ball k :: bs 299 | ``` 300 | 301 | Adjusting the state involves some fiddling with the FPS counter. 302 | The rest is pretty straight forward: 303 | 304 | ```idris 305 | export 306 | update : BallsEv -> BallsST -> BallsST 307 | update BallsInit s = init 308 | update (GotCleanup cu) s = {cleanup := cu} s 309 | update Run s = {balls := maybe s.balls initialBalls s.numBalls} s 310 | update (NumIn x) s = {numBalls := eitherToMaybe x} s 311 | update (Next m) s = case s.count of 312 | 0 => { balls $= map (nextBall m), dtime := 0, count := fpsCount } s 313 | S k => { balls $= map (nextBall m), dtime $= (+m), count := k } s 314 | ``` 315 | 316 | Almost all events will be fired from the animation, so its safe 317 | to render the scene on every event: 318 | 319 | ```idris 320 | showFPS : Bits32 -> String 321 | showFPS 0 = "" 322 | showFPS n = 323 | let val := 1000 * cast fpsCount `div` n 324 | in "FPS: \{show val}" 325 | ``` 326 | 327 | In addition, we redraw the whole application in case of the `Init` 328 | event, and we update the text field's validation message upon 329 | user input: 330 | 331 | ```idris 332 | export 333 | display : BallsEv -> BallsST -> Cmd BallsEv 334 | display BallsInit _ = 335 | child exampleDiv content <+> animateWithCleanup GotCleanup Next 336 | display Run _ = noAction 337 | display (GotCleanup _) _ = noAction 338 | display (NumIn x) _ = validate txtCount x <+> disabledE btnRun x 339 | display (Next m) s = 340 | batch 341 | [ render out (ballsToScene s.balls) 342 | , cmdIf (s.count == 0) (text log $ showFPS s.dtime) 343 | ] 344 | ``` 345 | 346 | The main controller must make sure the animation is started 347 | by registering an event handler upon initialization. 348 | Function `Web.MVC.Animate.animate` will respond with a 349 | cleanup hook, which we put in the `cleanup` field of the 350 | application state. 351 | 352 | 354 | -------------------------------------------------------------------------------- /docs/src/Examples/CSS.md: -------------------------------------------------------------------------------- 1 | # CSS 2 | 3 | The plan of *rhone-js* is to eventually come 4 | 'batteries included' and this means having a way 5 | to programmatically declare (and change) the appearance 6 | of a web page. The `Text.CSS` submodules therefore come 7 | with a (so far incomplete) set of data types for 8 | declaring CSS rules in a type-safe manner. 9 | 10 | ```idris 11 | module Examples.CSS 12 | 13 | import Data.String 14 | import Examples.CSS.Balls 15 | import Examples.CSS.Core 16 | import Examples.CSS.Fractals 17 | import Examples.CSS.MathGame 18 | import Examples.CSS.Performance 19 | import Examples.CSS.Reset 20 | import Examples.CSS.Requests 21 | import Text.CSS 22 | 23 | %default total 24 | ``` 25 | ## IDs and Classes 26 | 27 | The `rhone.html` document at the project root defines two 28 | entry points for our single-page web page: A `style` element 29 | in the header, where our CSS rules go, and the body element, 30 | where the content of our web page goes. We typically refer 31 | to HTML elements via `ElemRef` values 32 | (defined in `Rhone.JS.ElemRef`), which come with 33 | an ID and a tag to allow us to safely request the properly 34 | typed element from the DOM. 35 | 36 | ## CSS Rules 37 | 38 | Note: I'm by no means an expert, so 39 | the CSS rules below might quite well seem horrible 40 | to purists; suggestions of improvements are welcome. 41 | 42 | Here are the core rules for laying out the web page (the details can 43 | be found in the corresponding submodules). 44 | 45 | ```idris 46 | export 47 | rules : List (Rule 1) 48 | rules = 49 | coreCSS 50 | ++ Balls.css 51 | ++ Fractals.css 52 | ++ MathGame.css 53 | ++ Performance.css 54 | ++ Reset.css 55 | ++ Requests.css 56 | ``` 57 | 58 | 60 | -------------------------------------------------------------------------------- /docs/src/Examples/CSS/Balls.idr: -------------------------------------------------------------------------------- 1 | module Examples.CSS.Balls 2 | 3 | import Data.Vect 4 | import Examples.CSS.Colors 5 | import Text.CSS 6 | import Text.HTML 7 | import public Examples.CSS.Core 8 | 9 | -------------------------------------------------------------------------------- 10 | -- IDs 11 | -------------------------------------------------------------------------------- 12 | 13 | export 14 | out : Ref Canvas 15 | out = Id "balls_out" 16 | 17 | export 18 | btnRun : Ref Tag.Button 19 | btnRun = Id "balls_run" 20 | 21 | export 22 | txtCount : Ref Tag.Input 23 | txtCount = Id "balls_numballs" 24 | 25 | export 26 | log : Ref Div 27 | log = Id "balls_log" 28 | 29 | -------------------------------------------------------------------------------- 30 | -- Rules 31 | -------------------------------------------------------------------------------- 32 | 33 | export 34 | ballsContent : String 35 | ballsContent = "balls_content" 36 | 37 | export 38 | lblCount : String 39 | lblCount = "balls_lblcount" 40 | 41 | data Tag = LNum | INum | BRun | LFPS | Anim | Dot 42 | 43 | AreaTag Tag where 44 | showTag LNum = "LNum" 45 | showTag INum = "INum" 46 | showTag BRun = "BRun" 47 | showTag LFPS = "LFPS" 48 | showTag Anim = "Anim" 49 | showTag Dot = "." 50 | 51 | export 52 | css : List (Rule 1) 53 | css = 54 | [ Media "min-width: 300px" 55 | [ class ballsContent 56 | [ display $ Area 57 | (replicate 4 MinContent) 58 | [MaxContent, MaxContent] 59 | [ [LNum, INum] 60 | , [Dot, BRun] 61 | , [LFPS, LFPS] 62 | , [Anim, Anim] 63 | ] 64 | 65 | , columnGap $ px 10 66 | , rowGap $ px 10 67 | , padding $ VH (px 20) (px 10) 68 | ] 69 | ] 70 | 71 | , Media "min-width: 800px" 72 | [ class ballsContent 73 | [ display $ Area 74 | (replicate 4 MinContent) 75 | [MaxContent, MaxContent, fr 1] 76 | [ [LNum, INum, Anim] 77 | , [Dot, BRun, Anim] 78 | , [LFPS, LFPS, Anim] 79 | , [Dot, Dot, Anim] 80 | ] 81 | 82 | , columnGap $ px 10 83 | , rowGap $ px 10 84 | , padding $ VH (px 20) (px 10) 85 | ] 86 | ] 87 | 88 | , class lblCount [ gridArea LNum ] 89 | 90 | , ref txtCount 91 | [ gridArea INum 92 | , textAlign End 93 | ] 94 | 95 | , ref btnRun [ gridArea BRun ] 96 | 97 | , ref log [ gridArea LFPS ] 98 | 99 | , ref out 100 | [ justifySelf Center 101 | , gridArea Anim 102 | , maxWidth $ px 500 103 | , width $ px 500 104 | ] 105 | ] 106 | -------------------------------------------------------------------------------- /docs/src/Examples/CSS/Colors.idr: -------------------------------------------------------------------------------- 1 | module Examples.CSS.Colors 2 | 3 | import Data.Maybe 4 | import Text.CSS 5 | 6 | export 7 | lightest_grey : Color 8 | lightest_grey = hsl 0 0 90 9 | 10 | export 11 | lighter_grey : Color 12 | lighter_grey = hsl 0 0 70 13 | 14 | export 15 | light_grey : Color 16 | light_grey = hsl 0 0 50 17 | 18 | export 19 | dark_grey : Color 20 | dark_grey = hsl 0 0 30 21 | 22 | export 23 | darker_grey : Color 24 | darker_grey = hsl 0 0 10 25 | 26 | export 27 | base100 : Color 28 | base100 = rgb 230 115 0 29 | 30 | export 31 | base80 : Color 32 | base80 = rgb 230 138 46 33 | 34 | export 35 | base60 : Color 36 | base60 = rgb 230 161 92 37 | 38 | export 39 | base40 : Color 40 | base40 = rgb 230 184 138 41 | 42 | export 43 | base20 : Color 44 | base20 = rgb 230 207 184 45 | 46 | export 47 | comp100 : Color 48 | comp100 = rgb 0 115 230 49 | 50 | export 51 | comp80 : Color 52 | comp80 = rgb 46 138 230 53 | 54 | export 55 | comp60 : Color 56 | comp60 = rgb 92 161 230 57 | 58 | export 59 | comp40 : Color 60 | comp40 = rgb 138 184 230 61 | 62 | export 63 | comp20 : Color 64 | comp20 = rgb 184 207 230 65 | -------------------------------------------------------------------------------- /docs/src/Examples/CSS/Core.idr: -------------------------------------------------------------------------------- 1 | module Examples.CSS.Core 2 | 3 | import Examples.CSS.Colors 4 | import Text.CSS 5 | import Text.HTML 6 | 7 | -------------------------------------------------------------------------------- 8 | -- IDs 9 | -------------------------------------------------------------------------------- 10 | 11 | ||| ID of the `` element. The page content will 12 | ||| be placed here. 13 | export 14 | contentDiv : Ref Tag.Body 15 | contentDiv = Id "content" 16 | 17 | ||| The page consists of a static heading with a title an 18 | ||| (eventually) a short description of the project. 19 | ||| This is followed by a selection box, where visitors can 20 | ||| choose an example application. 21 | ||| 22 | ||| The example application will be dynamicall generated and 23 | ||| placed in to a `
` with ID `"example"`. 24 | export 25 | exampleDiv : Ref Div 26 | exampleDiv = Id "example" 27 | 28 | ||| ID of a ` 7 | 8 | 9 | 10 | 11 | 12 | -------------------------------------------------------------------------------- /pack.toml: -------------------------------------------------------------------------------- 1 | [custom.all.dom-mvc] 2 | type = "local" 3 | path = "." 4 | ipkg = "dom-mvc.ipkg" 5 | 6 | [custom.all.dom-mvc-extra] 7 | type = "local" 8 | path = "extra" 9 | ipkg = "dom-mvc-extra.ipkg" 10 | 11 | [custom.all.dom-mvc-docs] 12 | type = "local" 13 | path = "docs" 14 | ipkg = "docs.ipkg" 15 | 16 | [custom.all.tailrec] 17 | type = "git" 18 | url = "https://github.com/stefan-hoeck/idris2-tailrec" 19 | commit = "latest:main" 20 | ipkg = "tailrec.ipkg" 21 | -------------------------------------------------------------------------------- /pics/pic1.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/stefan-hoeck/idris2-dom-mvc/aa13b5cb074b9f1537cc55cac365cf1f5d76c8b3/pics/pic1.jpg -------------------------------------------------------------------------------- /pics/pic10.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/stefan-hoeck/idris2-dom-mvc/aa13b5cb074b9f1537cc55cac365cf1f5d76c8b3/pics/pic10.jpg -------------------------------------------------------------------------------- /pics/pic11.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/stefan-hoeck/idris2-dom-mvc/aa13b5cb074b9f1537cc55cac365cf1f5d76c8b3/pics/pic11.jpg -------------------------------------------------------------------------------- /pics/pic2.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/stefan-hoeck/idris2-dom-mvc/aa13b5cb074b9f1537cc55cac365cf1f5d76c8b3/pics/pic2.jpg -------------------------------------------------------------------------------- /pics/pic3.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/stefan-hoeck/idris2-dom-mvc/aa13b5cb074b9f1537cc55cac365cf1f5d76c8b3/pics/pic3.jpg -------------------------------------------------------------------------------- /pics/pic4.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/stefan-hoeck/idris2-dom-mvc/aa13b5cb074b9f1537cc55cac365cf1f5d76c8b3/pics/pic4.jpg -------------------------------------------------------------------------------- /pics/pic5.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/stefan-hoeck/idris2-dom-mvc/aa13b5cb074b9f1537cc55cac365cf1f5d76c8b3/pics/pic5.jpg -------------------------------------------------------------------------------- /pics/pic6.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/stefan-hoeck/idris2-dom-mvc/aa13b5cb074b9f1537cc55cac365cf1f5d76c8b3/pics/pic6.jpg -------------------------------------------------------------------------------- /pics/pic7.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/stefan-hoeck/idris2-dom-mvc/aa13b5cb074b9f1537cc55cac365cf1f5d76c8b3/pics/pic7.jpg -------------------------------------------------------------------------------- /pics/pic8.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/stefan-hoeck/idris2-dom-mvc/aa13b5cb074b9f1537cc55cac365cf1f5d76c8b3/pics/pic8.jpg -------------------------------------------------------------------------------- /pics/pic9.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/stefan-hoeck/idris2-dom-mvc/aa13b5cb074b9f1537cc55cac365cf1f5d76c8b3/pics/pic9.jpg -------------------------------------------------------------------------------- /src/Text/CSS.idr: -------------------------------------------------------------------------------- 1 | module Text.CSS 2 | 3 | import public Data.Refined 4 | import public Text.CSS.Angle 5 | import public Text.CSS.Color 6 | import public Text.CSS.Dir 7 | import public Text.CSS.Declaration 8 | import public Text.CSS.Flexbox 9 | import public Text.CSS.Gradient 10 | import public Text.CSS.Grid 11 | import public Text.CSS.Length 12 | import public Text.CSS.ListStyleType 13 | import public Text.CSS.Percentage 14 | import public Text.CSS.Property 15 | import public Text.CSS.Rule 16 | import public Text.CSS.Selector 17 | -------------------------------------------------------------------------------- /src/Text/CSS/Angle.idr: -------------------------------------------------------------------------------- 1 | module Text.CSS.Angle 2 | 3 | %default total 4 | 5 | public export 6 | data Angle : Type where 7 | Deg : Double -> Angle 8 | Rad : Double -> Angle 9 | Grad : Double -> Angle 10 | Turn : Double -> Angle 11 | 12 | export 13 | Interpolation Angle where 14 | interpolate (Deg x) = show x ++ "deg" 15 | interpolate (Rad x) = show x ++ "rad" 16 | interpolate (Grad x) = show x ++ "grad" 17 | interpolate (Turn x) = show x ++ "turn" 18 | 19 | export %inline 20 | deg : Cast Angle a => Double -> a 21 | deg = cast . Deg 22 | 23 | export %inline 24 | rad : Cast Angle a => Double -> a 25 | rad = cast . Rad 26 | 27 | export %inline 28 | grad : Cast Angle a => Double -> a 29 | grad = cast . Grad 30 | 31 | export %inline 32 | turn : Cast Angle a => Double -> a 33 | turn = cast . Turn 34 | -------------------------------------------------------------------------------- /src/Text/CSS/Cursor.idr: -------------------------------------------------------------------------------- 1 | module Text.CSS.Cursor 2 | 3 | %default total 4 | 5 | 6 | -------------------------------------------------------------------------------- 7 | -- Cursor Types 8 | -------------------------------------------------------------------------------- 9 | 10 | ||| All standard mouse cursors. 11 | ||| 12 | ||| For using custom icons, use type `Url` linking to an 13 | ||| image and choose the offset for the mouse position. 14 | public export 15 | data Cursor : Type where 16 | Alias : Cursor 17 | AllScroll : Cursor 18 | Auto : Cursor 19 | Cell : Cursor 20 | ColResize : Cursor 21 | ContextMenu : Cursor 22 | Copy : Cursor 23 | Crosshair : Cursor 24 | Default : Cursor 25 | EResize : Cursor 26 | EwResize : Cursor 27 | Grab : Cursor 28 | Grabbing : Cursor 29 | Help : Cursor 30 | Move : Cursor 31 | NResize : Cursor 32 | NeResize : Cursor 33 | NeswResize : Cursor 34 | NsResize : Cursor 35 | NwResize : Cursor 36 | NwseResize : Cursor 37 | NoDrop : Cursor 38 | None : Cursor 39 | NotAllowed : Cursor 40 | Pointer : Cursor 41 | Progress : Cursor 42 | RowResize : Cursor 43 | SResize : Cursor 44 | SeResize : Cursor 45 | SwResize : Cursor 46 | Text : Cursor 47 | Url : (url : String) -> (xOffset,yOffset : Nat) -> Cursor 48 | WResize : Cursor 49 | Wait : Cursor 50 | ZoomIn : Cursor 51 | ZoomOut : Cursor 52 | 53 | export 54 | Interpolation Cursor where 55 | interpolate Alias = "alias" 56 | interpolate AllScroll = "all-scroll" 57 | interpolate Auto = "auto" 58 | interpolate Cell = "cell" 59 | interpolate ColResize = "col-resize" 60 | interpolate ContextMenu = "context-menu" 61 | interpolate Copy = "copy" 62 | interpolate Crosshair = "crosshair" 63 | interpolate Default = "default" 64 | interpolate EResize = "e-resize" 65 | interpolate EwResize = "ew-resize" 66 | interpolate Grab = "grab" 67 | interpolate Grabbing = "grabbing" 68 | interpolate Help = "help" 69 | interpolate Move = "move" 70 | interpolate NResize = "n-resize" 71 | interpolate NeResize = "ne-resize" 72 | interpolate NeswResize = "nesw-resize" 73 | interpolate NsResize = "ns-resize" 74 | interpolate NwResize = "nw-resize" 75 | interpolate NwseResize = "nwse-resize" 76 | interpolate NoDrop = "no-drop" 77 | interpolate None = "none" 78 | interpolate NotAllowed = "not-allowed" 79 | interpolate Pointer = "pointer" 80 | interpolate Progress = "progress" 81 | interpolate RowResize = "row-resize" 82 | interpolate SResize = "s-resize" 83 | interpolate SeResize = "se-resize" 84 | interpolate SwResize = "sw-resize" 85 | interpolate Text = "text" 86 | interpolate (Url url x y) = "url(\{show url}) \{show x} \{show y}, auto" 87 | interpolate WResize = "w-resize" 88 | interpolate Wait = "wait" 89 | interpolate ZoomIn = "zoom-in" 90 | interpolate ZoomOut = "zoom-out" 91 | -------------------------------------------------------------------------------- /src/Text/CSS/Declaration.idr: -------------------------------------------------------------------------------- 1 | module Text.CSS.Declaration 2 | 3 | import Data.List 4 | import Text.CSS.Color 5 | import Text.CSS.Dir 6 | import Text.CSS.Flexbox 7 | import Text.CSS.Gradient 8 | import Text.CSS.Grid 9 | import Text.CSS.Length 10 | import Text.CSS.ListStyleType 11 | import Text.CSS.Percentage 12 | import Text.CSS.Property 13 | 14 | %default total 15 | 16 | public export 17 | data Declaration : Type where 18 | Decl : (property, value : String) -> Declaration 19 | Display : Display -> Declaration 20 | 21 | export 22 | Interpolation Declaration where 23 | interpolate (Decl p v) = "\{p}: \{v};" 24 | interpolate (Display Flex) = "display: flex;" 25 | interpolate (Display Grid) = "display: grid;" 26 | interpolate (Display $ Area rs cs a) = "\{renderArea rs cs a};" 27 | 28 | export %inline 29 | decl : Interpolation a => String -> a -> Declaration 30 | decl s = Decl s . interpolate 31 | 32 | -- prefix 33 | prfx : Dir a -> String 34 | prfx (Left _) = "-left" 35 | prfx (Right _) = "-right" 36 | prfx (Top _) = "-top" 37 | prfx (Bottom _) = "-bottom" 38 | prfx _ = "" 39 | 40 | export 41 | dirDecl : (prop : String) -> (a -> String) -> Dir a -> Declaration 42 | dirDecl prop f d = 43 | let vs := concat . intersperse " " . map f $ vals d 44 | in Decl "\{prop}\{prfx d}" vs 45 | 46 | export 47 | dirDecl2 : (prop,suffix : String) -> (a -> String) -> Dir a -> Declaration 48 | dirDecl2 prop suffix f d = 49 | let vs := concat . intersperse " " . map f $ vals d 50 | in Decl "\{prop}\{prfx d}-\{suffix}" vs 51 | 52 | -------------------------------------------------------------------------------- 53 | -- Predefined Properties 54 | -------------------------------------------------------------------------------- 55 | 56 | export %inline 57 | alignItems : FlexAlign -> Declaration 58 | alignItems = decl "align-items" 59 | 60 | export %inline 61 | alignSelf : FlexAlign -> Declaration 62 | alignSelf = decl "align-self" 63 | 64 | export %inline 65 | backgroundColor : Color -> Declaration 66 | backgroundColor = decl "background-color" 67 | 68 | export %inline 69 | backgroundImage : (url : String) -> Declaration 70 | backgroundImage = Decl "background-image" 71 | 72 | export %inline 73 | backgroundImageGradient : Gradient -> Declaration 74 | backgroundImageGradient = decl "background-image" 75 | 76 | export %inline 77 | backgroundSize : Width -> Declaration 78 | backgroundSize = decl "background-size" 79 | 80 | export %inline 81 | border : String -> Declaration 82 | border = Decl "border" 83 | 84 | export %inline 85 | borderColor : Dir Color -> Declaration 86 | borderColor = dirDecl2 "border" "color" interpolate 87 | 88 | export %inline 89 | borderRadius : BorderRadius -> Declaration 90 | borderRadius = decl "border-radius" 91 | 92 | export %inline 93 | borderStyle : Dir BorderStyle -> Declaration 94 | borderStyle = dirDecl2 "border" "style" interpolate 95 | 96 | export %inline 97 | borderWidth : Dir BorderWidth -> Declaration 98 | borderWidth = dirDecl2 "border" "width" interpolate 99 | 100 | export %inline 101 | boxSizing : BoxSizing -> Declaration 102 | boxSizing = decl "box-sizing" 103 | 104 | export %inline 105 | color : Color -> Declaration 106 | color = decl "color" 107 | 108 | export %inline 109 | columnGap : Length -> Declaration 110 | columnGap = decl "column-gap" 111 | 112 | export %inline 113 | direction : Direction -> Declaration 114 | direction = decl "direction" 115 | 116 | export %inline 117 | display : Display -> Declaration 118 | display = Display 119 | 120 | export %inline 121 | flex : String -> Declaration 122 | flex = Decl "flex" 123 | 124 | export %inline 125 | flexBasis : FlexBasis -> Declaration 126 | flexBasis = decl "flex-basis" 127 | 128 | export %inline 129 | flexDirection : FlexDirection -> Declaration 130 | flexDirection = decl "flex-direction" 131 | 132 | export %inline 133 | flexWrap : String -> Declaration 134 | flexWrap = Decl "flex-wrap" 135 | 136 | export %inline 137 | flexGrow : Nat -> Declaration 138 | flexGrow = Decl "flex-grow" . show 139 | 140 | export %inline 141 | flexFlow : List FlexFlow -> Declaration 142 | flexFlow = decl "flex-flow" 143 | 144 | export %inline 145 | fontFamily : String -> Declaration 146 | fontFamily = Decl "font-family" 147 | 148 | export %inline 149 | fontSize : FontSize -> Declaration 150 | fontSize = decl "font-size" 151 | 152 | export %inline 153 | fontWeight : FontWeight -> Declaration 154 | fontWeight = decl "font-weight" 155 | 156 | export %inline 157 | gridArea : AreaTag a => a -> Declaration 158 | gridArea = Decl "grid-area" . showTag 159 | 160 | export %inline 161 | gridColumn : GridPosition -> Declaration 162 | gridColumn = decl "grid-column" 163 | 164 | export %inline 165 | gridRow : GridPosition -> Declaration 166 | gridRow = decl "grid-row" 167 | 168 | export %inline 169 | gridTemplateColumns : List GridValue -> Declaration 170 | gridTemplateColumns = decl "grid-template-columns" 171 | 172 | export %inline 173 | gridTemplateRows : List GridValue -> Declaration 174 | gridTemplateRows = decl "grid-template-rows" 175 | 176 | export %inline 177 | height : Width -> Declaration 178 | height = decl "height" 179 | 180 | export %inline 181 | justifyContent : FlexJustify -> Declaration 182 | justifyContent = decl "justify-content" 183 | 184 | export %inline 185 | justifySelf : FlexJustify -> Declaration 186 | justifySelf = decl "justify-self" 187 | 188 | export %inline 189 | listStyleType : ListStyleType -> Declaration 190 | listStyleType = decl "list-style-type" 191 | 192 | export %inline 193 | margin : Dir Length -> Declaration 194 | margin = dirDecl "margin" interpolate 195 | 196 | export %inline 197 | maxHeight : Width -> Declaration 198 | maxHeight = decl "max-height" 199 | 200 | export %inline 201 | maxWidth : Width -> Declaration 202 | maxWidth = decl "max-width" 203 | 204 | export %inline 205 | minHeight : Width -> Declaration 206 | minHeight = decl "min-height" 207 | 208 | export %inline 209 | minWidth : Width -> Declaration 210 | minWidth = decl "min-width" 211 | 212 | export %inline 213 | overflowX : Overflow -> Declaration 214 | overflowX = decl "overflow-x" 215 | 216 | export %inline 217 | overflowY : Overflow -> Declaration 218 | overflowY = decl "overflow-y" 219 | 220 | export %inline 221 | padding : Dir Length -> Declaration 222 | padding = dirDecl "padding" interpolate 223 | 224 | export %inline 225 | rowGap : Length -> Declaration 226 | rowGap = decl "row-gap" 227 | 228 | export %inline 229 | textAlign : TextAlign -> Declaration 230 | textAlign = decl "text-align" 231 | 232 | export %inline 233 | textDecoration : String -> Declaration 234 | textDecoration = Decl "text-decoration" 235 | 236 | export %inline 237 | textDecorationColor : Color -> Declaration 238 | textDecorationColor = decl "text-decoration-color" 239 | 240 | export %inline 241 | textDecorationLine : TextDecorationLine -> Declaration 242 | textDecorationLine = decl "text-decoration-line" 243 | 244 | export %inline 245 | textDecorationStyle : TextDecorationStyle -> Declaration 246 | textDecorationStyle = decl "text-decoration-style" 247 | 248 | export %inline 249 | textOverflow : TextOverflow -> Declaration 250 | textOverflow = decl "text-overflow" 251 | 252 | export %inline 253 | textOverflow2 : TextOverflow -> TextOverflow -> Declaration 254 | textOverflow2 x y = Decl "text-overflow" "\{x} \{y}" 255 | 256 | export %inline 257 | width : Width -> Declaration 258 | width = decl "width" 259 | 260 | export %inline 261 | whitespace : WhiteSpace -> Declaration 262 | whitespace = decl "white-space" 263 | -------------------------------------------------------------------------------- /src/Text/CSS/Dir.idr: -------------------------------------------------------------------------------- 1 | module Text.CSS.Dir 2 | 3 | import Data.List 4 | import Text.CSS.Length 5 | import Text.CSS.Percentage 6 | 7 | %default total 8 | 9 | public export 10 | data Dir : Type -> Type where 11 | All : a -> Dir a 12 | Left : a -> Dir a 13 | Right : a -> Dir a 14 | Top : a -> Dir a 15 | Bottom : a -> Dir a 16 | ||| Vertical and horizontal width 17 | VH : (v, h : a) -> Dir a 18 | ||| Top, horizontal, bottom width 19 | THB : (t, h, b : a) -> Dir a 20 | ||| Top, right, bottom, left 21 | TRBL : (t, r, b, l : a) -> Dir a 22 | 23 | export 24 | vals : Dir a -> List a 25 | vals (All x) = [x] 26 | vals (Left x) = [x] 27 | vals (Right x) = [x] 28 | vals (Top x) = [x] 29 | vals (Bottom x) = [x] 30 | vals (VH v h) = [v,h] 31 | vals (THB t h b) = [t,h,b] 32 | vals (TRBL t r b l) = [t,r,b,l] 33 | 34 | export %inline 35 | Cast Length a => Cast Length (Dir a) where 36 | cast = All . cast 37 | 38 | export %inline 39 | Cast Percentage a => Cast Percentage (Dir a) where 40 | cast = All . cast 41 | -------------------------------------------------------------------------------- /src/Text/CSS/Flexbox.idr: -------------------------------------------------------------------------------- 1 | module Text.CSS.Flexbox 2 | 3 | import Data.List 4 | 5 | %default total 6 | 7 | public export 8 | data FlexDirection = 9 | Row 10 | | RowReverse 11 | | Column 12 | | ColumnReverse 13 | 14 | export 15 | Interpolation FlexDirection where 16 | interpolate Row = "row" 17 | interpolate RowReverse = "row-reverse" 18 | interpolate Column = "column" 19 | interpolate ColumnReverse = "column-reverse" 20 | 21 | public export 22 | data FlexAlign = 23 | Normal 24 | | Stretch 25 | | Center 26 | | Start 27 | | End 28 | | FlexStart 29 | | FlexEnd 30 | | Baseline 31 | | FirstBaseline 32 | | LastBaseline 33 | 34 | export 35 | Interpolation FlexAlign where 36 | interpolate Normal = "normal" 37 | interpolate Stretch = "stretch" 38 | interpolate Center = "center" 39 | interpolate Start = "start" 40 | interpolate End = "end" 41 | interpolate FlexStart = "flex-start" 42 | interpolate FlexEnd = "flex-end" 43 | interpolate Baseline = "baseline" 44 | interpolate FirstBaseline = "first baseline" 45 | interpolate LastBaseline = "last baseline" 46 | 47 | namespace FlexJustify 48 | public export 49 | data FlexJustify = 50 | Center 51 | | Start 52 | | End 53 | | FlexStart 54 | | FlexEnd 55 | | Left 56 | | Right 57 | | Normal 58 | | SpaceBetween 59 | | SpaceAround 60 | | SpaceEvenly 61 | | Stretch 62 | 63 | export 64 | Interpolation FlexJustify where 65 | interpolate Center = "center" 66 | interpolate Start = "start" 67 | interpolate End = "end" 68 | interpolate FlexStart = "flex-start" 69 | interpolate FlexEnd = "flex-end" 70 | interpolate Left = "left" 71 | interpolate Right = "right" 72 | interpolate Normal = "normal" 73 | interpolate SpaceBetween = "space-between" 74 | interpolate SpaceAround = "space-around" 75 | interpolate SpaceEvenly = "space-evenly" 76 | interpolate Stretch = "stretch" 77 | 78 | namespace FlexFlow 79 | public export 80 | data FlexFlow = 81 | Column 82 | | ColumnReverse 83 | | Inherit 84 | | Initial 85 | | Nowrap 86 | | Revert 87 | | RevertLayout 88 | | Row 89 | | RowReverse 90 | | Unset 91 | | Wrap 92 | | WrapReverse 93 | 94 | export 95 | Interpolation FlexFlow where 96 | interpolate Column = "column" 97 | interpolate ColumnReverse = "column-reverse" 98 | interpolate Inherit = "inherit" 99 | interpolate Initial = "initial" 100 | interpolate Nowrap = "nowrap" 101 | interpolate Revert = "revert" 102 | interpolate RevertLayout = "revert-layout" 103 | interpolate Row = "row" 104 | interpolate RowReverse = "row-reverse" 105 | interpolate Unset = "unset" 106 | interpolate Wrap = "wrap" 107 | interpolate WrapReverse = "wrap-reverse" 108 | 109 | export 110 | Interpolation (List FlexFlow) where 111 | interpolate = concat . intersperse " " . map interpolate 112 | -------------------------------------------------------------------------------- /src/Text/CSS/Gradient.idr: -------------------------------------------------------------------------------- 1 | module Text.CSS.Gradient 2 | 3 | import Data.List 4 | import Data.Nat 5 | import Data.String 6 | import Text.CSS.Angle 7 | import Text.CSS.Color 8 | import Text.CSS.Length 9 | import Text.CSS.Percentage 10 | 11 | %default total 12 | 13 | -------------------------------------------------------------------------------- 14 | -- Side or Corner 15 | -------------------------------------------------------------------------------- 16 | 17 | public export 18 | data SideOrCorner : Type where 19 | Left : SideOrCorner 20 | Right : SideOrCorner 21 | Top : SideOrCorner 22 | Bottom : SideOrCorner 23 | TopLeft : SideOrCorner 24 | TopRight : SideOrCorner 25 | BottomLeft : SideOrCorner 26 | BottomRight : SideOrCorner 27 | 28 | export 29 | Interpolation SideOrCorner where 30 | interpolate Left = "left" 31 | interpolate Right = "right" 32 | interpolate Top = "top" 33 | interpolate Bottom = "bottom" 34 | interpolate TopLeft = "top left" 35 | interpolate TopRight = "top right" 36 | interpolate BottomLeft = "bottom left" 37 | interpolate BottomRight = "bottom right" 38 | 39 | -------------------------------------------------------------------------------- 40 | -- Linear Direction 41 | -------------------------------------------------------------------------------- 42 | 43 | public export 44 | data LinearDirection : Type where 45 | Deflt : LinearDirection 46 | Angle : Angle -> LinearDirection 47 | To : SideOrCorner -> LinearDirection 48 | 49 | public export %inline 50 | Cast Angle LinearDirection where 51 | cast = Angle 52 | 53 | export 54 | Interpolation LinearDirection where 55 | interpolate Deflt = "" 56 | interpolate (Angle x) = "\{x}" 57 | interpolate (To x) = "to \{x}" 58 | 59 | -------------------------------------------------------------------------------- 60 | -- Length or Percentage 61 | -------------------------------------------------------------------------------- 62 | 63 | public export 64 | data LengthOrPercentage : Type where 65 | L : Length -> LengthOrPercentage 66 | P : Percentage -> LengthOrPercentage 67 | 68 | export %inline 69 | Cast Length LengthOrPercentage where cast = L 70 | 71 | export %inline 72 | Cast Percentage LengthOrPercentage where cast = P 73 | 74 | export 75 | Interpolation LengthOrPercentage where 76 | interpolate (L x) = interpolate x 77 | interpolate (P x) = interpolate x 78 | 79 | -------------------------------------------------------------------------------- 80 | -- Color Stop List 81 | -------------------------------------------------------------------------------- 82 | 83 | public export 84 | data CSLState = Empty | Stop | Hint 85 | 86 | public export 87 | data ColorStopListElem : (st : CSLState) -> Type where 88 | C : 89 | Color 90 | -> (ps : List LengthOrPercentage) 91 | -> {auto 0 prf : LTE (length ps) 2} 92 | -> ColorStopListElem Stop 93 | H : LengthOrPercentage -> ColorStopListElem Hint 94 | 95 | export %inline 96 | col : Color -> ColorStopListElem Stop 97 | col c = C c [] 98 | 99 | export 100 | Interpolation (ColorStopListElem st) where 101 | interpolate (C c ps) = unwords $ interpolate c :: map interpolate ps 102 | interpolate (H x) = "\{x}" 103 | 104 | public export 105 | data Match : CSLState -> CSLState -> Type where 106 | MatchStop : Match Stop s 107 | MatchHint : Match Hint Stop 108 | 109 | public export 110 | data ColorStopList : (st : CSLState) -> Type where 111 | Nil : ColorStopList Empty 112 | (::) : 113 | (h : ColorStopListElem sh) 114 | -> (t : ColorStopList st) 115 | -> {auto 0 prf : Match sh st} 116 | -> ColorStopList sh 117 | 118 | export 119 | Interpolation (ColorStopList st) where 120 | interpolate [v] = "\{v}" 121 | interpolate (h::t) = "\{h}, \{t}" 122 | interpolate [] = "" 123 | 124 | -------------------------------------------------------------------------------- 125 | -- Gradient 126 | -------------------------------------------------------------------------------- 127 | 128 | public export 129 | data Gradient : Type where 130 | Linear : 131 | (dir : LinearDirection) 132 | -> (colors : ColorStopList Stop) 133 | -> Gradient 134 | 135 | export 136 | Interpolation Gradient where 137 | interpolate (Linear Deflt cs) = "linear-gradient(\{cs})" 138 | interpolate (Linear x cs) = "linear-gradient(\{x}, \{cs})" 139 | -------------------------------------------------------------------------------- /src/Text/CSS/Grid.idr: -------------------------------------------------------------------------------- 1 | ||| Types and utilities for laying out components in a grid. 2 | module Text.CSS.Grid 3 | 4 | import Data.List 5 | import Text.CSS.Length 6 | import Text.CSS.Percentage 7 | 8 | -------------------------------------------------------------------------------- 9 | -- Flex Values 10 | -------------------------------------------------------------------------------- 11 | 12 | public export 13 | record Flex where 14 | constructor MkFlex 15 | value : Bits16 16 | 17 | export %inline 18 | fr : Cast Flex a => Bits16 -> a 19 | fr = cast . MkFlex 20 | 21 | export 22 | Interpolation Flex where 23 | interpolate f = "\{show f.value}fr" 24 | 25 | -------------------------------------------------------------------------------- 26 | -- MinMax Values 27 | -------------------------------------------------------------------------------- 28 | 29 | public export 30 | data MinMaxValue : Type where 31 | Auto : MinMaxValue 32 | MML : Length -> MinMaxValue 33 | MMP : Percentage -> MinMaxValue 34 | MMF : Flex -> MinMaxValue 35 | MinContent : MinMaxValue 36 | MaxContent : MinMaxValue 37 | 38 | export %inline 39 | Cast Length MinMaxValue where 40 | cast = MML 41 | 42 | export %inline 43 | Cast Percentage MinMaxValue where 44 | cast = MMP 45 | 46 | export %inline 47 | Cast Flex MinMaxValue where 48 | cast = MMF 49 | 50 | export 51 | Interpolation MinMaxValue where 52 | interpolate Auto = "auto" 53 | interpolate MinContent = "min-content" 54 | interpolate MaxContent = "max-content" 55 | interpolate (MML x) = interpolate x 56 | interpolate (MMP x) = interpolate x 57 | interpolate (MMF x) = interpolate x 58 | 59 | -------------------------------------------------------------------------------- 60 | -- GridValue 61 | -------------------------------------------------------------------------------- 62 | 63 | namespace GridValue 64 | public export 65 | data GridValue : Type where 66 | GL : Length -> GridValue 67 | GP : Percentage -> GridValue 68 | GF : Flex -> GridValue 69 | MinMax : (min,max : MinMaxValue) -> GridValue 70 | MaxContent : GridValue 71 | MinContent : GridValue 72 | 73 | export 74 | Interpolation GridValue where 75 | interpolate (GL x) = interpolate x 76 | interpolate (GP x) = interpolate x 77 | interpolate (GF x) = interpolate x 78 | interpolate (MinMax min max) = "minmax(\{min}, \{max})" 79 | interpolate MaxContent = "max-content" 80 | interpolate MinContent = "min-content" 81 | 82 | export 83 | Interpolation (List GridValue) where 84 | interpolate = fastConcat . intersperse " " . map interpolate 85 | 86 | export %inline 87 | Cast Length GridValue where 88 | cast = GL 89 | 90 | export %inline 91 | Cast Percentage GridValue where 92 | cast = GP 93 | 94 | export %inline 95 | Cast Flex GridValue where 96 | cast = GF 97 | 98 | -------------------------------------------------------------------------------- 99 | -- GridPosition 100 | -------------------------------------------------------------------------------- 101 | 102 | public export 103 | data GridPosition : Type where 104 | At : Bits32 -> GridPosition 105 | FromTo : Bits32 -> Bits32 -> GridPosition 106 | 107 | export 108 | Interpolation GridPosition where 109 | interpolate (At x) = show x 110 | interpolate (FromTo x y) = "\{show x} / \{show y}" 111 | -------------------------------------------------------------------------------- /src/Text/CSS/Length.idr: -------------------------------------------------------------------------------- 1 | module Text.CSS.Length 2 | 3 | %default total 4 | 5 | public export 6 | data Length : Type where 7 | Pt : Bits16 -> Length 8 | Px : Bits16 -> Length 9 | Em : Double -> Length 10 | Rem : Double -> Length 11 | 12 | export 13 | Interpolation Length where 14 | interpolate (Pt x) = show x ++ "pt" 15 | interpolate (Px x) = show x ++ "px" 16 | interpolate (Em x) = show x ++ "em" 17 | interpolate (Rem x) = show x ++ "rem" 18 | 19 | export %inline 20 | pt : Cast Length a => Bits16 -> a 21 | pt = cast . Pt 22 | 23 | export %inline 24 | px : Cast Length a => Bits16 -> a 25 | px = cast . Px 26 | 27 | export %inline 28 | em : Cast Length a => Double -> a 29 | em = cast . Em 30 | 31 | export %inline 32 | rem : Cast Length a => Double -> a 33 | rem = cast . Rem 34 | -------------------------------------------------------------------------------- /src/Text/CSS/ListStyleType.idr: -------------------------------------------------------------------------------- 1 | module Text.CSS.ListStyleType 2 | 3 | %default total 4 | 5 | public export 6 | data ListStyleType : Type where 7 | None : ListStyleType 8 | Disc : ListStyleType 9 | Circle : ListStyleType 10 | Square : ListStyleType 11 | Decimal : ListStyleType 12 | LowerAlpha : ListStyleType 13 | UpperAlpha : ListStyleType 14 | LowerRoman : ListStyleType 15 | UpperRoman : ListStyleType 16 | 17 | export 18 | Interpolation ListStyleType where 19 | interpolate None = "none" 20 | interpolate Disc = "disc" 21 | interpolate Circle = "circle" 22 | interpolate Square = "square" 23 | interpolate Decimal = "decimal" 24 | interpolate LowerAlpha = "lower-alpha" 25 | interpolate UpperAlpha = "upper-alpha" 26 | interpolate LowerRoman = "lower-roman" 27 | interpolate UpperRoman = "upper-roman" 28 | -------------------------------------------------------------------------------- /src/Text/CSS/Percentage.idr: -------------------------------------------------------------------------------- 1 | module Text.CSS.Percentage 2 | 3 | import Data.Refined 4 | import Derive.Prelude 5 | import Derive.Refined 6 | 7 | %language ElabReflection 8 | %default total 9 | 10 | public export 11 | IsPercentage : Double -> Bool 12 | IsPercentage x = 0 <= x && x <= 100 13 | 14 | ||| A floating point percentage value in the the 15 | ||| range [0,100]. 16 | public export 17 | record Percentage where 18 | constructor MkPercentage 19 | value : Double 20 | {auto 0 prf : Holds IsPercentage value} 21 | 22 | %runElab derive "Percentage" [Show,Eq,Ord,RefinedDouble] 23 | 24 | export 25 | Interpolation Percentage where 26 | interpolate (MkPercentage v) = show v ++ "%" 27 | 28 | ||| Convenience function for creating percentages with little 29 | ||| syntactic overhead. 30 | ||| 31 | ||| ```idris example 32 | ||| perc 12 33 | ||| ``` 34 | export %inline 35 | perc : 36 | {auto _ : Cast Percentage a} 37 | -> (v : Double) 38 | -> {auto 0 prf : Holds IsPercentage v} 39 | -> a 40 | perc v = cast $ MkPercentage v 41 | -------------------------------------------------------------------------------- /src/Text/CSS/Rule.idr: -------------------------------------------------------------------------------- 1 | module Text.CSS.Rule 2 | 3 | import Data.String 4 | import Text.CSS.Declaration 5 | import Text.CSS.Selector 6 | import Text.HTML.Ref 7 | import Text.HTML.Tag 8 | 9 | %default total 10 | 11 | public export 12 | data Rule : (n : Nat) -> Type where 13 | Sel : 14 | (selectors : List Selector) 15 | -> (decls : List Declaration) 16 | -> Rule n 17 | 18 | Media : 19 | (query : String) 20 | -> (rules : List $ Rule 0) 21 | -> Rule 1 22 | 23 | export %inline 24 | sel : Selector -> List Declaration -> Rule n 25 | sel s = Sel [s] 26 | 27 | export %inline 28 | class : String -> List Declaration -> Rule n 29 | class s = sel (class s) 30 | 31 | export 32 | classes : List String -> List Declaration -> Rule n 33 | classes = sel . classes 34 | 35 | export %inline 36 | elem : {str : _} -> (0 tag : HTMLTag str) -> List Declaration -> Rule n 37 | elem v = sel $ elem v 38 | 39 | export %inline 40 | id : String -> List Declaration -> Rule n 41 | id = sel . id 42 | 43 | export %inline 44 | star : List Declaration -> Rule n 45 | star = sel Star 46 | 47 | ||| Uses an element ref as an ID selector 48 | export %inline 49 | ref : {0 t : HTMLTag s} -> Ref t -> List Declaration -> Rule n 50 | ref (Id i) = id i 51 | 52 | export 53 | Interpolation (Rule n) where 54 | interpolate (Sel s ds) = 55 | let dss := fastConcat $ map interpolate ds 56 | ss := fastConcat . intersperse ", " $ map interpolate s 57 | in "\{ss}{\{dss}}" 58 | interpolate (Media q rs) = "@media (\{q}){\{unlines $ map interpolate rs}}" 59 | -------------------------------------------------------------------------------- /src/Text/CSS/Selector.idr: -------------------------------------------------------------------------------- 1 | module Text.CSS.Selector 2 | 3 | import Data.List 4 | import Data.String 5 | import Text.CSS.Property 6 | import Text.HTML.Tag 7 | 8 | %default total 9 | 10 | public export 11 | data Combinator : Type where 12 | Descendant : Combinator 13 | Child : Combinator 14 | GeneralSibling : Combinator 15 | AdjacentSibling : Combinator 16 | 17 | export 18 | Interpolation Combinator where 19 | interpolate Descendant = "" 20 | interpolate Child = ">" 21 | interpolate GeneralSibling = "~" 22 | interpolate AdjacentSibling = "+" 23 | 24 | public export 25 | data Selector : Type where 26 | Star : Selector 27 | Id : String -> Selector 28 | Class : String -> Selector 29 | Elem : {str : _} -> (0 tag : HTMLTag str) -> Selector 30 | Complex : Selector -> Combinator -> Selector -> Selector 31 | Nil : Selector 32 | (::) : Selector -> Selector -> Selector 33 | 34 | ||| Matches when the user activates (for example clicks on) an element. 35 | Active : Selector 36 | ||| Matches both the :link and :visited states of a link. 37 | AnyLink : Selector 38 | ||| Matches an element whose input value is empty. 39 | Blank : Selector 40 | ||| Matches a radio button or checkbox in the selected state. 41 | Checked : Selector 42 | ||| Matches the element, or an ancestor of the element, that is currently being displayed. 43 | Current : Selector 44 | ||| Matches the one or more UI elements that are the default among a set of similar elements. 45 | Default : Selector 46 | ||| Select an element based on its directionality (value of the HTML dir attribute or CSS direction property). 47 | Dir : Direction -> Selector 48 | ||| Matches user interface elements that are in an disabled state. 49 | Disabled : Selector 50 | ||| Matches an element that has no children except optionally white space. 51 | Empty : Selector 52 | ||| Matches user interface elements that are in an enabled state. 53 | Enabled : Selector 54 | ||| In Paged Media, matches the first page. 55 | First : Selector 56 | ||| Matches an element that is first among its siblings. 57 | FirstChild : Selector 58 | ||| Matches an element which is first of a certain type among its siblings. 59 | FirstOfType : Selector 60 | ||| Matches when an element has focus. 61 | Focus : Selector 62 | ||| Matches when an element has focus and the focus should be visible to the user. 63 | FocusVisible : Selector 64 | ||| Matches an element with focus plus an element with a descendent that has focus. 65 | FocusWithin : Selector 66 | ||| Matches the elements after the current element. 67 | Future : Selector 68 | ||| Matches when the user hovers over an element. 69 | Hover : Selector 70 | ||| Matches UI elements whose value is in an indeterminate state, usually checkboxes. 71 | Indeterminate : Selector 72 | ||| Matches an element with a range when its value is in-range. 73 | InRange : Selector 74 | ||| Matches an element, such as an , in an invalid state. 75 | Invalid : Selector 76 | ||| Matches an element based on language (value of the HTML lang attribute). 77 | Lang : String -> Selector 78 | ||| Matches an element which is last among its siblings. 79 | LastChild : Selector 80 | ||| Matches an element of a certain type that is last among its siblings. 81 | LastOfType : Selector 82 | ||| In Paged Media, matches left-hand pages. 83 | Left : Selector 84 | ||| Matches unvisited links. 85 | Link : Selector 86 | ||| Matches links pointing to pages that are in the same site as the current document. 87 | LocalLink : Selector 88 | |||Matches elements from a list of siblings — the siblings are matched by a formula of the form an+b (e.g. 2n + 1 would match elements 1, 3, 5, 7, etc. All the odd ones.) 89 | NthChild : String -> Selector 90 | |||Matches elements from a list of siblings — the siblings are matched by a formula of the form an+b (e.g. 2n + 1 would match elements 1, 3, 5, 7, etc. All the odd ones.) 91 | NthOfType : String -> Selector 92 | ||| Matches elements from a list of siblings, counting backwards from the end. The siblings are matched by a formula of the form an+b (e.g. 2n + 1 would match the last element in the sequence, then two elements before that, then two elements before that, etc. All the odd ones, counting from the end.) 93 | NthLastChild : String -> Selector 94 | ||| Matches elements from a list of siblings that are of a certain type (e.g.

elements), counting backwards from the end. The siblings are matched by a formula of the form an+b (e.g. 2n + 1 would match the last element of that type in the sequence, then two elements before that, then two elements before that, etc. All the odd ones, counting from the end.) 95 | NthLastOfType : String -> Selector 96 | ||| Matches an element that has no siblings. 97 | OnlyChild : Selector 98 | ||| Matches an element that is the only one of its type among its siblings. 99 | OnlyOfType : Selector 100 | ||| Matches form elements that are not required. 101 | Optional : Selector 102 | ||| Matches an element with a range when its value is out of range. 103 | OutOfRange : Selector 104 | ||| Matches the elements before the current element. 105 | Past : Selector 106 | ||| Matches an input element that is showing placeholder text. 107 | PlaceholderShown : Selector 108 | ||| Matches an element representing an audio, video, or similar resource that is capable of being “played” or “paused”, when that element is “playing”. 109 | Playing : Selector 110 | ||| Matches an element representing an audio, video, or similar resource that is capable of being “played” or “paused”, when that element is “paused”. 111 | Paused : Selector 112 | ||| Matches an element if it is not user-alterable. 113 | ReadOnly : Selector 114 | ||| Matches an element if it is user-alterable. 115 | ReadWrite : Selector 116 | ||| Matches form elements that are required. 117 | Required : Selector 118 | ||| In Paged Media, matches right-hand pages. 119 | Right : Selector 120 | ||| Matches an element that is the root of the document. 121 | Root : Selector 122 | ||| Matches any element that is a scope element. 123 | Scope : Selector 124 | ||| Matches an element such as an element, in a valid state. 125 | Valid : Selector 126 | ||| Matches an element if it is the target of the current URL (i.e. if it has an ID matching the current URL fragment). 127 | Target : Selector 128 | ||| Matches visited links. 129 | Visited : Selector 130 | 131 | After : Selector 132 | Backdrop : Selector 133 | Before : Selector 134 | Cue : Selector 135 | CueRegion : Selector 136 | FirstLetter : Selector 137 | FirstLine : Selector 138 | FileSelectorButton : Selector 139 | Marker : Selector 140 | Placeholder : Selector 141 | Selection : Selector 142 | 143 | 144 | export 145 | Interpolation Selector where 146 | interpolate Star = "*" 147 | interpolate (Id s) = "#\{s}" 148 | interpolate (Class s) = ".\{s}" 149 | interpolate (Elem {str} _) = str 150 | interpolate [] = "" 151 | interpolate (h::t) = interpolate h ++ interpolate t 152 | interpolate (Complex s1 Descendant s2) = "\{s1} \{s2}" 153 | interpolate (Complex s1 c s2) = "\{s1} \{c} \{s2}" 154 | interpolate Active = ":active" 155 | interpolate AnyLink = ":any-link" 156 | interpolate Blank = ":blank" 157 | interpolate Checked = ":checked" 158 | interpolate Current = ":current" 159 | interpolate Default = ":default" 160 | interpolate (Dir x) = ":dir(\{x})" 161 | interpolate Disabled = ":disabled" 162 | interpolate Empty = ":empty" 163 | interpolate Enabled = ":enabled" 164 | interpolate First = ":first" 165 | interpolate FirstChild = ":first-child" 166 | interpolate FirstOfType = ":first-of-type" 167 | interpolate Focus = ":focus" 168 | interpolate FocusVisible = ":focus-visible" 169 | interpolate FocusWithin = ":focus-within" 170 | interpolate Future = ":future" 171 | interpolate Hover = ":hover" 172 | interpolate Indeterminate = ":indeterminate" 173 | interpolate InRange = ":in-range" 174 | interpolate Invalid = ":invalid" 175 | interpolate (Lang x) = ":lang(\{x})" 176 | interpolate LastChild = ":last-child" 177 | interpolate LastOfType = ":last-of-type" 178 | interpolate Left = ":left" 179 | interpolate Link = ":link" 180 | interpolate LocalLink = ":local-link" 181 | interpolate (NthChild x) = ":nth-child(\{x})" 182 | interpolate (NthOfType x) = ":nth-of-type(\#{x})" 183 | interpolate (NthLastChild x) = ":nth-last-child(\#{x})" 184 | interpolate (NthLastOfType x) = ":nth-last-of-type(\#{x})" 185 | interpolate OnlyChild = ":only-child" 186 | interpolate OnlyOfType = ":only-of-type" 187 | interpolate Optional = ":optional" 188 | interpolate OutOfRange = ":out-of-range" 189 | interpolate Past = ":past" 190 | interpolate PlaceholderShown = ":placeholder-shown" 191 | interpolate Playing = ":playing" 192 | interpolate Paused = ":paused" 193 | interpolate ReadOnly = ":read-only" 194 | interpolate ReadWrite = ":read-write" 195 | interpolate Required = ":required" 196 | interpolate Right = ":right" 197 | interpolate Root = ":root" 198 | interpolate Scope = ":scope" 199 | interpolate Valid = ":valid" 200 | interpolate Target = ":target" 201 | interpolate Visited = ":visited" 202 | interpolate After = "::after" 203 | interpolate Backdrop = "::backdrop" 204 | interpolate Before = "::before" 205 | interpolate Cue = "::cue" 206 | interpolate CueRegion = "::cue-region" 207 | interpolate FirstLetter = "::first-letter" 208 | interpolate FirstLine = "::first-line" 209 | interpolate FileSelectorButton = "::file-selector-button" 210 | interpolate Marker = "::marker" 211 | interpolate Placeholder = "::placeholder" 212 | interpolate Selection = "::selection" 213 | 214 | export %inline 215 | class : String -> Selector 216 | class = Class 217 | 218 | export 219 | classes : List String -> Selector 220 | classes [] = [] 221 | classes (x :: xs) = class x :: classes xs 222 | 223 | export %inline 224 | elem : {str : _} -> (0 tpe : HTMLTag str) -> Selector 225 | elem = Elem 226 | 227 | export %inline 228 | id : String -> Selector 229 | id = Id 230 | -------------------------------------------------------------------------------- /src/Text/HTML.idr: -------------------------------------------------------------------------------- 1 | module Text.HTML 2 | 3 | import public Text.HTML.Attribute 4 | import public Text.HTML.Event 5 | import public Text.HTML.Node 6 | import public Text.HTML.Ref 7 | import public Text.HTML.Tag 8 | -------------------------------------------------------------------------------- /src/Text/HTML/Event.idr: -------------------------------------------------------------------------------- 1 | module Text.HTML.Event 2 | 3 | import Data.Contravariant 4 | import Data.Maybe 5 | import Web.Internal.FileTypes 6 | 7 | %default total 8 | 9 | -------------------------------------------------------------------------------- 10 | -- Event Info Types 11 | -------------------------------------------------------------------------------- 12 | 13 | public export 14 | record WheelInfo where 15 | constructor MkWheelInfo 16 | deltaMode : Bits32 17 | deltaX : Double 18 | deltaY : Double 19 | deltaZ : Double 20 | 21 | public export 22 | record MouseInfo where 23 | constructor MkMouseInfo 24 | -- buttons 25 | button : Int16 26 | buttons : Bits16 27 | 28 | -- coordinates 29 | clientX : Double 30 | clientY : Double 31 | offsetX : Double 32 | offsetY : Double 33 | pageX : Double 34 | pageY : Double 35 | screenX : Double 36 | screenY : Double 37 | 38 | -- keys 39 | alt : Bool 40 | ctrl : Bool 41 | meta : Bool 42 | shift : Bool 43 | 44 | public export 45 | record InputInfo where 46 | constructor MkInputInfo 47 | value : String 48 | files : List File 49 | checked : Bool 50 | 51 | public export 52 | record KeyInfo where 53 | constructor MkKeyInfo 54 | key : String 55 | code : String 56 | location : Bits32 57 | isComposing : Bool 58 | 59 | -- control keys 60 | alt : Bool 61 | ctrl : Bool 62 | meta : Bool 63 | shift : Bool 64 | 65 | public export 66 | record ScrollInfo where 67 | constructor MkScrollInfo 68 | scrollTop : Double 69 | scrollHeight : Int32 70 | clientHeight : Int32 71 | 72 | public export 73 | record Rect where 74 | constructor MkRect 75 | rectX : Double 76 | rectY : Double 77 | height : Double 78 | width : Double 79 | top : Double 80 | bottom : Double 81 | left : Double 82 | right : Double 83 | 84 | -------------------------------------------------------------------------------- 85 | -- Events 86 | -------------------------------------------------------------------------------- 87 | 88 | public export 89 | data DOMEvent : Type -> Type where 90 | -- Mouse clicks 91 | Click : (MouseInfo -> Maybe a) -> DOMEvent a 92 | DblClick : (MouseInfo -> Maybe a) -> DOMEvent a 93 | MouseDown : (MouseInfo -> Maybe a) -> DOMEvent a 94 | MouseUp : (MouseInfo -> Maybe a) -> DOMEvent a 95 | 96 | -- Mouse movement 97 | MouseEnter : (MouseInfo -> Maybe a) -> DOMEvent a 98 | MouseLeave : (MouseInfo -> Maybe a) -> DOMEvent a 99 | MouseOver : (MouseInfo -> Maybe a) -> DOMEvent a 100 | MouseOut : (MouseInfo -> Maybe a) -> DOMEvent a 101 | MouseMove : (MouseInfo -> Maybe a) -> DOMEvent a 102 | 103 | -- Focus 104 | Blur : a -> DOMEvent a 105 | Focus : a -> DOMEvent a 106 | 107 | -- Keyboard 108 | KeyDown : (KeyInfo -> Maybe a) -> DOMEvent a 109 | KeyUp : (KeyInfo -> Maybe a) -> DOMEvent a 110 | 111 | -- Input 112 | Change : (InputInfo -> Maybe a) -> DOMEvent a 113 | Input : (InputInfo -> Maybe a) -> DOMEvent a 114 | 115 | -- Routing 116 | HashChange : a -> DOMEvent a 117 | 118 | -- Scrolling 119 | Scroll : (ScrollInfo -> Maybe a) -> DOMEvent a 120 | 121 | -- Wheel 122 | Wheel : (WheelInfo -> Maybe a) -> DOMEvent a 123 | 124 | -- Resize Events 125 | Resize : (Rect -> Maybe a) -> DOMEvent a 126 | 127 | export 128 | Functor DOMEvent where 129 | map f (Click g) = Click (map f . g) 130 | map f (DblClick g) = DblClick (map f . g) 131 | map f (MouseDown g) = MouseDown (map f . g) 132 | map f (MouseUp g) = MouseUp (map f . g) 133 | map f (MouseEnter g) = MouseEnter (map f . g) 134 | map f (MouseLeave g) = MouseLeave (map f . g) 135 | map f (MouseOver g) = MouseOver (map f . g) 136 | map f (MouseOut g) = MouseOut (map f . g) 137 | map f (MouseMove g) = MouseMove (map f . g) 138 | map f (Blur x) = Blur (f x) 139 | map f (Focus x) = Focus (f x) 140 | map f (KeyDown g) = KeyDown (map f . g) 141 | map f (KeyUp g) = KeyUp (map f . g) 142 | map f (Change g) = Change (map f . g) 143 | map f (Input g) = Input (map f . g) 144 | map f (HashChange x) = HashChange (f x) 145 | map f (Scroll g) = Scroll (map f . g) 146 | map f (Wheel g) = Wheel (map f . g) 147 | map f (Resize g) = Resize (map f . g) 148 | -------------------------------------------------------------------------------- /src/Text/HTML/Ref.idr: -------------------------------------------------------------------------------- 1 | module Text.HTML.Ref 2 | 3 | import Text.HTML.Tag 4 | 5 | %default total 6 | 7 | ||| A typed reference to an element or container in the DOM. Elements can 8 | ||| 9 | ||| This can be used as a type-safe ID when constructing 10 | ||| HTML nodes and their attribute lists. 11 | ||| In addition, we provide (pseudo-)element references for 12 | ||| `body`, `document`, and `window`. 13 | public export 14 | data Ref : {0 k : Type} -> (t : k) -> Type where 15 | Id : {tag : String} 16 | -> {0 tpe : HTMLTag tag} 17 | -> (id : String) 18 | -> Ref tpe 19 | 20 | Elem : String -> Ref Void 21 | 22 | Body : Ref Void 23 | 24 | Document : Ref Void 25 | 26 | Window : Ref Void 27 | -------------------------------------------------------------------------------- /src/Text/HTML/Select.idr: -------------------------------------------------------------------------------- 1 | ||| Utilities for working with `` element displaying the options in the given 63 | ||| list. 64 | ||| 65 | ||| @values : the list of options 66 | ||| @sel : true if the given item in the list should be selected 67 | ||| @display : how to display an option at the UI 68 | ||| @toEvent : how to convert an option to an event 69 | ||| @attrs : additional attributes 70 | export 71 | selectFromListBy : 72 | (values : List t) 73 | -> (sel : t -> Bool) 74 | -> (display : t -> String) 75 | -> (toEvent : t -> e) 76 | -> (attrs : List (Attribute Select e)) 77 | -> Node e 78 | selectFromListBy vs sel f = selectEntries ((\x => Entry x $ f x) <$> vs) sel 79 | 80 | ||| Like `selectFromListBy` but uses an optional initial value 81 | ||| to determine the initially selected value. 82 | ||| 83 | ||| @values : the list of options 84 | ||| @init : the initially selected option (if any) 85 | ||| @display : how to display an option at the UI 86 | ||| @toEvent : how to convert an option to an event 87 | ||| @attrs : additional attributes 88 | export 89 | selectFromList : 90 | {auto eq : Eq t} 91 | -> (values : List t) 92 | -> (init : Maybe t) 93 | -> (display : t -> String) 94 | -> (toEvent : t -> e) 95 | -> (attrs : List (Attribute Select e)) 96 | -> Node e 97 | selectFromList vs i = selectFromListBy vs ((i ==) . Just) 98 | -------------------------------------------------------------------------------- /src/Text/HTML/Tag.idr: -------------------------------------------------------------------------------- 1 | module Text.HTML.Tag 2 | 3 | %default total 4 | 5 | ||| HTML Element Tags linking tag names with an enumeration. 6 | ||| 7 | ||| Some deprecated tags have been left out, some others might 8 | ||| still be missing. 9 | public export 10 | data HTMLTag : (tag : String) -> Type where 11 | A : HTMLTag "a" 12 | Address : HTMLTag "address" 13 | Area : HTMLTag "area" 14 | Article : HTMLTag "article" 15 | Aside : HTMLTag "aside" 16 | Audio : HTMLTag "audio" 17 | Base : HTMLTag "base" 18 | Blockquote : HTMLTag "blockquote" 19 | Body : HTMLTag "body" 20 | Br : HTMLTag "br" 21 | Button : HTMLTag "button" 22 | Canvas : HTMLTag "canvas" 23 | Caption : HTMLTag "caption" 24 | Col : HTMLTag "col" 25 | Colgroup : HTMLTag "colgroup" 26 | Data : HTMLTag "data" 27 | Datalist : HTMLTag "datalist" 28 | Del : HTMLTag "del" 29 | Details : HTMLTag "details" 30 | Dialog : HTMLTag "dialog" 31 | Div : HTMLTag "div" 32 | Dl : HTMLTag "dl" 33 | Embed : HTMLTag "embed" 34 | FieldSet : HTMLTag "fieldset" 35 | Footer : HTMLTag "footer" 36 | Form : HTMLTag "form" 37 | H1 : HTMLTag "h1" 38 | H2 : HTMLTag "h2" 39 | H3 : HTMLTag "h3" 40 | H4 : HTMLTag "h4" 41 | H5 : HTMLTag "h5" 42 | H6 : HTMLTag "h6" 43 | HR : HTMLTag "hr" 44 | Header : HTMLTag "header" 45 | Html : HTMLTag "html" 46 | IFrame : HTMLTag "iframe" 47 | Img : HTMLTag "img" 48 | Input : HTMLTag "input" 49 | Ins : HTMLTag "ins" 50 | Label : HTMLTag "label" 51 | Legend : HTMLTag "legend" 52 | Li : HTMLTag "li" 53 | Link : HTMLTag "link" 54 | Map : HTMLTag "map" 55 | Menu : HTMLTag "menu" 56 | Meta : HTMLTag "meta" 57 | Meter : HTMLTag "meter" 58 | Object : HTMLTag "object" 59 | Ol : HTMLTag "ol" 60 | OptGroup : HTMLTag "optgroup" 61 | Option : HTMLTag "option" 62 | Output : HTMLTag "output" 63 | P : HTMLTag "p" 64 | Param : HTMLTag "param" 65 | Picture : HTMLTag "picture" 66 | Pre : HTMLTag "pre" 67 | Progress : HTMLTag "progress" 68 | Q : HTMLTag "q" 69 | Script : HTMLTag "script" 70 | Section : HTMLTag "section" 71 | Select : HTMLTag "select" 72 | Slot : HTMLTag "slot" 73 | Source : HTMLTag "source" 74 | Span : HTMLTag "span" 75 | Style : HTMLTag "style" 76 | Svg : HTMLTag "svg" 77 | Table : HTMLTag "table" 78 | Tbody : HTMLTag "tbody" 79 | Td : HTMLTag "td" 80 | Template : HTMLTag "template" 81 | TextArea : HTMLTag "textarea" 82 | Tfoot : HTMLTag "tfoot" 83 | Th : HTMLTag "th" 84 | Thead : HTMLTag "thead" 85 | Time : HTMLTag "time" 86 | Title : HTMLTag "title" 87 | Tr : HTMLTag "tr" 88 | Track : HTMLTag "track" 89 | Ul : HTMLTag "ul" 90 | Video : HTMLTag "video" 91 | 92 | ||| Proof that we can set a custom validity message to 93 | ||| a HTML object with this tag. 94 | public export 95 | data ValidityTag : (t : HTMLTag s) -> Type where 96 | SVButton : ValidityTag Button 97 | SVFieldSet : ValidityTag FieldSet 98 | SVInput : ValidityTag Input 99 | SVObject : ValidityTag Object 100 | SVOutput : ValidityTag Output 101 | SVSelect : ValidityTag Select 102 | SVTextArea : ValidityTag TextArea 103 | 104 | ||| Proof that we can set a string value to 105 | ||| a HTML object with this tag. 106 | public export 107 | data ValueTag : (t : HTMLTag s) -> Type where 108 | VButton : ValueTag Button 109 | VData : ValueTag Data 110 | VInput : ValueTag Input 111 | VOption : ValueTag Option 112 | VOutput : ValueTag Output 113 | VParam : ValueTag Param 114 | VSelect : ValueTag Select 115 | VTextArea : ValueTag TextArea 116 | -------------------------------------------------------------------------------- /src/Web/MVC.idr: -------------------------------------------------------------------------------- 1 | module Web.MVC 2 | 3 | import Data.IORef 4 | import Data.Queue 5 | 6 | import public JS 7 | import public Web.MVC.Cmd 8 | import public Web.MVC.View 9 | import public Text.HTML 10 | 11 | ||| Run (a part of) an interactive web page firing events of type 12 | ||| `e` and holding state of type `s`. 13 | export covering 14 | runController : 15 | {0 e,s : Type} 16 | -> (ctrl : e -> s -> (s, Cmd e)) 17 | -> (onErr : JSErr -> IO ()) 18 | -> (initEv : e) 19 | -> (initST : s) 20 | -> IO () 21 | runController ctrl onErr initEv initST = Prelude.do 22 | state <- newIORef initST 23 | flag <- newIORef False 24 | queue <- newIORef $ Queue.empty {a = e} 25 | 26 | let covering handle : e -> IO () 27 | handle ev = Prelude.do 28 | 29 | -- Enqueue synchronously fired events if we are already handling 30 | -- an event 31 | False <- readIORef flag | True => modifyIORef queue (`enqueue` ev) 32 | 33 | -- Start handing the event and prevent others from currently 34 | -- being handled 35 | writeIORef flag True 36 | 37 | -- read current application state 38 | stOld <- readIORef state 39 | 40 | -- compute new application state and the command to run 41 | let (stNew, cmd) := ctrl ev stOld 42 | 43 | -- update application state 44 | writeIORef state stNew 45 | 46 | -- run the command by invoking it with this very event handler 47 | -- the command might fire one or more events synchronously. these 48 | -- will be enqueued and processed in a moment. 49 | ei <- runEitherT (run cmd (liftIO . handle)) 50 | 51 | case ei of 52 | Left err => onErr err 53 | Right () => pure () 54 | 55 | -- we are do with handling the current event so we set the flag 56 | -- back to false. 57 | writeIORef flag False 58 | 59 | -- we are now going to process the next enqueued command (if any) 60 | Just (ev2,q) <- dequeue <$> readIORef queue | Nothing => pure () 61 | writeIORef queue q 62 | handle ev2 63 | 64 | handle initEv 65 | 66 | export covering 67 | runMVC : 68 | {0 e,s : Type} 69 | -> (update : e -> s -> s) 70 | -> (display : e -> s -> Cmd e) 71 | -> (onErr : JSErr -> IO ()) 72 | -> (initEv : e) 73 | -> (initST : s) 74 | -> IO () 75 | runMVC upd disp onErr = 76 | runController (\ev,st => let st2 := upd ev st in (st2, disp ev st2)) onErr 77 | -------------------------------------------------------------------------------- /src/Web/MVC/Animate.idr: -------------------------------------------------------------------------------- 1 | ||| Utilities not (yet) available from idris2-dom 2 | module Web.MVC.Animate 3 | 4 | import Data.IORef 5 | import JS 6 | import Web.MVC.Cmd 7 | 8 | -------------------------------------------------------------------------------- 9 | -- Time 10 | -------------------------------------------------------------------------------- 11 | 12 | %foreign "javascript:lambda:(w) => BigInt(new Date().getTime())" 13 | prim__time : PrimIO Integer 14 | 15 | ||| Get the current time in milliseconds since 1970/01/01. 16 | export 17 | currentTime : HasIO io => io Integer 18 | currentTime = primIO prim__time 19 | 20 | ||| Determine the time taken to setup a command and wrap it in an 21 | ||| event that will be fired synchronously. 22 | export 23 | timed : (Integer -> e) -> Cmd e -> Cmd e 24 | timed toEv (C f) = C $ \h => do 25 | t1 <- currentTime 26 | f h 27 | t2 <- currentTime 28 | h (toEv $ t2 - t1) 29 | 30 | -------------------------------------------------------------------------------- 31 | -- Timers 32 | -------------------------------------------------------------------------------- 33 | 34 | ||| ID used to identify and cancel a running timer. 35 | public export 36 | data IntervalID : Type where [external] 37 | 38 | %foreign "browser:lambda:(n,h,w)=>setInterval(() => h(w),n)" 39 | prim__setInterval : Bits32 -> IO () -> PrimIO IntervalID 40 | 41 | %foreign "browser:lambda:(i,w)=>clearInterval(i)" 42 | prim__clearInterval : IntervalID -> PrimIO () 43 | 44 | ||| Fires the given event every `n` milliseconds. 45 | ||| 46 | ||| Note: Use `animate` for smoothly running animations. 47 | export 48 | every : e -> (n : Bits32) -> Cmd e 49 | every ev millis = 50 | C $ \h => ignore $ primIO (prim__setInterval millis (runJS $ h ev)) 51 | 52 | ||| Fires the given event every `n` milliseconds. 53 | ||| 54 | ||| In addition, this synchronously fires an event with a wrapped 55 | ||| handle for stopping the timer. 56 | export 57 | everyWithCleanup : (IO () -> e) -> e -> Bits32 -> Cmd e 58 | everyWithCleanup cleanUpToEv ev millis = 59 | C $ \h => Prelude.do 60 | id <- primIO (prim__setInterval millis (runJS $ h ev)) 61 | h (cleanUpToEv $ primIO (prim__clearInterval id)) 62 | 63 | -------------------------------------------------------------------------------- 64 | -- Animations 65 | -------------------------------------------------------------------------------- 66 | 67 | %foreign """ 68 | browser:lambda:(stop,h,w)=>{ 69 | let previousTimeStamp; 70 | 71 | function step(timestamp) { 72 | if (previousTimeStamp === undefined) 73 | previousTimeStamp = timestamp; 74 | const dtime = timestamp - previousTimeStamp; 75 | previousTimeStamp = timestamp; 76 | if (stop(w) === 0) { 77 | h(dtime)(w) 78 | window.requestAnimationFrame(step); 79 | } 80 | } 81 | 82 | window.requestAnimationFrame(step); 83 | } 84 | """ 85 | prim__animate : IO Bits32 -> (Bits32 -> IO ()) -> PrimIO () 86 | 87 | ||| Alias for a time delta in milliseconds 88 | public export 89 | DTime : Type 90 | DTime = Bits32 91 | 92 | ||| Repeatedly fires the given event holding the time delta in 93 | ||| milliseconds since the last animation step. 94 | export 95 | animate : (DTime -> e) -> Cmd e 96 | animate toEv = C $ \h => Prelude.do 97 | primIO $ prim__animate (pure 0) (runJS . h . toEv) 98 | 99 | ||| Repeatedly fires the given event holding the time delta in 100 | ||| milliseconds since the last animation step. 101 | ||| 102 | ||| In addition, synchronously fires an event with a wrapped 103 | ||| handle for stopping the animation. 104 | export 105 | animateWithCleanup : (IO () -> e) -> (DTime -> e) -> Cmd e 106 | animateWithCleanup cleanupToEv toEv = C $ \h => Prelude.do 107 | ref <- newIORef (the Bits32 0) 108 | primIO $ prim__animate (readIORef ref) (runJS . h . toEv) 109 | h $ cleanupToEv (writeIORef ref 1) 110 | -------------------------------------------------------------------------------- /src/Web/MVC/Canvas.idr: -------------------------------------------------------------------------------- 1 | module Web.MVC.Canvas 2 | 3 | import Derive.Prelude 4 | import JS 5 | import Text.HTML.Ref 6 | import Text.HTML.Tag 7 | import Web.Html 8 | import Web.MVC.Util 9 | 10 | import public Web.MVC.Canvas.Angle 11 | import public Web.MVC.Canvas.Scene 12 | import public Web.MVC.Canvas.Shape 13 | import public Web.MVC.Canvas.Style 14 | import public Web.MVC.Canvas.Transformation 15 | 16 | %default total 17 | %language ElabReflection 18 | 19 | ||| Canvas dimensions 20 | public export 21 | record CanvasDims where 22 | [noHints] 23 | constructor CD 24 | cwidth : Double 25 | cheight : Double 26 | 27 | %runElab derive "CanvasDims" [Show,Eq] 28 | 29 | export 30 | canvasDims : Ref Canvas -> JSIO CanvasDims 31 | canvasDims r = do 32 | canvas <- castElementByRef {t = HTMLCanvasElement} r 33 | w <- cast <$> get canvas width 34 | h <- cast <$> get canvas height 35 | pure $ CD w h 36 | 37 | export 38 | setCanvasDims : Ref Canvas -> CanvasDims -> JSIO () 39 | setCanvasDims r (CD w h) = do 40 | canvas <- castElementByRef {t = HTMLCanvasElement} r 41 | set (width canvas) (cast w) 42 | set (height canvas) (cast h) 43 | 44 | export 45 | context2D : HTMLCanvasElement -> JSIO CanvasRenderingContext2D 46 | context2D canvas = do 47 | m <- getContext canvas "2d" 48 | case m >>= project CanvasRenderingContext2D of 49 | Just c => pure c 50 | Nothing => throwError $ Caught "Web.MVC.Canvas.context2d: No rendering context for canvas" 51 | 52 | ||| Render a scene in a canvas in the DOM. 53 | export 54 | renderWithMetrics : Ref Canvas -> (TextMeasure => CanvasDims -> Scene) -> JSIO () 55 | renderWithMetrics ref scene = do 56 | canvas <- castElementByRef {t = HTMLCanvasElement} ref 57 | ctxt <- context2D canvas 58 | w <- cast <$> get canvas width 59 | h <- cast <$> get canvas height 60 | apply ctxt $ Rect 0 0 w h Clear 61 | applyWithMetrics ctxt (scene (CD w h)) 62 | 63 | ||| Render a scene in a canvas in the DOM. 64 | export %inline 65 | render : Ref Canvas -> (CanvasDims -> Scene) -> JSIO () 66 | render ref scene = renderWithMetrics ref scene 67 | -------------------------------------------------------------------------------- /src/Web/MVC/Canvas/Angle.idr: -------------------------------------------------------------------------------- 1 | module Web.MVC.Canvas.Angle 2 | 3 | %default total 4 | 5 | -------------------------------------------------------------------------------- 6 | -- Angle 7 | -------------------------------------------------------------------------------- 8 | 9 | public export 10 | data Angle : Type where 11 | Radians : Double -> Angle 12 | Degree : Double -> Angle 13 | 14 | export %inline 15 | rad : Double -> Angle 16 | rad = Radians 17 | 18 | export %inline 19 | deg : Double -> Angle 20 | deg = Degree 21 | 22 | export 23 | toRadians : Angle -> Double 24 | toRadians (Radians x) = x 25 | toRadians (Degree x) = (x / 180) * pi 26 | 27 | export 28 | toDegree : Angle -> Double 29 | toDegree (Radians x) = (x / pi) * 180 30 | toDegree (Degree x) = x 31 | 32 | export 33 | Show Angle where 34 | show = show . toDegree 35 | -------------------------------------------------------------------------------- /src/Web/MVC/Canvas/Scene.idr: -------------------------------------------------------------------------------- 1 | module Web.MVC.Canvas.Scene 2 | 3 | import Control.Monad.Either.Extra 4 | import JS 5 | import Web.MVC.Canvas.Shape 6 | import Web.MVC.Canvas.Style 7 | import Web.MVC.Canvas.Transformation 8 | import Web.Html 9 | 10 | %default total 11 | 12 | -------------------------------------------------------------------------------- 13 | -- Text Metrics 14 | -------------------------------------------------------------------------------- 15 | 16 | %foreign "browser:lambda:(x,a)=>x.measureText(a)" 17 | prim__measure : CanvasRenderingContext2D -> String -> PrimIO TextMetrics 18 | 19 | export 20 | %foreign "browser:lambda:x=>x.actualBoundingBoxAscent" 21 | actualBoundingBoxAscent : TextMetrics -> Double 22 | 23 | export 24 | %foreign "browser:lambda:x=>x.actualBoundingBoxDescent" 25 | actualBoundingBoxDescent : TextMetrics -> Double 26 | 27 | export 28 | %foreign "browser:lambda:x=>x.actualBoundingBoxLeft" 29 | actualBoundingBoxLeft : TextMetrics -> Double 30 | 31 | export 32 | %foreign "browser:lambda:x=>x.actualBoundingBoxRight" 33 | actualBoundingBoxRight : TextMetrics -> Double 34 | 35 | export 36 | %foreign "browser:lambda:x=>x.alphabeticBaseline" 37 | alphabeticBaseline : TextMetrics -> Double 38 | 39 | export 40 | %foreign "browser:lambda:x=>x.emHeightAscent" 41 | emHeightAscent : TextMetrics -> Double 42 | 43 | export 44 | %foreign "browser:lambda:x=>x.emHeightDescent" 45 | emHeightDescent : TextMetrics -> Double 46 | 47 | export 48 | %foreign "browser:lambda:x=>x.fontBoundingBoxAscent" 49 | fontBoundingBoxAscent : TextMetrics -> Double 50 | 51 | export 52 | %foreign "browser:lambda:x=>x.fontBoundingBoxDescent" 53 | fontBoundingBoxDescent : TextMetrics -> Double 54 | 55 | export 56 | %foreign "browser:lambda:x=>x.hangingBaseline" 57 | hangingBaseline : TextMetrics -> Double 58 | 59 | export 60 | %foreign "browser:lambda:x=>x.ideographicBaseline" 61 | ideographicBaseline : TextMetrics -> Double 62 | 63 | export 64 | %foreign "browser:lambda:x=>x.width" 65 | width : TextMetrics -> Double 66 | 67 | %foreign "browser:lambda:(c,d,a,b,f,s)=>{d0 = c.direction; b0 = c.textBaseline; a0 = c.textAlign; f0 = c.font; c.font = f; c.direction = d; c.textBaseline = b; c.textAlign = a; res = c.measureText(s); c.font = f0; c.direction = d0; c.textBaseline = b0; c.textAlign = a0; return res}" 68 | prim__measureText : 69 | CanvasRenderingContext2D 70 | -> (dir, align, baseline, font, text : String) 71 | -> TextMetrics 72 | 73 | -------------------------------------------------------------------------------- 74 | -- Scene 75 | -------------------------------------------------------------------------------- 76 | 77 | public export 78 | data Scene : Type where 79 | S1 : (fs : List Style) -> (tr : Transformation) -> (shape : Shape) -> Scene 80 | SM : (fs : List Style) -> (tr : Transformation) -> List Scene -> Scene 81 | 82 | -------------------------------------------------------------------------------- 83 | -- IO 84 | -------------------------------------------------------------------------------- 85 | 86 | export 87 | applyAll : CanvasRenderingContext2D -> List Scene -> JSIO () 88 | 89 | export 90 | apply : CanvasRenderingContext2D -> Scene -> JSIO () 91 | 92 | applyAll ctxt = assert_total $ traverseList_ (apply ctxt) 93 | 94 | apply ctxt (S1 fs tr shape) = do 95 | save ctxt 96 | traverseList_ (apply ctxt) fs 97 | apply ctxt tr 98 | apply ctxt shape 99 | restore ctxt 100 | 101 | apply ctxt (SM fs tr xs) = do 102 | save ctxt 103 | traverseList_ (apply ctxt) fs 104 | apply ctxt tr 105 | applyAll ctxt xs 106 | restore ctxt 107 | 108 | ||| Utility for computing `TextMetrics`. 109 | export 110 | record TextMeasure where 111 | [noHints] 112 | constructor TM 113 | measure_ : (dir, align, bl, font, text : String) -> TextMetrics 114 | 115 | ||| Compute the `TextMetrics` for the given text in the given font. 116 | export %inline 117 | measureText : 118 | {auto m : TextMeasure} 119 | -> CanvasDirection 120 | -> CanvasTextAlign 121 | -> CanvasTextBaseline 122 | -> (font,text : String) 123 | -> TextMetrics 124 | measureText d a b f t = m.measure_ (show d) (show a) (show b) f t 125 | 126 | ||| Supplies the given function with a `TextMeasure` implicit, derived 127 | ||| from the given rendering context. 128 | export %inline 129 | withMetrics : CanvasRenderingContext2D -> (TextMeasure => a) -> a 130 | withMetrics cd f = f @{TM $ prim__measureText cd} 131 | 132 | ||| Alternative version of `apply` for those cases where we need to 133 | ||| work with text metrics. 134 | export 135 | applyWithMetrics : CanvasRenderingContext2D -> (TextMeasure => Scene) -> JSIO () 136 | applyWithMetrics cd f = withMetrics cd $ apply cd f 137 | -------------------------------------------------------------------------------- /src/Web/MVC/Canvas/Shape.idr: -------------------------------------------------------------------------------- 1 | module Web.MVC.Canvas.Shape 2 | 3 | import Control.Monad.Either.Extra 4 | import JS 5 | import Web.Html 6 | import Web.MVC.Canvas.Angle 7 | 8 | %default total 9 | 10 | -------------------------------------------------------------------------------- 11 | -- Types 12 | -------------------------------------------------------------------------------- 13 | 14 | namespace PathType 15 | public export 16 | data PathType = Fill | Stroke 17 | 18 | public export 19 | data Segment : Type where 20 | Move : (x,y : Double) -> Segment 21 | Line : (x,y : Double) -> Segment 22 | Arc : (x,y,radius : Double) 23 | -> (start,stop : Angle) 24 | -> (counterclockwise : Bool) 25 | -> Segment 26 | ArcTo : (x1,y1,x2,y2,radius : Double) -> Segment 27 | 28 | namespace RectType 29 | public export 30 | data RectType = Fill | Stroke | Clear 31 | 32 | public export 33 | data Shape : Type where 34 | Rect : (x,y,w,h : Double) -> RectType -> Shape 35 | Path : List Segment -> PathType -> Shape 36 | Shapes : List Shape -> Shape 37 | Text : String -> (x,y : Double) -> Optional Double -> Shape 38 | Text' : String -> (x,y : Double) -> Shape 39 | 40 | export 41 | circle : (x,y,radius : Double) -> PathType -> Shape 42 | circle x y r = Path [Arc x y r (rad 0) (rad $ 2 * pi) False] 43 | 44 | export 45 | polyLine : List (Double,Double) -> Shape 46 | polyLine [] = Path [] Stroke 47 | polyLine ((x,y) :: t) = Path (Move x y :: map (uncurry Line) t) Stroke 48 | 49 | export 50 | Semigroup Shape where 51 | x <+> Shapes [] = x 52 | Shapes [] <+> y = y 53 | Shapes xs <+> Shapes ys = Shapes $ xs ++ ys 54 | x <+> Shapes ys = Shapes $ x :: ys 55 | x <+> y = Shapes [x,y] 56 | 57 | export 58 | Monoid Shape where 59 | neutral = Shapes [] 60 | 61 | -------------------------------------------------------------------------------- 62 | -- IO 63 | -------------------------------------------------------------------------------- 64 | 65 | applySegment : CanvasRenderingContext2D -> Segment -> JSIO () 66 | applySegment ctxt (Move x y) = moveTo ctxt x y 67 | applySegment ctxt (Line x y) = lineTo ctxt x y 68 | applySegment ctxt (Arc x y r start stop ccw) = do 69 | arc' ctxt x y r (toRadians start) (toRadians stop) (Def ccw) 70 | applySegment ctxt (ArcTo x1 y1 x2 y2 radius) = 71 | arcTo ctxt x1 y1 x2 y2 radius 72 | 73 | export 74 | applyAll : CanvasRenderingContext2D -> List Shape -> JSIO () 75 | 76 | export 77 | apply : CanvasRenderingContext2D -> Shape -> JSIO () 78 | 79 | applyAll ctxt = assert_total $ traverseList_ (apply ctxt) 80 | 81 | apply ctxt (Rect x y w h Fill) = fillRect ctxt x y w h 82 | apply ctxt (Rect x y w h Stroke) = strokeRect ctxt x y w h 83 | apply ctxt (Rect x y w h Clear) = clearRect ctxt x y w h 84 | apply ctxt (Path ss st) = do 85 | beginPath ctxt 86 | traverseList_ (applySegment ctxt) ss 87 | case st of 88 | Fill => fill ctxt 89 | Stroke => stroke ctxt 90 | apply ctxt (Text str x y max) = fillText' ctxt str x y max 91 | apply ctxt (Text' str x y) = fillText ctxt str x y 92 | apply ctxt (Shapes xs) = applyAll ctxt xs 93 | -------------------------------------------------------------------------------- /src/Web/MVC/Canvas/Style.idr: -------------------------------------------------------------------------------- 1 | module Web.MVC.Canvas.Style 2 | 3 | import JS 4 | import Text.CSS.Color 5 | import Web.Html 6 | 7 | %default total 8 | 9 | public export 10 | data Style : Type where 11 | Fill : Color -> Style 12 | Stroke : Color -> Style 13 | LineWidth : Double -> Style 14 | SetLineDash : List Double -> Style 15 | LineDashOffset : Double -> Style 16 | Font : String -> Style 17 | Direction : CanvasDirection -> Style 18 | TextAlign : CanvasTextAlign -> Style 19 | TextBaseline : CanvasTextBaseline -> Style 20 | 21 | -------------------------------------------------------------------------------- 22 | -- IO 23 | -------------------------------------------------------------------------------- 24 | 25 | export 26 | apply : CanvasRenderingContext2D -> Style -> JSIO () 27 | apply ctxt (Fill c) = fillStyle ctxt .= inject (interpolate c) 28 | apply ctxt (Stroke c) = strokeStyle ctxt .= inject (interpolate c) 29 | apply ctxt (LineWidth v) = lineWidth ctxt .= v 30 | apply ctxt (SetLineDash vs) = fromListIO vs >>= setLineDash ctxt 31 | apply ctxt (LineDashOffset v) = lineDashOffset ctxt .= v 32 | apply ctxt (Font v) = font ctxt .= v 33 | apply ctxt (Direction v) = direction ctxt .= v 34 | apply ctxt (TextAlign v) = textAlign ctxt .= v 35 | apply ctxt (TextBaseline v) = textBaseline ctxt .= v 36 | -------------------------------------------------------------------------------- /src/Web/MVC/Canvas/Transformation.idr: -------------------------------------------------------------------------------- 1 | module Web.MVC.Canvas.Transformation 2 | 3 | import JS 4 | import Web.Html 5 | import Web.MVC.Canvas.Angle 6 | 7 | -------------------------------------------------------------------------------- 8 | -- Transformation 9 | -------------------------------------------------------------------------------- 10 | 11 | public export 12 | data Transformation : Type where 13 | Id : Transformation 14 | Transform : (a,b,c,d,e,f : Double) -> Transformation 15 | 16 | export 17 | scale : (h,w : Double) -> Transformation 18 | scale h w = Transform h 0 0 w 0 0 19 | 20 | export 21 | rotate : Angle -> Transformation 22 | rotate phi = 23 | let r := toRadians phi 24 | c := cos r 25 | s := sin r 26 | in Transform c s (-s) c 0 0 27 | 28 | export 29 | translate : (dx,dy : Double) -> Transformation 30 | translate dx dy = Transform 0 0 0 0 dx dy 31 | 32 | export 33 | mult : Transformation -> Transformation -> Transformation 34 | mult Id x = x 35 | mult x Id = x 36 | mult (Transform a1 b1 c1 d1 e1 f1) (Transform a2 b2 c2 d2 e2 f2) = 37 | Transform 38 | (a1 * a2 + c1 * b2) 39 | (b1 * a2 + d1 * b2) 40 | (a1 * c2 + c1 * d2) 41 | (b1 * c2 + d1 * d2) 42 | (a1 * e2 + c1 * f2 + e1) 43 | (b1 * e2 + d1 * f2 + f1) 44 | 45 | export %inline 46 | Semigroup Transformation where 47 | (<+>) = mult 48 | 49 | export %inline 50 | Monoid Transformation where 51 | neutral = Id 52 | 53 | -------------------------------------------------------------------------------- 54 | -- IO 55 | -------------------------------------------------------------------------------- 56 | 57 | export 58 | apply : CanvasRenderingContext2D -> Transformation -> JSIO () 59 | apply ctxt Id = pure () 60 | apply ctxt (Transform a b c d e f) = setTransform ctxt a b c d e f 61 | -------------------------------------------------------------------------------- /src/Web/MVC/Cmd.idr: -------------------------------------------------------------------------------- 1 | module Web.MVC.Cmd 2 | 3 | import Control.Monad.Either.Extra 4 | import JS 5 | 6 | %default total 7 | 8 | -------------------------------------------------------------------------------- 9 | -- Commands 10 | -------------------------------------------------------------------------------- 11 | 12 | ||| A `Cmd` (abbreviation of "command") is a (typically effectful) computation 13 | ||| which might send an arbitrary number of events of type `e` to an event 14 | ||| handler synchronously or asynchronously. 15 | ||| 16 | ||| Commands are used as the primary means of setting up (interactive) UI 17 | ||| components and running effectful computations. 18 | ||| 19 | ||| Module `Web.MVC.View` provides various commands for creating, modifying 20 | ||| and deleting interactive DOM elements. 21 | ||| 22 | ||| Module `Web.MVC.Animate` has commands for firing events at regular 23 | ||| intervals and for running animations. 24 | ||| 25 | ||| Module `Web.MVC.Http` has commands for sending requests to and 26 | ||| firing events upon receiving responses from HTTP servers. 27 | public export 28 | record Cmd (e : Type) where 29 | constructor C 30 | run : (handler : e -> JSIO ()) -> JSIO () 31 | 32 | export %inline 33 | Functor Cmd where 34 | map f (C run) = C $ run . (. f) 35 | 36 | export 37 | Semigroup (Cmd e) where 38 | C f <+> C g = C $ \h => f h >> g h 39 | 40 | export %inline 41 | Monoid (Cmd e) where 42 | neutral = C . const $ pure () 43 | 44 | ||| Wraps a batch of commands in a single command by 45 | ||| installing each command sequentially. 46 | ||| 47 | ||| This function is stack safe. 48 | export 49 | batch : List (Cmd e) -> Cmd e 50 | batch cs = C $ \h => traverseList_ (`run` h) cs 51 | 52 | ||| Wrap an effectful computation in a command. 53 | ||| 54 | ||| The produced result is fired synchronously. 55 | export %inline 56 | cmd : JSIO e -> Cmd e 57 | cmd v = C (v >>=) 58 | 59 | ||| Wrap an effectful computation in a command. 60 | ||| 61 | ||| The produced result is fired synchronously. 62 | export %inline 63 | liftIO : IO e -> Cmd e 64 | liftIO = cmd . liftIO 65 | 66 | ||| Wrap an effectful computation in a command. 67 | ||| 68 | ||| This will never fire an event. 69 | export %inline 70 | cmd_ : JSIO () -> Cmd e 71 | cmd_ v = C $ const v 72 | 73 | ||| Wrap an effectful computation in a command. 74 | ||| 75 | ||| This will never fire an event. 76 | export %inline 77 | liftIO_ : IO () -> Cmd e 78 | liftIO_ = cmd_ . liftIO 79 | 80 | ||| Fires the given event once, synchronously. 81 | export %inline 82 | pure : e -> Cmd e 83 | pure v = C ($ v) 84 | 85 | ||| A command that produces no event. 86 | ||| 87 | ||| This will never fire an event. 88 | export %inline 89 | noAction : Cmd e 90 | noAction = neutral 91 | 92 | ||| Use the given command conditionally. 93 | ||| 94 | ||| If the boolean flag is `False`, this will return the 95 | ||| empty command (`noAction`). 96 | export 97 | cmdIf : Bool -> Lazy (Cmd e) -> Cmd e 98 | cmdIf True u = u 99 | cmdIf False _ = noAction 100 | 101 | ||| Convert a value in a `Maybe` to a `Cmd e`. 102 | ||| 103 | ||| Returns the empty command in case of a `Nothing`. 104 | export 105 | cmdIfJust : Maybe t -> (t -> Cmd e) -> Cmd e 106 | cmdIfJust m f = maybe noAction f m 107 | -------------------------------------------------------------------------------- /src/Web/MVC/Event.idr: -------------------------------------------------------------------------------- 1 | module Web.MVC.Event 2 | 3 | import JS 4 | import Text.HTML.Event 5 | import Web.Dom 6 | import Web.Raw.UIEvents 7 | 8 | %default total 9 | 10 | %foreign "browser:lambda:x=>x.target.value || x.target.innerHTML || ''" 11 | prim__input : Event -> PrimIO String 12 | 13 | %foreign "browser:lambda:x=>x.target.checked?1:0" 14 | prim__checked : Event -> PrimIO Bits8 15 | 16 | %foreign "browser:lambda:x=>x.target.files || []" 17 | prim__files : Event -> PrimIO FileList 18 | 19 | %foreign "browser:lambda:x=>x.length" 20 | prim__length : FileList -> PrimIO Bits32 21 | 22 | %foreign "browser:lambda:(x,y)=>x[y]" 23 | prim__item : FileList -> Bits32 -> File 24 | 25 | files : Event -> JSIO (List File) 26 | files e = do 27 | fs <- primIO (prim__files e) 28 | l <- primIO (prim__length fs) 29 | pure $ case l of 30 | 0 => [] 31 | x => prim__item fs <$> [0..x-1] 32 | 33 | export 34 | mouseInfo : MouseEvent -> JSIO MouseInfo 35 | mouseInfo e = 36 | [| MkMouseInfo 37 | (button e) 38 | (buttons e) 39 | (clientX e) 40 | (clientY e) 41 | (offsetX e) 42 | (offsetY e) 43 | (pageX e) 44 | (pageY e) 45 | (screenX e) 46 | (screenY e) 47 | (altKey e) 48 | (ctrlKey e) 49 | (metaKey e) 50 | (shiftKey e) 51 | |] 52 | 53 | export 54 | keyInfo : KeyboardEvent -> JSIO KeyInfo 55 | keyInfo e = 56 | [| MkKeyInfo 57 | (key e) 58 | (code e) 59 | (location e) 60 | (isComposing e) 61 | (altKey e) 62 | (ctrlKey e) 63 | (metaKey e) 64 | (shiftKey e) 65 | |] 66 | 67 | export 68 | changeInfo : Event -> JSIO InputInfo 69 | changeInfo e = 70 | [| MkInputInfo 71 | (primIO (prim__input e)) 72 | (files e) 73 | ((1 ==) <$> primIO (prim__checked e)) |] 74 | 75 | export 76 | inputInfo : InputEvent -> JSIO InputInfo 77 | inputInfo e = changeInfo $ up e 78 | 79 | export 80 | elemScrollInfo : Element -> JSIO ScrollInfo 81 | elemScrollInfo x = 82 | [| MkScrollInfo (get x scrollTop) (scrollHeight x) (clientHeight x) |] 83 | 84 | export 85 | scrollInfo : Event -> JSIO ScrollInfo 86 | scrollInfo e = do 87 | Just et <- target e | Nothing => pure $ MkScrollInfo 0 0 0 88 | maybe (pure $ MkScrollInfo 0 0 0) elemScrollInfo (castTo Element et) 89 | 90 | export 91 | wheelInfo : WheelEvent -> JSIO WheelInfo 92 | wheelInfo e = 93 | [| MkWheelInfo 94 | (deltaMode e) 95 | (deltaX e) 96 | (deltaY e) 97 | (deltaZ e) |] 98 | -------------------------------------------------------------------------------- /src/Web/MVC/Http.idr: -------------------------------------------------------------------------------- 1 | module Web.MVC.Http 2 | 3 | import Control.Monad.Either.Extra 4 | import Derive.Prelude 5 | import JS 6 | import JSON.Simple 7 | import Web.Html 8 | import Web.Raw.Xhr 9 | import Web.MVC.Cmd 10 | 11 | %default total 12 | %language ElabReflection 13 | 14 | -------------------------------------------------------------------------------- 15 | -- Utilities 16 | -------------------------------------------------------------------------------- 17 | 18 | export %inline 19 | Cast String JS.ByteString.ByteString where 20 | cast = believe_me 21 | 22 | export %inline 23 | Cast JS.ByteString.ByteString String where 24 | cast = believe_me 25 | 26 | -------------------------------------------------------------------------------- 27 | -- Types 28 | -------------------------------------------------------------------------------- 29 | 30 | ||| HTTP methods currently supported. 31 | public export 32 | data Method = GET | POST 33 | 34 | %runElab derive "Method" [Show,Eq,Ord] 35 | 36 | ||| A HTTP header is just a pair of strings. 37 | public export 38 | 0 Header : Type 39 | Header = (String,String) 40 | 41 | ||| Part in a formdata request. 42 | public export 43 | data Part : Type where 44 | StringPart : (name, value : String) -> Part 45 | FilePart : (name : String) -> (file : File) -> Part 46 | 47 | ||| Body of a HTTP request. 48 | public export 49 | data RequestBody : Type where 50 | Empty : RequestBody 51 | StringBody : (mimeType : String) -> (content : String) -> RequestBody 52 | JSONBody : ToJSON a => a -> RequestBody 53 | FormBody : List Part -> RequestBody 54 | 55 | ||| HTTP Errors 56 | public export 57 | data HTTPError : Type where 58 | Timeout : HTTPError 59 | NetworkError : HTTPError 60 | BadStatus : Bits16 -> HTTPError 61 | JSONError : String -> DecodingErr -> HTTPError 62 | 63 | ||| Type of expected respons. 64 | ||| 65 | ||| Every constructor takes a function for wrapping a request 66 | ||| result of type `Either HTTPError x` into the result type. 67 | public export 68 | data Expect : Type -> Type where 69 | ExpectJSON : FromJSON a => (Either HTTPError a -> r) -> Expect r 70 | ExpectString : (Either HTTPError String -> r) -> Expect r 71 | ExpectAny : (Either HTTPError () -> r) -> Expect r 72 | 73 | bodyHeaders : RequestBody -> List Header 74 | bodyHeaders Empty = [] 75 | bodyHeaders (StringBody m _) = [("Content-Type", m)] 76 | bodyHeaders (JSONBody x) = [("Content-Type", "application/json")] 77 | bodyHeaders (FormBody x) = [] 78 | 79 | append : FormData -> Part -> JSIO () 80 | append fd (StringPart name value) = FormData.append fd name value 81 | append fd (FilePart name file) = FormData.append1 fd name file 82 | 83 | parameters {0 r : Type} 84 | 85 | onerror : (r -> JSIO ()) -> Expect r -> HTTPError -> JSIO () 86 | onerror h (ExpectJSON f) err = h (f $ Left err) 87 | onerror h (ExpectString f) err = h (f $ Left err) 88 | onerror h (ExpectAny f) err = h (f $ Left err) 89 | 90 | onsuccess : (r -> JSIO ()) -> Expect r -> XMLHttpRequest -> JSIO () 91 | onsuccess h (ExpectString f) x = responseText x >>= h . f . Right 92 | onsuccess h (ExpectAny f) x = h (f $ Right ()) 93 | onsuccess h (ExpectJSON {a} f) x = do 94 | s <- responseText x 95 | h . f . mapFst (JSONError s) $ decode s 96 | 97 | onload : (r -> JSIO ()) -> Expect r -> XMLHttpRequest -> JSIO () 98 | onload h exp x = do 99 | st <- status x 100 | case st >= 200 && st < 300 of 101 | False => onerror h exp (BadStatus st) 102 | True => onsuccess h exp x 103 | 104 | xsend : RequestBody -> XMLHttpRequest -> JSIO () 105 | xsend Empty x = XMLHttpRequest.send x 106 | xsend (StringBody _ s) x = XMLHttpRequest.send' x (Def . Just $ inject s) 107 | xsend (JSONBody d) x = XMLHttpRequest.send' x (Def . Just $ inject $ encode d) 108 | xsend (FormBody ps) x = do 109 | fd <- FormData.new 110 | traverseList_ (append fd) ps 111 | XMLHttpRequest.send' x (Def . Just $ inject fd) 112 | 113 | ||| Sends a HTTP request. 114 | ||| 115 | ||| Converts the response to an event of type `r`. 116 | export 117 | request : 118 | (method : Method) 119 | -> (headers : List Header) 120 | -> (url : String) 121 | -> (body : RequestBody) 122 | -> (expect : Expect r) 123 | -> (timeout : Maybe Bits32) 124 | -> Cmd r 125 | request m headers url body exp tout = C $ \h => Prelude.do 126 | -- create new Http request 127 | x <- XMLHttpRequest.new 128 | 129 | -- register event listeners 130 | XMLHttpRequestEventTarget.onerror x ?> onerror h exp NetworkError 131 | XMLHttpRequestEventTarget.onload x ?> onload h exp x 132 | XMLHttpRequestEventTarget.ontimeout x ?> onerror h exp Timeout 133 | 134 | -- open url 135 | open_ x (cast $ show m) url 136 | 137 | -- set message headers 138 | let hs := bodyHeaders body ++ headers 139 | traverseList_ (\(n,h) => setRequestHeader x (cast n) (cast h)) hs 140 | 141 | -- set timeout (if any) 142 | traverse_ (set (timeout x)) tout 143 | 144 | -- send request 145 | xsend body x 146 | 147 | ||| Send a GET HTTP request. 148 | export %inline 149 | get : (url : String) -> (expect : Expect r) -> Cmd r 150 | get u e = request GET [] u Empty e Nothing 151 | 152 | ||| Send a GET request, reading the response as plain text. 153 | export %inline 154 | getText : (url : String) -> (f : Either HTTPError String -> r) -> Cmd r 155 | getText u = get u . ExpectString 156 | 157 | ||| Send a GET request, decoding the result as a JSON string 158 | ||| and converting it to the result type `a`. 159 | export %inline 160 | getJSON : FromJSON a => (url : String) -> (f : Either HTTPError a -> r) -> Cmd r 161 | getJSON u = get u . ExpectJSON 162 | 163 | ||| Send a POST request. 164 | export %inline 165 | post : (url : String) -> (body : RequestBody) -> (expect : Expect r) -> Cmd r 166 | post u b e = request POST [] u b e Nothing 167 | -------------------------------------------------------------------------------- /src/Web/MVC/Util.idr: -------------------------------------------------------------------------------- 1 | module Web.MVC.Util 2 | 3 | import JS 4 | import Text.CSS 5 | import Text.HTML 6 | import Web.Dom 7 | import Web.Html 8 | import Web.Raw.Geometry 9 | import public Text.HTML.Ref 10 | import public Text.HTML.Tag 11 | 12 | %default total 13 | 14 | ||| DOM type associacte with an ElemRef 15 | public export 16 | 0 ElemType : Ref t -> Type 17 | ElemType (Id _) = Element 18 | ElemType (Elem _) = Element 19 | ElemType Body = HTMLElement 20 | ElemType Document = Document 21 | ElemType Window = Window 22 | 23 | -------------------------------------------------------------------------------- 24 | -- Accessing and Updating Nodes 25 | -------------------------------------------------------------------------------- 26 | 27 | ||| Tries to retrieve an element of the given type by looking 28 | ||| up its ID in the DOM. Unlike `getElementById`, this will throw 29 | ||| an exception in the `JSIO` monad if the element is not found 30 | ||| or can't be safely cast to the desired type. 31 | export 32 | strictGetElementById : SafeCast t => Maybe String -> (id : String) -> JSIO t 33 | strictGetElementById mtag id = do 34 | Nothing <- castElementById t id | Just t => pure t 35 | liftJSIO $ throwError $ 36 | let tag := fromMaybe "element" mtag 37 | in Caught "Web.MVC.Output.strictGetElementById: Could not find \{tag} with id \{id}" 38 | 39 | ||| Tries to retrieve a HTMLElement by looking 40 | ||| up its ID in the DOM. Unlike `getElementById`, this will throw 41 | ||| an exception in the `JSIO` monad if the element is not found 42 | ||| or can't be safely cast to the desired type. 43 | export %inline 44 | strictGetHTMLElementById : (tag,id : String) -> JSIO HTMLElement 45 | strictGetHTMLElementById = strictGetElementById . Just 46 | 47 | ||| Tries to retrieve an element of the given type by looking 48 | ||| up its ID in the DOM. Unlike `getElementById`, this will throw 49 | ||| an exception in the `JSIO` monad if the element is not found 50 | ||| or can't be safely cast to the desired type. 51 | export 52 | getElementByRef : (r : Ref t) -> JSIO (ElemType r) 53 | getElementByRef (Id {tag} id) = strictGetElementById (Just tag) id 54 | getElementByRef (Elem id) = strictGetElementById Nothing id 55 | getElementByRef Body = body 56 | getElementByRef Document = document 57 | getElementByRef Window = window 58 | 59 | err : String 60 | err = "Web.MVC.Output.castElementByRef" 61 | 62 | ||| Tries to retrieve an element of the given type by looking 63 | ||| up its ID in the DOM. Unlike `getElementById`, this will throw 64 | ||| an exception in the `JSIO` monad if the element is not found 65 | ||| or can't be safely cast to the desired type. 66 | export 67 | castElementByRef : {0 x : k} -> SafeCast t => Ref x -> JSIO t 68 | castElementByRef (Id {tag} id) = strictGetElementById (Just tag) id 69 | castElementByRef (Elem id) = strictGetElementById Nothing id 70 | castElementByRef Body = body >>= tryCast err 71 | castElementByRef Document = document >>= tryCast err 72 | castElementByRef Window = window >>= tryCast err 73 | 74 | setVM : Ref t -> ValidityTag t -> String -> JSIO () 75 | setVM r SVButton s = castElementByRef r >>= \x => HTMLButtonElement.setCustomValidity x s 76 | setVM r SVFieldSet s = castElementByRef r >>= \x => HTMLFieldSetElement.setCustomValidity x s 77 | setVM r SVInput s = castElementByRef r >>= \x => HTMLInputElement.setCustomValidity x s 78 | setVM r SVObject s = castElementByRef r >>= \x => HTMLObjectElement.setCustomValidity x s 79 | setVM r SVOutput s = castElementByRef r >>= \x => HTMLOutputElement.setCustomValidity x s 80 | setVM r SVSelect s = castElementByRef r >>= \x => HTMLSelectElement.setCustomValidity x s 81 | setVM r SVTextArea s = castElementByRef r >>= \x => HTMLTextAreaElement.setCustomValidity x s 82 | 83 | setVal : Ref t -> ValueTag t -> String -> JSIO () 84 | setVal r VButton s = castElementByRef r >>= (HTMLButtonElement.value =. s) 85 | setVal r VData s = castElementByRef r >>= (HTMLDataElement.value =. s) 86 | setVal r VInput s = castElementByRef r >>= (HTMLInputElement.value =. s) 87 | setVal r VOption s = castElementByRef r >>= (HTMLOptionElement.value =. s) 88 | setVal r VOutput s = castElementByRef r >>= (HTMLOutputElement.value =. s) 89 | setVal r VParam s = castElementByRef r >>= (HTMLParamElement.value =. s) 90 | setVal r VSelect s = castElementByRef r >>= (HTMLSelectElement.value =. s) 91 | setVal r VTextArea s = castElementByRef r >>= (HTMLTextAreaElement.value =. s) 92 | 93 | export 94 | setValidityMessage : Ref t -> ValidityTag t => String -> JSIO () 95 | setValidityMessage r = setVM r %search 96 | 97 | export 98 | setValue : Ref t -> ValueTag t => String -> JSIO () 99 | setValue r = setVal r %search 100 | 101 | -------------------------------------------------------------------------------- 102 | -- DOM Updates 103 | -------------------------------------------------------------------------------- 104 | 105 | nodeList : DocumentFragment -> List (HSum [Node,String]) 106 | nodeList df = [inject $ df :> Node] 107 | 108 | ||| Replaces all children of the given node with a new document fragment. 109 | export %inline 110 | replaceChildren : Element -> DocumentFragment -> JSIO () 111 | replaceChildren elem = replaceChildren elem . nodeList 112 | 113 | ||| Appends the given document fragment to a DOM element's children 114 | export %inline 115 | appendDF : Element -> DocumentFragment -> JSIO () 116 | appendDF elem = append elem . nodeList 117 | 118 | ||| Prepends the given document fragment to a DOM element's children 119 | export %inline 120 | prependDF : Element -> DocumentFragment -> JSIO () 121 | prependDF elem = prepend elem . nodeList 122 | 123 | ||| Inserts the given document fragment after a DOM element. 124 | export %inline 125 | afterDF : Element -> DocumentFragment -> JSIO () 126 | afterDF elem = after elem . nodeList 127 | 128 | ||| Inserts the given document fragment before a DOM element. 129 | export %inline 130 | beforeDF : Element -> DocumentFragment -> JSIO () 131 | beforeDF elem = before elem . nodeList 132 | 133 | ||| Inserts the given document fragment before a DOM element. 134 | export %inline 135 | replaceDF : Element -> DocumentFragment -> JSIO () 136 | replaceDF elem = replaceWith elem . nodeList 137 | 138 | -------------------------------------------------------------------------------- 139 | -- Element Geometry 140 | -------------------------------------------------------------------------------- 141 | 142 | export 143 | toRect : DOMRect -> JSIO Rect 144 | toRect r = 145 | [| MkRect 146 | (DOMRectReadOnly.x r) 147 | (DOMRectReadOnly.y r) 148 | (DOMRectReadOnly.height r) 149 | (DOMRectReadOnly.width r) 150 | (DOMRectReadOnly.top r) 151 | (DOMRectReadOnly.bottom r) 152 | (DOMRectReadOnly.left r) 153 | (DOMRectReadOnly.right r) 154 | |] 155 | 156 | export 157 | boundingRect : {0 x : k} -> Ref x -> JSIO Rect 158 | boundingRect ref = do 159 | el <- castElementByRef {t = Element} ref 160 | r <- Element.getBoundingClientRect el 161 | toRect r 162 | -------------------------------------------------------------------------------- /src/Web/MVC/Widget.idr: -------------------------------------------------------------------------------- 1 | module Web.MVC.Widget 2 | 3 | import Web.MVC 4 | 5 | %default total 6 | 7 | -------------------------------------------------------------------------------- 8 | -- Widgets 9 | -------------------------------------------------------------------------------- 10 | 11 | 12 | ||| A `Widget` is a standalone UI element that manages its own 13 | ||| state. It packages up all aspects of an MVC component into a 14 | ||| single piece of data that can be passed around and transformed, 15 | ||| before finally turned into a runnable program with `runWidget`. 16 | ||| 17 | ||| See the various parameters of `Web.MVC.runMVC` for further 18 | ||| explanation. 19 | public export 20 | record Widget where 21 | constructor MkWidget 22 | 23 | ||| The internal state of the widget (model) 24 | 0 St : Type 25 | ||| Event type 26 | 0 Ev : Type 27 | ||| Initial state 28 | init : St 29 | ||| Given the initial state, set up the UI 30 | setup : St -> Cmd Ev 31 | ||| Update the state based on the latest event 32 | update : Ev -> St -> St 33 | ||| Update the UI based on the latest event and the current state 34 | display : Ev -> St -> Cmd Ev 35 | 36 | ||| `w1 <+> w2` is the independent composition of widgets `w1` and 37 | ||| `w2`, with the product state and the sum events. 38 | public export 39 | Semigroup Widget where 40 | w1 <+> w2 = MkWidget 41 | { St = (w1.St, w2.St) 42 | , Ev = Either w1.Ev w2.Ev 43 | , init = (w1.init, w2.init) 44 | , setup = \(s1, s2) => batch 45 | [ Left <$> w1.setup s1 46 | , Right <$> w2.setup s2 47 | ] 48 | , update = \ev, (s1, s2) => case ev of 49 | Left ev1 => (w1.update ev1 s1, s2) 50 | Right ev2 => (s1, w2.update ev2 s2) 51 | , display = \ev, (s1, s2) => case ev of 52 | Left ev => Left <$> w1.display ev s1 53 | Right ev => Right <$> w2.display ev s2 54 | } 55 | 56 | ||| `neutral` is the trivial widget with trivial state and no events 57 | public export 58 | Monoid Widget where 59 | neutral = MkWidget 60 | { St = () 61 | , Ev = Void 62 | , init = () 63 | , setup = neutral 64 | , update = absurd 65 | , display = \_, _ => neutral 66 | } 67 | 68 | ||| Run a `Widget`. This is basically `runMVC` with the arguments 69 | ||| constructed from the fields of `Widget`. Since this function 70 | ||| produces no result, there's no going back from here: all `Widget` 71 | ||| composition and transformation must be done beforehand. 72 | export 73 | covering 74 | runWidget : (JSErr -> IO ()) -> Widget -> IO () 75 | runWidget onError w = runMVC update display onError Nothing w.init 76 | where 77 | update : Maybe w.Ev -> w.St -> w.St 78 | update Nothing = id 79 | update (Just ev) = w.update ev 80 | 81 | display : Maybe w.Ev -> w.St -> Cmd (Maybe w.Ev) 82 | display ev s = Just <$> maybe w.setup w.display ev s 83 | --------------------------------------------------------------------------------