├── .gitignore ├── README.md ├── bower.json ├── html ├── index.html └── main.css ├── package.json ├── psc-package.json ├── src ├── Flare.js ├── Flare.purs └── Flare │ ├── Drawing.purs │ └── Smolder.purs └── test └── Main.purs /.gitignore: -------------------------------------------------------------------------------- 1 | bower_components 2 | node_modules 3 | output 4 | .psci 5 | html/main.js 6 | .psci_modules 7 | .pulp-cache 8 | .psc-ide-port 9 | .psc-package 10 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ## Flare 2 | 3 | Flare is a special-purpose UI library for 4 | [PureScript](https://github.com/purescript/purescript). It is built on top 5 | of [purescript-signal](https://github.com/bodil/purescript-signal) and uses 6 | Applicative-style programming to combine predefined input fields to a reactive 7 | user interface. Flare is inspired by the Haskell library 8 | [typed-spreadsheet](https://github.com/Gabriel439/Haskell-Typed-Spreadsheet-Library). 9 | The main design-criterion of this library is ease of use. 10 | 11 | - [Tutorial](https://david-peter.de/articles/flare/) - Introduction with many examples 12 | - [Try Flare](http://try.purescript.org/?backend=flare) - Write and compile Flare UIs in your browser 13 | - [Talk](https://www.youtube.com/watch?v=iTSosG7vUyI) - A talk I gave about Flare and FlareCheck at LambdaConf 2016 14 | - [Tests](http://sharkdp.github.io/purescript-flare/) - A lot of additional examples 15 | - [Quick start](https://github.com/sharkdp/flare-example) - Start a new Flare project 16 | - [Module documentation](http://pursuit.purescript.org/packages/purescript-flare/) 17 | 18 | ## Projects that use Flare 19 | 20 | - [purescript-sparkle](https://github.com/sharkdp/purescript-sparkle) - QuickCheck-style interactive tests 21 | - [purescript-flaredoc](https://github.com/sharkdp/purescript-flaredoc/) - Interactive documentation using FlareCheck (see [-arrays](http://sharkdp.github.io/purescript-flaredoc/), [-strings](http://sharkdp.github.io/purescript-strings/), [-colors](http://sharkdp.github.io/purescript-colors/)) 22 | - [purescript-isometric](http://sharkdp.github.io/purescript-isometric/) - Interactive 3D rendering 23 | - [Nature invented it first](http://nosubstance.me/post/nature-invented-it-first/) - Blog post with interactive animation 24 | 25 | ## Building 26 | ``` 27 | bower install 28 | pulp build -O -I test -m Test.Main -t html/main.js 29 | ``` 30 | -------------------------------------------------------------------------------- /bower.json: -------------------------------------------------------------------------------- 1 | { 2 | "name": "purescript-flare", 3 | "authors": [ 4 | "David Peter " 5 | ], 6 | "license": "MIT", 7 | "ignore": [ 8 | "**/.*", 9 | "bower_components", 10 | "output", 11 | "test", 12 | "html" 13 | ], 14 | "repository": { 15 | "type": "git", 16 | "url": "git://github.com/sharkdp/purescript-flare.git" 17 | }, 18 | "dependencies": { 19 | "purescript-canvas": "^4.0.0", 20 | "purescript-datetime": "^4.0.0", 21 | "purescript-drawing": "^4.0.0", 22 | "purescript-foldable-traversable": "^4.0.0", 23 | "purescript-nonempty": "^5.0.0", 24 | "purescript-signal": "^10.1.0", 25 | "purescript-smolder": "^12.0.0", 26 | "purescript-tuples": "^5.0.0", 27 | "purescript-web-dom": "^1.0.0" 28 | } 29 | } 30 | -------------------------------------------------------------------------------- /html/index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | purescript-flare 8 | 9 | 10 | 11 | 12 | 13 | 14 |

Flare examples

15 |

Example 1: Two number inputs

16 |

 17 | pow <$> number "Base" 2.0
 18 |     <*> number "Exponent" 10.0
 19 |

20 |

21 |

22 | 23 |

Example 2: Semigroup instance

24 |

 25 | string_ "Hello" <> pure " " <> string_ "World"
 26 |

27 |

28 |

29 | 30 |

Example 3: Traverse

31 |

 32 | sum <$> traverse int_ [2, 13, 27, 42]
 33 |

34 |

35 |

36 | 37 |

Example 4: More calculations

38 |

 39 | lift2 (/) (number_ 5.0) (number_ 2.0)
 40 |

41 |

42 |

43 | 44 |

Example 5: Drawing output

45 |

 46 | coloredCircle hue radius =
 47 |   filled (fillColor (hsl hue 0.8 0.4)) (circle 50.0 50.0 radius)
 48 | 
 49 | ui = coloredCircle <$> (numberSlider "Hue"    0.0 360.0 1.0 140.0)
 50 |                    <*> (numberSlider "Radius" 2.0  45.0 0.1  25.0)
 51 |

52 |

53 |

54 | 55 |

Example 6: Select box

56 |

 57 | data Language = English | French | German
 58 | 
 59 | toString English = "english"
 60 | toString French  = "french"
 61 | toString German  = "german"
 62 | 
 63 | greet English = "Hello"
 64 | greet French  = "Salut"
 65 | greet German  = "Hallo"
 66 | 
 67 | ui = (greet <$> (select "Language" (English :| [French, German]) toString))
 68 |      <> pure " " <> string "Name" "Pierre" <> pure "!"
 69 |

70 |

71 |

72 | 73 |

Example 7: Integration with Signals (Superformula)

74 |

 75 | plot m n1 s col time =
 76 |       filled (fillColor col) $
 77 |         path (map point angles)
 78 | 
 79 |       where point phi = { x: 100.0 + radius phi * cos phi
 80 |                         , y: 100.0 + radius phi * sin phi }
 81 |             angles = map (\i -> 2.0 * pi / toNumber points * toNumber i)
 82 |                          (0 .. points)
 83 |             points = 400
 84 |             n2 = s + 3.0 * sin (0.005 * time)
 85 |             n3 = s + 3.0 * cos (0.005 * time)
 86 |             radius phi = 20.0 * pow expr (- 1.0 / n1)
 87 |               where expr = first + second
 88 |                     first = pow (abs (cos (m * phi / 4.0))) n2
 89 |                     second = pow (abs (sin (m * phi / 4.0))) n3
 90 | 
 91 | ui7 = plot <$> (numberSlider "m"  0.0 10.0 1.0  7.0)
 92 |            <*> (numberSlider "n1" 1.0 10.0 0.1  4.0)
 93 |            <*> (numberSlider "s"  4.0 16.0 0.1 14.0)
 94 |            <*> (color "Color" (hsl 333.0 0.6 0.5))
 95 |            <*> lift animationFrame
 96 |

97 |

98 |

99 | 100 |

Example 8: Lists and sliders

101 |

102 | traverse (intSlider_ 1 5) (1..5)
103 |

104 |

105 |

106 | 107 |

Example 9: Checkboxes

108 |

109 | lift2 (&&) (boolean_ false) (boolean_ true)
110 |

111 |

112 |

113 | 114 |

Example 10: Folding over the past

115 |

116 | graph xs width = outlined (outlineColor black <> lineWidth width)
117 |                           (path points)
118 |   where points = zipWith point xs (1 .. length xs)
119 |         point x y = { x, y: toNumber y }
120 | 
121 | ui = graph <$> foldp cons [] (numberSlider "Position" 0.0 150.0 1.0 75.0)
122 |            <*> numberSlider "Width" 1.0 5.0 0.1 1.0
123 |

124 |

125 |

127 | 128 |

Example 11: Buttons

129 |

130 | ui = foldp (+) 0 (button "Increment" 0 1)
131 |

132 |

133 |

134 | 135 |

Example 12: HTML output using Smolder

136 |

137 | table h w = H.table $ foldMap row (0 .. h)
138 |   where row i = H.tr $ foldMap (cell i) (0 .. w)
139 |         cell i j = H.td (H.text (show i <> "," <> show j))
140 | 
141 | ui = table <$> intSlider_ 0 9 5 <*> intSlider_ 0 9 5
142 |

143 |

144 |

145 | 146 |

Example 13: Adding items to a list

147 |

148 | actions = string "Add item:" "Orange" <**> button "Add" (flip const) cons
149 | 
150 | list = foldp id ["Apple", "Banana"] actions
151 | 
152 | ui = (H.ul <<< foldMap (H.li <<< H.text)) <$> list
153 |

154 |

155 |

156 | 157 |

Example 14: Color picker (running Flare inside Flare)

158 |

159 | data Domain = HSL | RGB
160 | 
161 | showDomain HSL = "HSL"
162 | showDomain RGB = "RGB"
163 | 
164 | toHTML c = H.div `H.with` (A.style $ "background-color:" <> hex) $ H.text hex
165 |   where hex = cssStringHSLA c
166 | 
167 | ns l = numberSlider l 0.0
168 | 
169 | is l = intSlider l 0 255
170 | 
171 | uiColor HSL = hsl <$> ns "Hue"        360.0  1.0 180.0
172 |                   <*> ns "Saturation"   1.0 0.01   0.5
173 |                   <*> ns "Lightness"    1.0 0.01   0.5
174 | uiColor RGB = rgb <$> is "Red"   200
175 |                   <*> is "Green"   0
176 |                   <*> is "Blue"  100
177 | 
178 | ui = toHTML <$>
179 |      select "Color domain" (HSL :| [RGB]) showDomain `innerFlare` uiColor
180 |

181 |

182 |

183 | 184 |

Example 15: Multiple buttons

185 |

186 | data Action = Increment | Decrement | Negate | Reset
187 | 
188 | label Increment = "+ 1"
189 | label Decrement = "- 1"
190 | label Negate    = "+/-"
191 | label Reset     = "Reset"
192 | 
193 | perform :: Action -> Int -> Int
194 | perform Increment = add 1
195 | perform Decrement = flip sub 1
196 | perform Negate    = negate
197 | perform Reset     = const 0
198 | 
199 | ui = foldp (maybe id perform) 0 $
200 |        buttons [Increment, Decrement, Negate, Reset] label
201 |

202 |

203 |

204 | 205 |

Example 16: Using other Signal functions (here: since)

206 |

207 | light on = H.with H.div arg mempty
208 |   where arg | on = A.className "on"
209 |             | otherwise = mempty
210 | 
211 | ui = light <$> liftSF (since 1000.0) (button "Switch on" unit unit)
212 |

213 |

214 |

215 | 216 |

Example 17: Date input

217 |

218 | ui = showDiff <$> date "Date 1" (fromMaybe bottom date1)
219 |               <*> date "Date 2" (fromMaybe bottom date2)
220 |   where
221 |     date1 = canonicalDate <$> toEnum 1986 <*> toEnum 7 <*> toEnum 3
222 |     date2 = canonicalDate <$> toEnum 2016 <*> toEnum 8 <*> toEnum 5
223 |     showDiff d1 d2 = "Days between the dates: " <>
224 |                      show (round $ abs $ unDays $ diff d1 d2)
225 |

226 |

227 |

228 | 229 |

Example 18: Resizable lists

230 |

231 | ui = acronym <$> resizableList "Words" string_ "Really" defaultList
232 |   where
233 |     defaultList = "Don't" : "Repeat" : "Yourself" : Nil
234 |     acronym xs = "Acronym: " <> foldMap (take 1) xs
235 |

236 |

237 |

238 | 239 | 240 | 241 | 242 | -------------------------------------------------------------------------------- /html/main.css: -------------------------------------------------------------------------------- 1 | body { 2 | margin: 40px; 3 | } 4 | 5 | pre { 6 | background-color: #f0f0f0; 7 | padding: 10px; 8 | width: 830px; 9 | } 10 | 11 | h3 { 12 | margin-top: 30px; 13 | margin-bottom: 5px; 14 | } 15 | 16 | .flare-input { 17 | margin-bottom: 5px; 18 | } 19 | 20 | input:invalid { 21 | background-color: #ff5050; 22 | } 23 | 24 | .flare-input-number, .flare-input-int-number { 25 | width: 80px; 26 | } 27 | 28 | input[type="range"] { 29 | width: 150px; 30 | border: 1px solid transparent; 31 | } 32 | 33 | label { 34 | width: 150px; 35 | display: inline-block; 36 | } 37 | 38 | table { 39 | width: 300px; 40 | height: 300px; 41 | } 42 | 43 | td { 44 | text-align: center; 45 | border: 1px solid black; 46 | padding: 3px; 47 | font-size: 11px; 48 | } 49 | 50 | #output14 > div { 51 | display: inline-block; 52 | padding: 20px; 53 | color: black; 54 | text-shadow: 0px 0px 4px white; 55 | font-family: courier; 56 | } 57 | 58 | #controls15 > div { 59 | display: inline-block; 60 | margin-right: 5px; 61 | } 62 | 63 | #output16 > div { 64 | width: 50px; 65 | height: 50px; 66 | border-radius: 25px; 67 | background-color: #ccc; 68 | } 69 | 70 | #output16 > div.on { 71 | background-color: #ebdd13; 72 | } 73 | -------------------------------------------------------------------------------- /package.json: -------------------------------------------------------------------------------- 1 | { 2 | "private": true, 3 | "scripts": { 4 | "clean": "rimraf output && rimraf .pulp-cache", 5 | "build": "pulp build", 6 | "test": "pulp test" 7 | }, 8 | "devDependencies": { 9 | "pulp": "^12.3.0", 10 | "purescript": "^0.12.0", 11 | "purescript-psa": "^0.6.0", 12 | "rimraf": "^2.6.2" 13 | } 14 | } 15 | -------------------------------------------------------------------------------- /psc-package.json: -------------------------------------------------------------------------------- 1 | { 2 | "name": "purescript-flare", 3 | "set": "psc-0.12.0", 4 | "source": "https://github.com/purescript/package-sets.git", 5 | "depends": [ 6 | "canvas", 7 | "datetime", 8 | "drawing", 9 | "foldable-traversable", 10 | "nonempty", 11 | "prelude", 12 | "signal", 13 | "smolder", 14 | "tuples", 15 | "web-dom" 16 | ] 17 | } 18 | -------------------------------------------------------------------------------- /src/Flare.js: -------------------------------------------------------------------------------- 1 | // module Flare 2 | // jshint browser: true 3 | // jshint node: true 4 | 5 | "use strict"; 6 | 7 | exports.renderString = function(target) { 8 | return function(content) { 9 | return function() { 10 | document.getElementById(target).innerHTML = content; 11 | }; 12 | }; 13 | }; 14 | 15 | exports.removeChildren = function(target) { 16 | return function() { 17 | var el = document.getElementById(target); 18 | 19 | // http://stackoverflow.com/a/3955238/704831 20 | while (el.firstChild) { 21 | el.removeChild(el.firstChild); 22 | } 23 | }; 24 | }; 25 | 26 | exports.createInnerElementP = function(tuple) { 27 | return function () { 28 | var uid = getUniqueID(); 29 | var el = document.createElement('div'); 30 | el.id = uid; 31 | // append element to body so it can be found by getElementById. 32 | // It will be moved to the right place later when rendering 33 | document.body.appendChild(el); 34 | return tuple(uid)(el); 35 | }; 36 | }; 37 | 38 | exports.appendComponent = function(target) { 39 | return function(el) { 40 | return function() { 41 | document.getElementById(target).appendChild(el); 42 | }; 43 | }; 44 | }; 45 | 46 | // This function maintains a global state `window.flareID` to generate unique 47 | // DOM element IDs. It is only called from functions with a DOM effect. 48 | function getUniqueID() { 49 | if (window.flareID === undefined) { 50 | window.flareID = 0; 51 | } 52 | window.flareID = window.flareID + 1; 53 | return "flare-component-" + window.flareID.toString(); 54 | } 55 | 56 | function createComponent(inputType, elementCallback, eventType, eventListener) { 57 | return function(label) { 58 | return function(initial) { 59 | return function(send) { 60 | return function() { 61 | var uid = getUniqueID(); 62 | var el = elementCallback(initial); 63 | el.className = "flare-input-" + inputType; 64 | el.id = uid; 65 | 66 | var div = document.createElement("div"); 67 | div.className = "flare-input"; 68 | 69 | if (label !== "") { 70 | var labelEl = document.createElement("label"); 71 | labelEl.htmlFor = uid; 72 | labelEl.appendChild(document.createTextNode(label)); 73 | div.appendChild(labelEl); 74 | } 75 | 76 | div.appendChild(el); 77 | 78 | el.addEventListener(eventType, function(e) { 79 | var value = eventListener(e.target, initial); 80 | send(value)(); 81 | }); 82 | 83 | return div; 84 | }; 85 | }; 86 | }; 87 | }; 88 | } 89 | 90 | exports.cNumber = createComponent("number", 91 | function(initial) { 92 | var input = document.createElement("input"); 93 | input.type = "number"; 94 | input.step = "any"; 95 | input.value = initial.toString(); 96 | return input; 97 | }, 98 | "input", 99 | function(t, initial) { 100 | var val = parseFloat(t.value); 101 | return (isNaN(val) ? initial : val); 102 | } 103 | ); 104 | 105 | function clamp(min, max, initial, value) { 106 | if (isNaN(value)) { 107 | return initial; 108 | } else if (value < min) { 109 | return min; 110 | } else if (value > max) { 111 | return max; 112 | } 113 | return value; 114 | } 115 | 116 | exports.cNumberRange = function(type) { 117 | return function(min) { 118 | return function(max) { 119 | return function(step) { 120 | return createComponent("number-" + type, 121 | function(initial) { 122 | var input = document.createElement("input"); 123 | input.type = type; 124 | input.min = min.toString(); 125 | input.max = max.toString(); 126 | input.step = step.toString(); 127 | input.value = initial.toString(); 128 | return input; 129 | }, 130 | "input", 131 | function(t, initial) { 132 | return clamp(min, max, initial, parseFloat(t.value)); 133 | } 134 | ); 135 | }; 136 | }; 137 | }; 138 | }; 139 | 140 | exports.cIntRange = function(type) { 141 | return function(min) { 142 | return function(max) { 143 | return createComponent("int-" + type, 144 | function(initial) { 145 | var input = document.createElement("input"); 146 | input.type = type; 147 | input.min = min.toString(); 148 | input.max = max.toString(); 149 | input.step = "1"; 150 | input.value = initial.toString(); 151 | return input; 152 | }, 153 | "input", 154 | function(t, initial) { 155 | return clamp(min, max, initial, parseInt(t.value, 10)); 156 | } 157 | ); 158 | }; 159 | }; 160 | }; 161 | 162 | exports.cString = createComponent("string", 163 | function(initial) { 164 | var input = document.createElement("input"); 165 | input.type = "text"; 166 | input.value = initial; 167 | return input; 168 | }, 169 | "input", 170 | function(t, initial) { 171 | return t.value; 172 | } 173 | ); 174 | 175 | exports.cStringPattern = function(pattern) { 176 | return createComponent("string-pattern", 177 | function(initial) { 178 | var input = document.createElement("input"); 179 | input.type = "text"; 180 | input.pattern = pattern; 181 | input.required = true; 182 | input.value = initial; 183 | return input; 184 | }, 185 | "input", 186 | function(t, initial) { 187 | return t.value; 188 | } 189 | ); 190 | }; 191 | 192 | exports.cBoolean = createComponent("boolean", 193 | function(initial) { 194 | var input = document.createElement("input"); 195 | input.type = "checkbox"; 196 | input.checked = initial; 197 | return input; 198 | }, 199 | "change", 200 | function(t, initial) { 201 | return t.checked; 202 | } 203 | ); 204 | 205 | exports.cButton = function(vPressed) { 206 | return function(label) { 207 | return function(vDefault) { 208 | return function(send) { 209 | return function() { 210 | var div = document.createElement("div"); 211 | div.className = "flare-input"; 212 | 213 | var button = document.createElement("button"); 214 | button.id = getUniqueID(); 215 | button.className = "flare-input-button"; 216 | button.appendChild(document.createTextNode(label)); 217 | 218 | button.addEventListener('mousedown', function() { 219 | send(vPressed)(); 220 | }); 221 | button.addEventListener('mouseup', function() { 222 | send(vDefault)(); 223 | }); 224 | 225 | div.appendChild(button); 226 | return div; 227 | 228 | }; 229 | }; 230 | }; 231 | }; 232 | }; 233 | 234 | exports.cSelect = function(xs) { 235 | return function(toString) { 236 | return createComponent("select", 237 | function(initial) { 238 | var select = document.createElement("select"); 239 | 240 | var x, op; 241 | for (var i = 0; i < xs.length + 1; i++) { 242 | x = (i === 0) ? initial : xs[i - 1]; 243 | op = document.createElement("option"); 244 | op.appendChild(document.createTextNode(toString(x))); 245 | select.appendChild(op); 246 | } 247 | 248 | return select; 249 | }, 250 | "change", 251 | function(t, initial) { 252 | var ix = t.selectedIndex; 253 | if (ix === 0) { 254 | return initial; 255 | } 256 | return xs[ix - 1]; 257 | } 258 | ); 259 | }; 260 | }; 261 | 262 | exports.cRadioGroup = function(xs) { 263 | return function(toString) { 264 | return function(label) { 265 | var uid = getUniqueID(); 266 | return createComponent("radioGroup", 267 | function(initial) { 268 | var fieldset = document.createElement("fieldset"); 269 | 270 | if (label !== "") { 271 | var legend = document.createElement("legend"); 272 | legend.appendChild(document.createTextNode(label)); 273 | fieldset.appendChild(legend); 274 | } 275 | 276 | var x, xid, op, labelEl; 277 | for (var i = 0; i < xs.length + 1; i++) { 278 | x = (i === 0) ? initial : xs[i - 1]; 279 | xid = uid + "-" + i.toString(); 280 | 281 | op = document.createElement("input"); 282 | op.type = "radio"; 283 | op.name = uid; 284 | op.id = xid; 285 | if (i === 0) { 286 | op.checked = "checked"; 287 | } 288 | fieldset.appendChild(op); 289 | 290 | labelEl = document.createElement("label"); 291 | labelEl.appendChild(document.createTextNode(toString(x))); 292 | labelEl.htmlFor = xid; 293 | fieldset.appendChild(labelEl); 294 | } 295 | 296 | return fieldset; 297 | }, 298 | "change", 299 | function(t, initial) { 300 | var ix = parseInt(t.id.substr(uid.length + 1), 10); 301 | if (ix === 0) { 302 | return initial; 303 | } 304 | return xs[ix - 1]; 305 | } 306 | )(""); 307 | }; 308 | }; 309 | }; 310 | 311 | exports.cTextarea = createComponent("textarea", 312 | function(initial) { 313 | var textarea = document.createElement("textarea"); 314 | textarea.value = initial; 315 | return textarea; 316 | }, 317 | "input", 318 | function(t, initial) { 319 | return t.value; 320 | } 321 | ); 322 | 323 | 324 | exports.toFieldset = function(label) { 325 | return function(elements) { 326 | var fieldset = document.createElement("fieldset"); 327 | 328 | if (label !== "") { 329 | var legend = document.createElement("legend"); 330 | legend.appendChild(document.createTextNode(label)); 331 | fieldset.appendChild(legend); 332 | } 333 | 334 | for (var i = 0; i < elements.length; i++) { 335 | fieldset.appendChild(elements[i]); 336 | } 337 | 338 | return fieldset; 339 | }; 340 | }; 341 | 342 | 343 | exports.cResizableList = function(prependDefault) { 344 | return function(listUi) { 345 | return function(label) { 346 | return function(defaultList) { 347 | return function(send) { 348 | return function() { 349 | var uid = getUniqueID(); 350 | var container = document.createElement("div"); 351 | container.className = "flare-input"; 352 | 353 | if (label !== "") { 354 | var labelEl = document.createElement("label"); 355 | labelEl.htmlFor = uid; 356 | labelEl.appendChild(document.createTextNode(label)); 357 | container.appendChild(labelEl); 358 | } 359 | 360 | // update to reflect the given list 361 | function setList(list) { 362 | var content = document.createElement("div"); 363 | content.id = uid; 364 | content.className = "flare-input-list"; 365 | 366 | var flare = listUi(list)(); // UI missing +/- buttons at top 367 | flare.value1.subscribe(function(val) { send(val)(); }); 368 | 369 | // always add plusButton, even for empty lists 370 | var plusButton = document.createElement("button"); 371 | plusButton.appendChild(document.createTextNode("+")); 372 | plusButton.addEventListener("click", function () { 373 | setList(prependDefault(flare.value1.get())); 374 | }); 375 | content.appendChild(plusButton); 376 | 377 | // if list is non-empty, add its UI components and minusButton 378 | if (flare.value0.length > 0) { 379 | // relies on fact that tail UI has a single element 380 | var tailComponent = flare.value0.pop(); 381 | var headComponents = flare.value0; 382 | headComponents.forEach(function (c) { 383 | // display head on same line as +/- buttons 384 | c.style.display = "inline"; 385 | content.appendChild(c); 386 | }); 387 | var minusButton = document.createElement("button"); 388 | minusButton.appendChild(document.createTextNode("-")); 389 | minusButton.addEventListener("click", function () { 390 | setList(flare.value1.get().value1); // remove head of list 391 | }); 392 | content.appendChild(minusButton); 393 | content.appendChild(tailComponent); 394 | } 395 | 396 | // fresh content 397 | var oldContent = document.getElementById(uid); 398 | if (oldContent) container.removeChild(oldContent); 399 | container.appendChild(content); 400 | } 401 | 402 | setList(defaultList); 403 | return container; 404 | }; 405 | }; 406 | }; 407 | }; 408 | }; 409 | }; 410 | 411 | exports.cColor = createComponent("color", 412 | function(initial) { 413 | var input = document.createElement("input"); 414 | input.type = "color"; 415 | input.value = initial; 416 | return input; 417 | }, 418 | "input", 419 | function(t, initial) { 420 | return t.value; 421 | } 422 | ); 423 | 424 | function padNumber(num) { 425 | var str = num.toString(); 426 | if (str.length == 1) { 427 | str = "0" + str; 428 | } 429 | return str; 430 | } 431 | 432 | exports.cDate = createComponent("date", 433 | function(initial) { 434 | var input = document.createElement("input"); 435 | input.type = "date"; 436 | input.value = initial.year.toString() + "-" + 437 | padNumber(initial.month) + "-" + 438 | padNumber(initial.day); 439 | return input; 440 | }, 441 | "input", 442 | function(t, initial) { 443 | var parts = t.value.split("-"); 444 | return { year: parseInt(parts[0], 10), 445 | month: parseInt(parts[1], 10), 446 | day: parseInt(parts[2]) 447 | }; 448 | } 449 | ); 450 | 451 | exports.cTime = createComponent("time", 452 | function(initial) { 453 | var input = document.createElement("input"); 454 | input.type = "time"; 455 | input.value = padNumber(initial.hours.toString()) + ":" + 456 | padNumber(initial.minutes.toString()); 457 | return input; 458 | }, 459 | "input", 460 | function(t, initial) { 461 | var parts = t.value.split(":"); 462 | return { hours: parseInt(parts[0], 10), 463 | minutes: parseInt(parts[1], 10) 464 | }; 465 | } 466 | ); 467 | 468 | // vim: ts=2:sw=2 469 | -------------------------------------------------------------------------------- /src/Flare.purs: -------------------------------------------------------------------------------- 1 | module Flare 2 | ( Flare() 3 | , UI() 4 | , ElementId() 5 | , Label() 6 | , number 7 | , number_ 8 | , numberRange 9 | , numberRange_ 10 | , numberSlider 11 | , numberSlider_ 12 | , innerFlare 13 | , int 14 | , int_ 15 | , intRange 16 | , intRange_ 17 | , intSlider 18 | , intSlider_ 19 | , string 20 | , string_ 21 | , stringPattern 22 | , stringPattern_ 23 | , boolean 24 | , boolean_ 25 | , optional 26 | , optional_ 27 | , button 28 | , buttons 29 | , select 30 | , select_ 31 | , radioGroup 32 | , radioGroup_ 33 | , textarea 34 | , textarea_ 35 | , color 36 | , color_ 37 | , date 38 | , date_ 39 | , time 40 | , time_ 41 | , fieldset 42 | , resizableList 43 | , resizableList_ 44 | , applyUIFlipped 45 | , (<**>) 46 | , wrap 47 | , lift 48 | , liftSF 49 | , foldp 50 | , foldEffect 51 | , setupFlare 52 | , flareWith 53 | , runFlareWith 54 | , runFlare 55 | , runFlareShow 56 | ) where 57 | 58 | import Prelude 59 | 60 | import Color (Color, toHexString, fromHexString) 61 | import Control.Apply (lift2) 62 | import Data.Array (fromFoldable) 63 | import Data.Date (Date, exactDate) 64 | import Data.Date as Date 65 | import Data.Enum (toEnum, fromEnum) 66 | import Data.Foldable (class Foldable, traverse_, foldMap) 67 | import Data.List (List(..), (:)) 68 | import Data.Maybe (Maybe(..), fromMaybe) 69 | import Data.Maybe.First (First(..)) 70 | import Data.Newtype (unwrap) 71 | import Data.NonEmpty (NonEmpty, (:|)) 72 | import Data.Time (Time(..)) 73 | import Data.Traversable (class Traversable, traverse) 74 | import Data.Tuple (Tuple(..)) 75 | import Effect (Effect) 76 | import Signal as S 77 | import Signal.Channel (subscribe, send, channel) 78 | import Signal.Effect as SE 79 | import Web.DOM (Element) 80 | 81 | type ElementId = String 82 | type Label = String 83 | 84 | -- | A `Flare` is a `Signal` with a corresponding list of HTML elements 85 | -- | for the user interface components. 86 | data Flare a = Flare (Array Element) (S.Signal a) 87 | 88 | instance functorFlare :: Functor Flare where 89 | map f (Flare cs sig) = Flare cs (map f sig) 90 | 91 | instance applyFlare :: Apply Flare where 92 | apply (Flare cs1 sig1) (Flare cs2 sig2) = Flare (cs1 <> cs2) (sig1 <*> sig2) 93 | 94 | instance applicativeFlare :: Applicative Flare where 95 | pure x = Flare [] (pure x) 96 | 97 | -- | The main data type for a Flare UI. It encapsulates the `Effect` action 98 | -- | which is to be run when setting up the input elements and corresponding 99 | -- | signals. 100 | newtype UI a = UI (Effect (Flare a)) 101 | 102 | instance functorUI :: Functor UI where 103 | map f (UI a) = UI $ map (map f) a 104 | 105 | instance applyUI :: Apply UI where 106 | apply (UI a1) (UI a2) = UI $ lift2 apply a1 a2 107 | 108 | instance applicativeUI :: Applicative UI where 109 | pure x = UI $ pure (pure x) 110 | 111 | instance semigroupUI :: (Semigroup a) => Semigroup (UI a) where 112 | append = lift2 append 113 | 114 | instance monoidUI :: (Monoid a) => Monoid (UI a) where 115 | mempty = pure mempty 116 | 117 | -- | Remove all children from a given parent element. 118 | foreign import removeChildren :: ElementId -> Effect Unit 119 | 120 | -- | Append a child element to the parent with the specified ID. 121 | foreign import appendComponent :: ElementId -> Element -> Effect Unit 122 | 123 | foreign import createInnerElementP :: forall a. (ElementId -> Element -> a) -> Effect a 124 | 125 | createInnerElement :: Effect (Tuple ElementId Element) 126 | createInnerElement = createInnerElementP Tuple 127 | 128 | -- | Set the inner HTML of the specified element to the given value. 129 | foreign import renderString :: ElementId -> String -> Effect Unit 130 | 131 | type CreateComponent a = Label 132 | -> a 133 | -> (a -> Effect Unit) 134 | -> Effect Element 135 | 136 | foreign import cNumber :: CreateComponent Number 137 | foreign import cNumberRange :: String -> Number -> Number -> Number -> CreateComponent Number 138 | foreign import cIntRange :: String -> Int -> Int -> CreateComponent Int 139 | foreign import cString :: CreateComponent String 140 | foreign import cStringPattern :: String -> CreateComponent String 141 | foreign import cBoolean :: CreateComponent Boolean 142 | foreign import cButton :: forall a. a -> CreateComponent a 143 | foreign import cSelect :: forall a. Array a -> (a -> String) -> CreateComponent a 144 | foreign import cRadioGroup :: forall a. Array a -> (a -> String) -> CreateComponent a 145 | foreign import cTextarea :: CreateComponent String 146 | foreign import cColor :: CreateComponent String 147 | 148 | type DateRec = { year :: Int, month :: Int, day :: Int } 149 | type TimeRec = { hours :: Int, minutes :: Int } 150 | 151 | foreign import cDate :: CreateComponent DateRec 152 | foreign import cTime :: CreateComponent TimeRec 153 | 154 | -- | Set up the HTML element for a given component and create the corresponding 155 | -- | signal channel. 156 | createUI :: forall a. (CreateComponent a) -> Label -> a -> UI a 157 | createUI createComp label default = UI $ do 158 | chan <- channel default 159 | comp <- createComp label default (send chan) 160 | let signal = subscribe chan 161 | pure $ Flare [comp] signal 162 | 163 | -- | Creates an input field for a `Number` from a given label and default 164 | -- | value. 165 | number :: Label -> Number -> UI Number 166 | number = createUI cNumber 167 | 168 | -- | Like `number`, but without a label. 169 | number_ :: Number -> UI Number 170 | number_ = number "" 171 | 172 | -- | Creates an input field for a `Number` from a given label, 173 | -- | minimum value, maximum value, step size as well as default value. 174 | -- | The returned value is guaranteed to be within the given range. 175 | numberRange :: Label -> Number -> Number -> Number -> Number -> UI Number 176 | numberRange label min max step default = createUI (cNumberRange "number" min max step) label default 177 | 178 | -- | Like `numberRange`, but without a label. 179 | numberRange_ :: Number -> Number -> Number -> Number -> UI Number 180 | numberRange_ = numberRange "" 181 | 182 | -- | Creates a slider for a `Number` input from a given label, 183 | -- | minimum value, maximum value, step size as well as default value. 184 | numberSlider :: Label -> Number -> Number -> Number -> Number -> UI Number 185 | numberSlider label min max step default = createUI (cNumberRange "range" min max step) label default 186 | 187 | -- | Like `numberSlider`, but without a label. 188 | numberSlider_ :: Number -> Number -> Number -> Number -> UI Number 189 | numberSlider_ = numberSlider "" 190 | 191 | -- | Creates an input field for an `Int` from a given label and default 192 | -- | value. The returned value is guaranteed to be within the allowed integer 193 | -- | range. 194 | int :: Label -> Int -> UI Int 195 | int label = createUI (cIntRange "number" bottom top) label 196 | 197 | -- | Like `int`, but without a label. 198 | int_ :: Int -> UI Int 199 | int_ = int "" 200 | 201 | -- | Creates an input field for an `Int` from a given label, minimum and 202 | -- | maximum values as well as a default value. The returned value is 203 | -- | guaranteed to be within the given range. 204 | intRange :: Label -> Int -> Int -> Int -> UI Int 205 | intRange label min max default = createUI (cIntRange "number" min max) label default 206 | 207 | -- | Like `intRange`, but without a label. 208 | intRange_ :: Int -> Int -> Int -> UI Int 209 | intRange_ = intRange "" 210 | 211 | -- | Creates a slider for an `Int` input from a given label, minimum and 212 | -- | maximum values as well as a default value. 213 | intSlider :: Label -> Int -> Int -> Int -> UI Int 214 | intSlider label min max default = createUI (cIntRange "range" min max) label default 215 | 216 | -- | Like `intSlider`, but without a label. 217 | intSlider_ :: Int -> Int -> Int -> UI Int 218 | intSlider_ = intSlider "" 219 | 220 | -- | Creates a text field for a `String` input from a given label and default 221 | -- | value. 222 | string :: Label -> String -> UI String 223 | string = createUI cString 224 | 225 | -- | Like `string`, but without a label. 226 | string_ :: String -> UI String 227 | string_ = string "" 228 | 229 | -- | Creates a text field for a `String` input from a given label, validation 230 | -- | pattern (HTML5 `pattern` attribute), and a default value. 231 | stringPattern :: Label -> String -> String -> UI String 232 | stringPattern label pattern default = createUI (cStringPattern pattern) label default 233 | 234 | -- | Like `stringPattern`, but without a label. 235 | stringPattern_ :: String -> String -> UI String 236 | stringPattern_ = stringPattern "" 237 | 238 | -- | Creates a checkbox for a `Boolean` input from a given label and default 239 | -- | value. 240 | boolean :: Label -> Boolean -> UI Boolean 241 | boolean = createUI cBoolean 242 | 243 | -- | Like `boolean`, but without a label. 244 | boolean_ :: Boolean -> UI Boolean 245 | boolean_ = boolean "" 246 | 247 | -- | Creates a checkbox that returns `Just x` if enabled and `Nothing` if 248 | -- | disabled. Takes a label, the initial state (enabled or disabled) and 249 | -- | the default value `x`. 250 | optional :: forall a. Label -> Boolean -> a -> UI (Maybe a) 251 | optional label enabled x = ret <$> boolean label enabled 252 | where ret true = (Just x) 253 | ret false = Nothing 254 | 255 | -- | Like `optional`, but without a label. 256 | optional_ :: forall a. Boolean -> a -> UI (Maybe a) 257 | optional_ = optional "" 258 | 259 | -- | Creates a button which yields the first value in the default state and 260 | -- | the second value when it is pressed. 261 | button :: forall a. Label -> a -> a -> UI a 262 | button label vDefault vPressed = createUI (cButton vPressed) label vDefault 263 | 264 | -- | Create a button for each element of the given container. The whole 265 | -- | component returns `Nothing` if none of the buttons is pressed and `Just x` 266 | -- | if the button corresponding to the element `x` is pressed. 267 | buttons :: forall f a. Traversable f => f a -> (a -> String) -> UI (Maybe a) 268 | buttons xs toString = (unwrap <<< foldMap First) <$> traverse toButton xs 269 | where 270 | toButton :: a -> UI (Maybe a) 271 | toButton x = button (toString x) Nothing (Just x) 272 | 273 | -- | Creates a select box to choose from a list of options. The first option 274 | -- | is selected by default. The rest of the options is given as an array. 275 | select :: forall f a. Foldable f => Label -> NonEmpty f a -> (a -> String) -> UI a 276 | select label (default :| xs) toString = 277 | createUI (cSelect (fromFoldable xs) toString) label default 278 | 279 | -- | Like `select`, but without a label. 280 | select_ :: forall f a. Foldable f => NonEmpty f a -> (a -> String) -> UI a 281 | select_ = select "" 282 | 283 | -- | Creates a group of radio buttons to choose from a list of options. The 284 | -- | first option is selected by default. The rest of the options is given as 285 | -- | an array. 286 | radioGroup :: forall f a. Foldable f => Label -> NonEmpty f a -> (a -> String) -> UI a 287 | radioGroup label (default :| xs) toString = 288 | createUI (cRadioGroup (fromFoldable xs) toString) label default 289 | 290 | -- | Like `radioGroup`, but without a label. 291 | radioGroup_ :: forall f a. Foldable f => NonEmpty f a -> (a -> String) -> UI a 292 | radioGroup_ = radioGroup "" 293 | 294 | -- | Creates a textarea field for a `String` input from a given label and 295 | -- | default value. 296 | textarea :: Label -> String -> UI String 297 | textarea = createUI cTextarea 298 | 299 | -- | Like `textarea`, but without a label. 300 | textarea_ :: String -> UI String 301 | textarea_ = textarea "" 302 | 303 | -- | Creates a color picker input field from a label and default `Color`. 304 | color :: Label -> Color -> UI Color 305 | color label default = (fromMaybe default <<< fromHexString) <$> 306 | createUI cColor label (toHexString default) 307 | 308 | -- | Like `color`, but without a label. 309 | color_ :: Color -> UI Color 310 | color_ = color "" 311 | 312 | -- | Creates a date input field from a label and default `Date`. 313 | date :: Label -> Date -> UI Date 314 | date label default = (fromMaybe default <<< toDate) <$> 315 | createUI cDate label { year: fromEnum (Date.year default) 316 | , month: fromEnum (Date.month default) 317 | , day: fromEnum (Date.day default) 318 | } 319 | where 320 | toDate :: DateRec -> Maybe Date 321 | toDate { year, month, day } = do 322 | y <- toEnum year 323 | m <- toEnum month 324 | d <- toEnum day 325 | exactDate y m d 326 | 327 | -- | Like `date`, but without a label. 328 | date_ :: Date -> UI Date 329 | date_ = date "" 330 | 331 | -- | Creates a time input field from a label and default `Time`. 332 | time :: Label -> Time -> UI Time 333 | time label default = (fromMaybe default <<< toTime) <$> 334 | createUI cTime label { hours: 0, minutes: 30 } 335 | where 336 | toTime :: TimeRec -> Maybe Time 337 | toTime { hours, minutes } = Time <$> toEnum hours 338 | <*> toEnum minutes 339 | <*> toEnum 0 340 | <*> toEnum 0 341 | 342 | -- | Like `time`, but without a label. 343 | time_ :: Time -> UI Time 344 | time_ = time "" 345 | 346 | foreign import toFieldset :: Label -> Array Element -> Element 347 | 348 | -- | Group the components of a UI inside a fieldset element with a given title. 349 | fieldset :: forall a. Label -> UI a -> UI a 350 | fieldset label (UI setup) = UI $ do 351 | (Flare cs sig) <- setup 352 | pure $ Flare [toFieldset label cs] sig 353 | 354 | foreign import cResizableList :: forall a. (List a -> List a) 355 | -> (List a -> UI (List a)) 356 | -> CreateComponent (List a) 357 | 358 | -- | Creates a resizable `List a` input given a way to construct `a` UIs, a 359 | -- | default `a`, and a default `List a`. 360 | resizableList :: forall a. Label -> 361 | (a -> UI a) -> 362 | a -> 363 | List a -> 364 | UI (List a) 365 | resizableList label aUi defaultA defaultList = 366 | createUI (cResizableList prependDefault listUi) label defaultList where 367 | prependDefault = Cons defaultA 368 | -- a UI missing +/- buttons at the top (which `cResizableList` then adds) 369 | listUi = case _ of 370 | Nil -> pure Nil 371 | hd : tl -> Cons <$> aUi hd 372 | <*> resizableList "" aUi defaultA tl 373 | 374 | -- | Like `resizableList`, but without a label. 375 | resizableList_ :: forall a. (a -> UI a) -> a -> List a -> UI (List a) 376 | resizableList_ = resizableList "" 377 | 378 | -- | A flipped version of `<*>` for `UI` that arranges the components in the 379 | -- | order of appearance. 380 | applyUIFlipped :: forall a b. UI a -> UI (a -> b) -> UI b 381 | applyUIFlipped (UI setup1) (UI setup2) = UI $ do 382 | (Flare cs1 sig1) <- setup1 383 | (Flare cs2 sig2) <- setup2 384 | pure $ Flare (cs1 <> cs2) (sig2 <*> sig1) 385 | 386 | infixl 4 applyUIFlipped as <**> 387 | 388 | -- | Encapsulate a `Signal` within a `UI` component. 389 | wrap :: forall a. (S.Signal a) -> UI a 390 | wrap sig = UI $ pure $ Flare [] sig 391 | 392 | -- | Lift a `Signal` inside the `Eff` monad to a `UI` component. 393 | lift :: forall a. Effect (S.Signal a) -> UI a 394 | lift msig = UI $ do 395 | sig <- msig 396 | pure $ Flare [] sig 397 | 398 | -- | Lift a function from `Signal a` to `Signal b` to a function from 399 | -- | `UI a` to `UI b` without affecting the components. For example: 400 | -- | 401 | -- | ``` purescript 402 | -- | dropRepeats :: forall a. (Eq a) => UI a -> UI a 403 | -- | dropRepeats = liftSF S.dropRepeats 404 | -- | ``` 405 | liftSF :: forall a b. (S.Signal a -> S.Signal b) 406 | -> UI a 407 | -> UI b 408 | liftSF f (UI setup) = UI do 409 | (Flare comp sig) <- setup 410 | pure $ Flare comp (f sig) 411 | 412 | -- | Create a past dependent component. The fold-function takes the current 413 | -- | value of the component and the previous value of the output to produce 414 | -- | the new value of the output. 415 | foldp :: forall a b. (a -> b -> b) -> b -> UI a -> UI b 416 | foldp f x0 = liftSF (S.foldp f x0) 417 | 418 | -- | Creates a past dependent component with an effectful computation. 419 | -- | The function argument takes the value of the input component, and 420 | -- | the previous value of the output component, to produce the new value 421 | -- | of the output component wrapped inside an Effect action. 422 | foldEffect :: forall a b. (a -> b -> Effect b) -> b -> UI a -> UI b 423 | foldEffect f b (UI eff) = lift $ do 424 | (Flare _ signal) <- eff 425 | SE.foldEffect f b signal 426 | 427 | -- | Low level function to get direct access to the HTML elements and the 428 | -- | `Signal` inside a Flare UI. 429 | setupFlare :: forall a. UI a 430 | -> Effect { components :: Array Element 431 | , signal :: S.Signal a } 432 | setupFlare (UI setupUI) = do 433 | (Flare components signal) <- setupUI 434 | pure { components, signal } 435 | 436 | -- | Renders a Flare UI to the DOM and sets up all event handlers. The ID 437 | -- | specifies the HTML element to which the controls are attached. The 438 | -- | handler function argument handles the `Signal` inside the `Flare`. 439 | flareWith :: forall a. ElementId 440 | -> (S.Signal a -> Effect Unit) 441 | -> UI a 442 | -> Effect Unit 443 | flareWith controls handler (UI setupUI) = do 444 | (Flare components signal) <- setupUI 445 | removeChildren controls 446 | traverse_ (appendComponent controls) components 447 | handler signal 448 | 449 | -- | Renders an UI with access to the current value. 450 | innerFlare :: forall a b. UI a 451 | -> (a -> UI b) 452 | -> UI b 453 | innerFlare (UI setupUI) innerUI = UI $ do 454 | (Flare components signal) <- setupUI 455 | -- Get the initial value for the resulting signal 456 | UI setupInnerUI <- innerUI <$> S.get signal 457 | (Flare _ innerSignal) <- setupInnerUI 458 | initialInner <- S.get innerSignal 459 | innerResult <- channel initialInner 460 | -- Set up the inner UI 461 | Tuple innerHostId innerHost <- createInnerElement 462 | let setupInner = innerUI >>> flareWith innerHostId (map (send innerResult) >>> S.runSignal) 463 | S.runSignal $ setupInner <$> signal 464 | pure $ Flare (components <> [innerHost]) (subscribe innerResult) 465 | 466 | -- | Renders a Flare UI to the DOM and sets up all event handlers. The ID 467 | -- | specifies the HTML element to which the controls are attached. The 468 | -- | function argument will be mapped over the `Signal` inside the `Flare`. 469 | runFlareWith :: forall a. ElementId 470 | -> (a -> Effect Unit) 471 | -> UI a 472 | -> Effect Unit 473 | runFlareWith controls handler ui = flareWith controls (S.runSignal <<< map handler) ui 474 | 475 | -- | Renders a Flare UI to the DOM and sets up all event handlers. The two IDs 476 | -- | specify the DOM elements to which the controls and the output will be 477 | -- | attached, respectively. 478 | runFlare :: ElementId 479 | -> ElementId 480 | -> UI String 481 | -> Effect Unit 482 | runFlare controls target = runFlareWith controls (renderString target) 483 | 484 | -- | Like `runFlare` but uses `show` to convert the contained value to a 485 | -- | `String` before rendering to the DOM (useful for testing). 486 | runFlareShow :: forall a. (Show a) 487 | => ElementId 488 | -> ElementId 489 | -> UI a 490 | -> Effect Unit 491 | runFlareShow controls target ui = runFlare controls target (show <$> ui) 492 | -------------------------------------------------------------------------------- /src/Flare/Drawing.purs: -------------------------------------------------------------------------------- 1 | module Flare.Drawing 2 | ( runFlareDrawing 3 | , module Graphics.Drawing 4 | ) where 5 | 6 | import Graphics.Drawing 7 | 8 | import Data.Maybe (fromJust) 9 | import Effect (Effect) 10 | import Flare (UI, ElementId, runFlareWith) 11 | import Graphics.Canvas (getCanvasElementById, getContext2D, getCanvasWidth, getCanvasHeight, clearRect) 12 | import Partial.Unsafe (unsafePartial) 13 | import Prelude (Unit, bind) 14 | 15 | -- | Renders a Flare UI with a `Drawing` as output. The first ID specifies 16 | -- | the DOM element for the controls while the second ID specifies the 17 | -- | canvas for rendering. 18 | runFlareDrawing :: ElementId 19 | -> ElementId 20 | -> UI Drawing 21 | -> Effect Unit 22 | runFlareDrawing controls canvasID ui = do 23 | mcanvas <- getCanvasElementById canvasID 24 | let canvas = unsafePartial (fromJust mcanvas) 25 | ctx <- getContext2D canvas 26 | 27 | let render' drawing = do 28 | w <- getCanvasWidth canvas 29 | h <- getCanvasHeight canvas 30 | _ <- clearRect ctx { x: 0.0, y: 0.0, width: w, height: h } 31 | render ctx drawing 32 | 33 | runFlareWith controls render' ui 34 | -------------------------------------------------------------------------------- /src/Flare/Smolder.purs: -------------------------------------------------------------------------------- 1 | module Flare.Smolder 2 | ( runFlareHTML 3 | ) where 4 | 5 | import Prelude 6 | 7 | import Effect (Effect) 8 | import Flare (UI, ElementId, runFlare) 9 | import Text.Smolder.Markup (Markup) 10 | import Text.Smolder.Renderer.String (render) 11 | 12 | -- | Renders a Flare UI with `Markup` as output. The first ID specifies 13 | -- | the DOM element for the controls while the second ID specifies the 14 | -- | element for the output. 15 | runFlareHTML :: forall e. ElementId 16 | -> ElementId 17 | -> UI (Markup e) 18 | -> Effect Unit 19 | runFlareHTML controls target = 20 | runFlare controls target <<< map render 21 | -------------------------------------------------------------------------------- /test/Main.purs: -------------------------------------------------------------------------------- 1 | module Test.Main where 2 | 3 | import Prelude 4 | 5 | import Control.Apply (lift2) 6 | import Data.Array (cons, (..), length, zipWith) 7 | import Data.Date (canonicalDate, diff) 8 | import Data.Enum (toEnum) 9 | import Data.Foldable (foldMap, sum, traverse_) 10 | import Data.Int (toNumber, round) 11 | import Data.List (List(..), (:)) 12 | import Data.Maybe (maybe, fromMaybe) 13 | import Data.Newtype (un) 14 | import Data.NonEmpty ((:|)) 15 | import Data.String (take) 16 | import Data.Time.Duration (Days(..)) 17 | import Data.Traversable (traverse) 18 | import Effect (Effect) 19 | import Flare (UI, runFlareShow, runFlare, button, liftSF, buttons, foldp, select, intSlider, numberSlider, string, innerFlare, intSlider_, boolean_, lift, color, number_, int_, string_, number, (<**>), date, resizableList) 20 | import Color (rgb, hsl, cssStringHSLA, black) 21 | import Flare.Drawing (Color, Drawing, runFlareDrawing, path, lineWidth, outlineColor, outlined, fillColor, filled, circle) 22 | import Flare.Smolder (runFlareHTML) 23 | import Math (pow, sin, cos, pi, abs) 24 | import Signal.DOM (animationFrame) 25 | import Signal.Time (since) 26 | import Text.Smolder.HTML (div, li, ul, table, td, tr) as H 27 | import Text.Smolder.HTML.Attributes as A 28 | import Text.Smolder.Markup (Markup, with, text) as H 29 | 30 | -- Example 1 31 | 32 | ui1 :: UI Number 33 | ui1 = pow <$> number "Base" 2.0 34 | <*> number "Exponent" 10.0 35 | 36 | -- Example 2 37 | 38 | ui2 :: UI String 39 | ui2 = string_ "Hello" <> pure " " <> string_ "World" 40 | 41 | -- Example 3 42 | 43 | ui3 :: UI Int 44 | ui3 = sum <$> traverse int_ [2, 13, 27, 42] 45 | 46 | -- Example 4 47 | 48 | ui4 :: UI Number 49 | ui4 = lift2 (/) (number_ 5.0) (number_ 2.0) 50 | 51 | -- Example 5 52 | 53 | coloredCircle :: Number -> Number -> Drawing 54 | coloredCircle hue radius = 55 | filled (fillColor (hsl hue 0.8 0.4)) (circle 50.0 50.0 radius) 56 | 57 | ui5 :: UI Drawing 58 | ui5 = coloredCircle <$> (numberSlider "Hue" 0.0 360.0 1.0 140.0) 59 | <*> (numberSlider "Radius" 2.0 45.0 0.1 25.0) 60 | 61 | -- Example 6 62 | 63 | data Language = English | French | German 64 | 65 | toString :: Language -> String 66 | toString English = "english" 67 | toString French = "french" 68 | toString German = "german" 69 | 70 | greet :: Language -> String 71 | greet English = "Hello" 72 | greet French = "Salut" 73 | greet German = "Hallo" 74 | 75 | ui6 :: UI String 76 | ui6 = (greet <$> (select "Language" (English :| [French, German]) toString)) 77 | <> pure " " <> string "Name" "Pierre" <> pure "!" 78 | 79 | -- Example 7 80 | 81 | plot :: Number -> Number -> Number -> Color -> Number -> Drawing 82 | plot m n1 s col time = 83 | filled (fillColor col) $ 84 | path (map point angles) 85 | 86 | where point phi = { x: 100.0 + radius phi * cos phi 87 | , y: 100.0 + radius phi * sin phi } 88 | angles = map (\i -> 2.0 * pi / toNumber points * toNumber i) 89 | (0 .. points) 90 | points = 400 91 | n2 = s + 3.0 * sin (0.005 * time) 92 | n3 = s + 3.0 * cos (0.005 * time) 93 | radius phi = 20.0 * pow expr (- 1.0 / n1) 94 | where expr = first + second 95 | first = pow (abs (cos (m * phi / 4.0))) n2 96 | second = pow (abs (sin (m * phi / 4.0))) n3 97 | 98 | ui7 :: UI Drawing 99 | ui7 = plot <$> (numberSlider "m" 0.0 10.0 1.0 7.0) 100 | <*> (numberSlider "n1" 1.0 10.0 0.1 4.0) 101 | <*> (numberSlider "s" 4.0 16.0 0.1 14.0) 102 | <*> (color "Color" (hsl 333.0 0.6 0.5)) 103 | <*> lift animationFrame 104 | 105 | -- Example 8 106 | 107 | ui8 :: UI (Array Int) 108 | ui8 = traverse (intSlider_ 1 5) (1..5) 109 | 110 | -- Example 9 111 | 112 | ui9 :: UI Boolean 113 | ui9 = lift2 (&&) (boolean_ false) (boolean_ true) 114 | 115 | -- Example 10 116 | 117 | graph :: Array Number -> Number -> Drawing 118 | graph xs width = outlined (outlineColor black <> lineWidth width) 119 | (path points) 120 | where points = zipWith point xs (1 .. length xs) 121 | point x y = { x, y: toNumber y } 122 | 123 | ui10 :: UI Drawing 124 | ui10 = graph <$> foldp cons [] (numberSlider "Position" 0.0 150.0 1.0 75.0) 125 | <*> numberSlider "Width" 1.0 5.0 0.1 1.0 126 | 127 | -- Example 11 128 | 129 | ui11 :: UI Int 130 | ui11 = foldp (+) 0 (button "Increment" 0 1) 131 | 132 | -- Example 12 133 | 134 | table :: forall m. Int -> Int -> H.Markup m 135 | table h w = H.table $ traverse_ row (0 .. h) 136 | where row i = H.tr $ traverse_ (cell i) (0 .. w) 137 | cell i j = H.td (H.text (show i <> "," <> show j)) 138 | 139 | ui12 :: forall m. UI (H.Markup m) 140 | ui12 = table <$> intSlider_ 0 9 5 <*> intSlider_ 0 9 5 141 | 142 | -- Example 13 143 | 144 | actions :: UI (Array String -> Array String) 145 | actions = string "Add item:" "Orange" <**> button "Add" (flip const) cons 146 | 147 | list :: UI (Array String) 148 | list = foldp identity ["Apple", "Banana"] actions 149 | 150 | ui13 :: forall m. UI (H.Markup m) 151 | ui13 = (H.ul <<< traverse_ (H.li <<< H.text)) <$> list 152 | 153 | -- Example 14 154 | 155 | data Domain = HSL | RGB 156 | 157 | showDomain :: Domain -> String 158 | showDomain HSL = "HSL" 159 | showDomain RGB = "RGB" 160 | 161 | toHTML :: forall m. Color -> H.Markup m 162 | toHTML c = H.div `H.with` (A.style $ "background-color:" <> hex) $ H.text hex 163 | where hex = cssStringHSLA c 164 | 165 | ns :: String -> Number -> Number -> Number -> UI Number 166 | ns l = numberSlider l 0.0 167 | 168 | is :: String -> Int -> UI Int 169 | is l = intSlider l 0 255 170 | 171 | uiColor :: Domain -> UI Color 172 | uiColor HSL = hsl <$> ns "Hue" 360.0 1.0 180.0 173 | <*> ns "Saturation" 1.0 0.01 0.5 174 | <*> ns "Lightness" 1.0 0.01 0.5 175 | uiColor RGB = rgb <$> is "Red" 200 176 | <*> is "Green" 0 177 | <*> is "Blue" 100 178 | 179 | ui14 :: forall m. UI (H.Markup m) 180 | ui14 = toHTML <$> 181 | select "Color domain" (HSL :| [RGB]) showDomain `innerFlare` uiColor 182 | 183 | -- Example 15 184 | 185 | data Action = Increment | Decrement | Negate | Reset 186 | 187 | label :: Action -> String 188 | label Increment = "+ 1" 189 | label Decrement = "- 1" 190 | label Negate = "+/-" 191 | label Reset = "Reset" 192 | 193 | perform :: Action -> Int -> Int 194 | perform Increment = add 1 195 | perform Decrement = flip sub 1 196 | perform Negate = negate 197 | perform Reset = const 0 198 | 199 | ui15 :: UI Int 200 | ui15 = foldp (maybe identity perform) 0 $ 201 | buttons [Increment, Decrement, Negate, Reset] label 202 | 203 | -- Example 16 204 | 205 | light :: forall m. Boolean -> H.Markup m 206 | light on = H.with H.div arg (H.text "") 207 | where arg | on = A.className "on" 208 | | otherwise = mempty 209 | 210 | ui16 :: forall m. UI (H.Markup m) 211 | ui16 = light <$> liftSF (since 1000.0) (button "Switch on" unit unit) 212 | 213 | -- Example 17 214 | 215 | ui17 :: UI String 216 | ui17 = showDiff <$> date "Date 1" (fromMaybe bottom date1) 217 | <*> date "Date 2" (fromMaybe bottom date2) 218 | where 219 | date1 = canonicalDate <$> toEnum 1986 <*> toEnum 7 <*> toEnum 3 220 | date2 = canonicalDate <$> toEnum 2016 <*> toEnum 8 <*> toEnum 5 221 | showDiff d1 d2 = "Days between the dates: " <> show (round $ abs $ un Days $ diff d1 d2) 222 | 223 | -- Example 18 224 | 225 | ui18 :: UI String 226 | ui18 = acronym <$> resizableList "Words" string_ "Really" defaultList 227 | where 228 | defaultList = "Don't" : "Repeat" : "Yourself" : Nil 229 | acronym xs = "Acronym: " <> foldMap (take 1) xs 230 | 231 | -- Render everything to the DOM 232 | 233 | main :: Effect Unit 234 | main = do 235 | runFlareShow "controls1" "output1" ui1 236 | runFlare "controls2" "output2" ui2 237 | runFlareShow "controls3" "output3" ui3 238 | runFlareShow "controls4" "output4" ui4 239 | runFlareDrawing "controls5" "output5" ui5 240 | runFlare "controls6" "output6" ui6 241 | runFlareDrawing "controls7" "output7" ui7 242 | runFlareShow "controls8" "output8" ui8 243 | runFlareShow "controls9" "output9" ui9 244 | runFlareDrawing "controls10" "output10" ui10 245 | runFlareHTML "controls12" "output12" ui12 246 | runFlareShow "controls11" "output11" ui11 247 | runFlareHTML "controls13" "output13" ui13 248 | runFlareHTML "controls14" "output14" ui14 249 | runFlareShow "controls15" "output15" ui15 250 | runFlareHTML "controls16" "output16" ui16 251 | runFlare "controls17" "output17" ui17 252 | runFlare "controls18" "output18" ui18 253 | --------------------------------------------------------------------------------