Purescript Pha - Example

├── src └── Pha │ ├── Html │ ├── Events.js │ ├── Util.purs │ ├── Keyed.purs │ ├── Core.js │ ├── Attributes.purs │ ├── Elements.purs │ ├── Core.purs │ └── Events.purs │ ├── Html.purs │ ├── App │ ├── Internal.purs │ └── Internal.js │ ├── Update.purs │ ├── Util.js │ ├── Util.purs │ ├── Subscriptions.purs │ ├── Svg.purs │ ├── Svg │ └── Attributes.purs │ ├── Update │ └── Internal.purs │ └── App.purs ├── test.dhall ├── packages.dhall ├── .gitignore ├── examples ├── dist │ ├── ex-counter2.html │ └── bundle.css ├── Counter.purs └── Counter2.purs ├── package.json ├── spago.dhall ├── LICENSE └── README.md /src/Pha/Html/Events.js: -------------------------------------------------------------------------------- 1 | export const valueImpl = (el, nothing, just) => 2 | typeof el.value === "string" ? just(el.value) : nothing -------------------------------------------------------------------------------- /test.dhall: -------------------------------------------------------------------------------- 1 | let conf = ./spago.dhall 2 | in conf // { 3 | sources = conf.sources # [ "examples/**/*.purs" ], 4 | backend = "purs-backend-es build", 5 | dependencies = conf.dependencies # ["arrays", "integers"] 6 | } -------------------------------------------------------------------------------- /packages.dhall: -------------------------------------------------------------------------------- 1 | let upstream = 2 | https://github.com/purescript/package-sets/releases/download/psc-0.15.12-20231104/packages.dhall 3 | sha256:79344f3278e5c29920e693ee057ea75347755c019f6fe28fb8a0e06de2a85bfc 4 | 5 | in upstream 6 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | /bower_components/ 2 | /node_modules/ 3 | /.pulp-cache/ 4 | /output/ 5 | /output-es/ 6 | /generated-docs/ 7 | /.psc-package/ 8 | /.psc* 9 | /.purs* 10 | /.psa* 11 | /.spago 12 | /yarn.lock 13 | /package-lock.json 14 | /examples/dist/bundle-counter2.js 15 | -------------------------------------------------------------------------------- /examples/dist/ex-counter2.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | Purescript Pha - Example 7 | 8 | 9 | 10 | 11 |

12 | 13 | 14 | -------------------------------------------------------------------------------- /src/Pha/Html.purs: -------------------------------------------------------------------------------- 1 | module Pha.Html (module Export) where 2 | 3 | import Pha.Html.Core (Event, EventHandler, Prop, Html, attr, class', class_, empty, fromMaybe, elem, keyed, lazy, lazy2, lazy3, lazy4, lazy5, maybe, on_, noProp, prop, style, text, when) as Export 4 | import Pha.Html.Elements (a, br, button, div, footer, form, h1, h2, h3, h4, h5, h6, header, hr, img, input, label, li, main, nav, ol, option, p, section, select, span, table, td, textarea, tr, ul) as Export 5 | -------------------------------------------------------------------------------- /package.json: -------------------------------------------------------------------------------- 1 | { 2 | "dependencies": { 3 | "esbuild": "^0.19.5", 4 | "purescript": "^0.15.12", 5 | "purescript-psa": "^0.8.2", 6 | "purs-backend-es": "^1.4.2", 7 | "spago": "^0.21.0" 8 | }, 9 | "scripts": { 10 | "clean": "rimraf output && rimraf .spago", 11 | "build": "spago build --purs-args '--censor-lib --strict'", 12 | "example-counter2": "spago -x test.dhall build && purs-backend-es bundle-app --no-build -m Example.Counter2 --to examples/dist/bundle-counter2.js" 13 | } 14 | } 15 | -------------------------------------------------------------------------------- /src/Pha/App/Internal.purs: -------------------------------------------------------------------------------- 1 | module Pha.App.Internal where 2 | import Prelude 3 | import Effect.Uncurried (EffectFn1, EffectFn2, EffectFn5) 4 | import Pha.Html.Core (Html, Event, EventHandler) 5 | import Web.Event.EventTarget (EventTarget) 6 | import Web.DOM.Node (Node) 7 | 8 | foreign import getAction ∷ ∀msg. EffectFn2 EventTarget String (EventHandler msg) 9 | foreign import unsafePatch ∷ ∀msg. EffectFn5 Node Node (Html msg) (Html msg) (EffectFn1 Event Unit) Node 10 | foreign import copyVNode ∷ ∀msg. Html msg → Html msg 11 | foreign import unsafeLinkNode ∷ ∀msg. Node → Html msg → Html msg -------------------------------------------------------------------------------- /src/Pha/Update.purs: -------------------------------------------------------------------------------- 1 | module Pha.Update 2 | ( delay 3 | , module I 4 | , module Exports 5 | ) where 6 | 7 | import Prelude 8 | import Pha.Update.Internal (Subscription, SubscriptionId, Update, hoist, mapMessage, mapModel, subscribe, unsubscribe) as I 9 | import Control.Monad.State.Class (get, gets, put, modify, modify_) as Exports 10 | import Effect.Aff (Milliseconds) 11 | import Effect.Aff as Aff 12 | import Effect.Aff.Class (class MonadAff, liftAff) 13 | import Effect.Aff (Milliseconds(..)) as Exports 14 | import Effect.Aff.Class (liftAff) as Exports 15 | import Effect.Class (liftEffect) as Exports 16 | 17 | delay ∷ ∀model msg m. MonadAff m ⇒ Milliseconds → I.Update model msg m Unit 18 | delay = liftAff <<< Aff.delay 19 | -------------------------------------------------------------------------------- /examples/dist/bundle.css: -------------------------------------------------------------------------------- 1 | .counter { 2 | width: 5rem; 3 | height: 2rem; 4 | background-color: snow; 5 | border: solid black thick; 6 | } 7 | 8 | .box { 9 | width: 5rem; 10 | height: 5rem; 11 | background-color: snow; 12 | border: solid black thick; 13 | } 14 | 15 | .box.even { 16 | background-color: green; 17 | } 18 | 19 | .puzzle { 20 | position: relative; 21 | width: 12rem; 22 | height: 12rem; 23 | } 24 | 25 | .puzzle-item { 26 | position: absolute; 27 | transition: all 500ms linear; 28 | width: 25%; 29 | height: 25%; 30 | background-color: yellow; 31 | border: solid grey thin; 32 | text-align: center; 33 | vertical-align: center; 34 | } -------------------------------------------------------------------------------- /spago.dhall: -------------------------------------------------------------------------------- 1 | {- 2 | Welcome to a Spago project! 3 | You can edit this file as you like. 4 | -} 5 | { name = "pha" 6 | , license = "MIT" 7 | , dependencies = 8 | [ "aff" 9 | , "bifunctors" 10 | , "effect" 11 | , "foldable-traversable" 12 | , "free" 13 | , "functions" 14 | , "maybe" 15 | , "ordered-collections" 16 | , "prelude" 17 | , "profunctor-lenses" 18 | , "refs" 19 | , "tailrec" 20 | , "transformers" 21 | , "tuples" 22 | , "unsafe-coerce" 23 | , "unsafe-reference" 24 | , "web-dom" 25 | , "web-events" 26 | , "web-html" 27 | , "web-pointerevents" 28 | , "web-uievents" 29 | ] 30 | , packages = ./packages.dhall 31 | , repository = "https://github.com/gbagan/purescript-pha" 32 | , sources = [ "src/**/*.purs" ] 33 | } 34 | -------------------------------------------------------------------------------- /examples/Counter.purs: -------------------------------------------------------------------------------- 1 | module Example.Counter where 2 | import Prelude 3 | import Effect (Effect) 4 | import Pha.Html (Html) 5 | import Pha.App (sandbox) 6 | import Pha.Html as H 7 | import Pha.Html.Events as E 8 | 9 | type State = Int 10 | data Msg = Increment | Decrement 11 | 12 | init ∷ State 13 | init = 0 14 | 15 | update ∷ Msg → State → State 16 | update Increment n = n + 1 17 | update Decrement n = n - 1 18 | 19 | view ∷ State → Html Msg 20 | view counter = 21 | H.div [] 22 | [ H.button [E.onClick \_ → Decrement] [H.text "-"] 23 | , H.span [] [H.text $ show counter] 24 | , H.button [E.onClick \_ → Increment] [H.text "+"] 25 | ] 26 | 27 | main ∷ Effect Unit 28 | main = sandbox {init, update, view, selector: "#root"} -------------------------------------------------------------------------------- /src/Pha/Html/Util.purs: -------------------------------------------------------------------------------- 1 | module Pha.Html.Util 2 | where 3 | 4 | import Prelude 5 | 6 | import Pha.Svg.Attributes (class IsLength, toString) 7 | 8 | -- | 63.7 → "63.7px" 9 | px ∷ Number → String 10 | px a = show a <> "px" 11 | 12 | -- | 63 → 63.px 13 | px' ∷ Int → String 14 | px' a = show a <> "px" 15 | 16 | -- | 0.7 → "70%" 17 | pc ∷ Number → String 18 | pc a = show (100.0 * a) <> "%" 19 | 20 | -- | translate (px 40.0) (px 30.0) → "translate(40px,30px)" 21 | translate ∷ forall x y. IsLength x => IsLength y => x → y → String 22 | translate x y = "translate(" <> toString x <> "," <> toString y <> ")" 23 | 24 | -- | rgbColor 128 64 30 → "rgb(128,64,30)" 25 | rgbColor ∷ Int → Int → Int → String 26 | rgbColor r g' b = "rgb(" <> show r <> "," <> show g' <> "," <> show b <> ")" -------------------------------------------------------------------------------- /src/Pha/Util.js: -------------------------------------------------------------------------------- 1 | const objEq = (a, b) => { 2 | if (a === undefined) 3 | return false 4 | for (let x in a) 5 | if (a[x] !== b[x]) 6 | return false 7 | return true 8 | } 9 | 10 | export const memoizeImpl = f => g => { 11 | let u = undefined; 12 | let a = undefined; 13 | let res = undefined; 14 | return v => { 15 | if (u === v) 16 | return res 17 | u = v; 18 | const b = f(v); 19 | if (a === b) 20 | return res; 21 | a = b; 22 | res = g(b); 23 | return res; 24 | } 25 | } 26 | 27 | export const memoizeObj = f => g => { 28 | let u = undefined; 29 | let a = undefined; 30 | let res = undefined; 31 | return v => { 32 | if (u === v) 33 | return res; 34 | u = v; 35 | const b = f(v); 36 | if (objEq(a, b)) 37 | return res; 38 | a = b; 39 | res = g(b); 40 | return res; 41 | } 42 | } -------------------------------------------------------------------------------- /src/Pha/Util.purs: -------------------------------------------------------------------------------- 1 | module Pha.Util (memoize, memoCompose, memoCompose2, memoCompose3, memoCompose') where 2 | 3 | import Prelude 4 | 5 | foreign import memoizeImpl :: forall a b c. (a -> b) -> (b -> c) -> a -> c 6 | foreign import memoizeObj :: forall a b c. (a -> b) -> (b -> c) -> a -> c 7 | 8 | -- | Memoize the function f. 9 | -- | If the argument of f differs from the previous call, then f is recomputed. 10 | memoize :: forall a b. (a -> b) -> a -> b 11 | memoize = memoizeImpl identity 12 | 13 | -- | Memoize the composition of two functions 14 | memoCompose :: forall a b c. (a -> b) -> (b -> c) -> a -> c 15 | memoCompose = memoizeImpl 16 | 17 | memoCompose2 :: forall a b c d. (a -> b) -> (a -> c) -> (b -> c -> d) -> a -> d 18 | memoCompose2 f g h = memoCompose' (\v -> {a: f v, b: g v}) \{a, b} -> h a b 19 | 20 | memoCompose3 :: forall a b c d e. (a -> b) -> (a -> c) -> (a -> d) -> (b -> c -> d -> e) -> a -> e 21 | memoCompose3 f g h l = memoCompose' (\v -> {a: f v, b: g v, c: h v}) \{a, b, c} -> l a b c 22 | 23 | memoCompose' :: forall a b c. (a -> Record b) -> (Record b -> c) -> a -> c 24 | memoCompose' = memoizeObj -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2019 Guillaume Bagan 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /src/Pha/Html/Keyed.purs: -------------------------------------------------------------------------------- 1 | module Pha.Html.Keyed where 2 | 3 | import Pha.Html.Core (Html, KeyedHtml, Prop, keyed) 4 | 5 | a ∷ ∀msg. Array (Prop msg) → Array (KeyedHtml msg) → Html msg 6 | a = keyed "a" 7 | 8 | button ∷ ∀msg. Array (Prop msg) → Array (KeyedHtml msg) → Html msg 9 | button = keyed "button" 10 | 11 | div ∷ ∀msg. Array (Prop msg) → Array (KeyedHtml msg) → Html msg 12 | div = keyed "div" 13 | 14 | footer ∷ ∀msg. Array (Prop msg) → Array (KeyedHtml msg) → Html msg 15 | footer = keyed "footer" 16 | 17 | form ∷ ∀msg. Array (Prop msg) → Array (KeyedHtml msg) → Html msg 18 | form = keyed "form" 19 | 20 | header ∷ ∀msg. Array (Prop msg) → Array (KeyedHtml msg) → Html msg 21 | header = keyed "header" 22 | 23 | li ∷ ∀msg. Array (Prop msg) → Array (KeyedHtml msg) → Html msg 24 | li = keyed "li" 25 | 26 | p ∷ ∀msg. Array (Prop msg) → Array (KeyedHtml msg) → Html msg 27 | p = keyed "p" 28 | 29 | main ∷ ∀msg. Array (Prop msg) → Array (KeyedHtml msg) → Html msg 30 | main = keyed "main" 31 | 32 | menu ∷ ∀msg. Array (Prop msg) → Array (KeyedHtml msg) → Html msg 33 | menu = keyed "menu" 34 | 35 | nav ∷ ∀msg. Array (Prop msg) → Array (KeyedHtml msg) → Html msg 36 | nav = keyed "nav" 37 | 38 | ol ∷ ∀msg. Array (Prop msg) → Array (KeyedHtml msg) → Html msg 39 | ol = keyed "ol" 40 | 41 | select ∷ ∀msg. Array (Prop msg) → Array (KeyedHtml msg) → Html msg 42 | select = keyed "select" 43 | 44 | section ∷ ∀msg. Array (Prop msg) → Array (KeyedHtml msg) → Html msg 45 | section = keyed "section" 46 | 47 | span ∷ ∀msg. Array (Prop msg) → Array (KeyedHtml msg) → Html msg 48 | span = keyed "span" 49 | 50 | ul ∷ ∀msg. Array (Prop msg) → Array (KeyedHtml msg) → Html msg 51 | ul = keyed "ul" 52 | 53 | 54 | --- SVG 55 | 56 | svg ∷ ∀msg. Array (Prop msg) → Array (KeyedHtml msg) → Html msg 57 | svg = keyed "svg" 58 | 59 | g ∷ ∀msg. Array (Prop msg) → Array (KeyedHtml msg) → Html msg 60 | g = keyed "g" 61 | -------------------------------------------------------------------------------- /src/Pha/Subscriptions.purs: -------------------------------------------------------------------------------- 1 | module Pha.Subscriptions (eventListener, onKeyDown, onHashChange, onResize) where 2 | 3 | import Prelude 4 | 5 | import Data.Maybe (Maybe(..)) 6 | import Effect.Class (class MonadEffect, liftEffect) 7 | import Pha.Html.Core (EventHandler) 8 | import Pha.Update (SubscriptionId, Update, subscribe) 9 | import Web.Event.Event as E 10 | import Web.Event.EventTarget as ET 11 | import Web.HTML (window) 12 | import Web.HTML.Event.HashChangeEvent (HashChangeEvent) 13 | import Web.HTML.Event.HashChangeEvent as HCE 14 | import Web.HTML.Window as W 15 | import Web.UIEvent.KeyboardEvent as KE 16 | import Web.UIEvent.UIEvent as UI 17 | 18 | eventListener ∷ ∀ msg model m. String → ET.EventTarget → EventHandler msg → Update model msg m SubscriptionId 19 | eventListener name target decoder = subscribe \dispatch → do 20 | listener ← ET.eventListener (handleEvent dispatch) 21 | ET.addEventListener (E.EventType name) listener false target 22 | pure $ ET.removeEventListener (E.EventType name) listener false target 23 | where 24 | handleEvent dispatch ev = 25 | decoder ev >>= case _ of 26 | Nothing → pure unit 27 | Just msg → dispatch msg 28 | 29 | onKeyDown ∷ ∀ msg model m. MonadEffect m ⇒ (String → Maybe msg) → Update model msg m SubscriptionId 30 | onKeyDown f = do 31 | target ← liftEffect $ W.toEventTarget <$> window 32 | eventListener "keydown" target \ev → pure $ f =<< KE.key <$> KE.fromEvent ev 33 | 34 | onHashChange ∷ ∀ msg model m. MonadEffect m ⇒ (HashChangeEvent → Maybe msg) → Update model msg m SubscriptionId 35 | onHashChange f = do 36 | target ← liftEffect $ W.toEventTarget <$> window 37 | eventListener "hashchange" target \ev → pure $ f =<< HCE.fromEvent ev 38 | 39 | onResize ∷ ∀ msg model m. MonadEffect m ⇒ (UI.UIEvent → Maybe msg) → Update model msg m SubscriptionId 40 | onResize f = do 41 | target ← liftEffect $ W.toEventTarget <$> window 42 | eventListener "resize" target \ev → pure $ f =<< UI.fromEvent ev -------------------------------------------------------------------------------- /src/Pha/Svg.purs: -------------------------------------------------------------------------------- 1 | module Pha.Svg where 2 | 3 | import Pha.Html.Core (Html, Prop, elem) 4 | 5 | --- SVG 6 | 7 | svg ∷ ∀msg. Array (Prop msg) → Array (Html msg) → Html msg 8 | svg = elem "svg" 9 | 10 | circle ∷ ∀msg. Array (Prop msg) → Html msg 11 | circle props = elem "circle" props [] 12 | 13 | clipPath ∷ ∀msg. Array (Prop msg) → Array (Html msg) → Html msg 14 | clipPath = elem "clipPath" 15 | 16 | defs ∷ ∀msg. Array (Prop msg) → Array (Html msg) → Html msg 17 | defs = elem "defs" 18 | 19 | ellipse ∷ ∀msg. Array (Prop msg) → Html msg 20 | ellipse props = elem "ellipse" props [] 21 | 22 | foreignObject ∷ ∀msg. Array (Prop msg) → Array (Html msg) → Html msg 23 | foreignObject = elem "foreignObject" 24 | 25 | g ∷ ∀msg. Array (Prop msg) → Array (Html msg) → Html msg 26 | g = elem "g" 27 | 28 | image ∷ ∀msg. Array (Prop msg) → Html msg 29 | image attrs = elem "image" attrs [] 30 | 31 | line ∷ ∀msg. Array (Prop msg) → Html msg 32 | line props = elem "line" props [] 33 | 34 | linearGradient ∷ ∀msg. Array (Prop msg) → Array (Html msg) → Html msg 35 | linearGradient = elem "linearGradient" 36 | 37 | path ∷ ∀msg. Array (Prop msg) → Html msg 38 | path props = elem "path" props [] 39 | 40 | pattern ∷ ∀msg. Array (Prop msg) → Array (Html msg) → Html msg 41 | pattern = elem "pattern" 42 | 43 | polygon ∷ ∀msg. Array (Prop msg) → Html msg 44 | polygon props = elem "polygon" props [] 45 | 46 | polyline ∷ ∀msg. Array (Prop msg) → Html msg 47 | polyline props = elem "polyline" props [] 48 | 49 | rect ∷ ∀msg. Array (Prop msg) → Html msg 50 | rect props = elem "rect" props [] 51 | 52 | stop ∷ ∀msg. Array (Prop msg) → Html msg 53 | stop props = elem "stop" props [] 54 | 55 | -- | Create a SVG text element 56 | text ∷ ∀msg. Array (Prop msg) → Array (Html msg) → Html msg 57 | text = elem "text" 58 | 59 | textPath ∷ ∀msg. Array (Prop msg) → Array (Html msg) → Html msg 60 | textPath = elem "textPath" 61 | 62 | tspan ∷ ∀msg. Array (Prop msg) → Array (Html msg) → Html msg 63 | tspan = elem "tspan" 64 | 65 | use ∷ ∀msg. Array (Prop msg) → Html msg 66 | use props = elem "use" props [] -------------------------------------------------------------------------------- /src/Pha/Html/Core.js: -------------------------------------------------------------------------------- 1 | /* 2 | 0: property 3 | 1: attribute 4 | 2: event 5 | 3: class 6 | 4: style 7 | */ 8 | 9 | const compose = (f, g) => f && g ? x => f(g(x)) : f || g 10 | 11 | const _h = (tag, ps, children, keyed=false) => { 12 | const style = [] 13 | const props = {} 14 | const attrs = {} 15 | const events = {} 16 | const vdom = {tag, children, props, attrs, events, node: null, keyed} 17 | const n = ps.length 18 | for (let i = 0; i < n; i++) { 19 | const [t, k, v] = ps[i] 20 | if (t === 0) 21 | props[k] = v 22 | else if (t === 1) 23 | attrs[k] = v 24 | else if (t === 2) 25 | events[k] = v 26 | else if (t === 3) 27 | attrs.class = attrs.class ? attrs.class + " " + k : k 28 | else if (t === 4) 29 | style.push(k + ":" + v) 30 | } 31 | const style_ = style.join(";") 32 | if (style_) 33 | attrs.style = style_ 34 | return vdom 35 | } 36 | 37 | export const elemImpl = (tag, ps, children) => _h(tag, ps, children.map(html => ({key: null, html}))) 38 | 39 | export const keyedImpl = (tag, ps, children) => _h(tag, ps, children, true) 40 | 41 | const createTextVNode = text => ({ 42 | tag: text, 43 | children: [], 44 | type: 3 45 | }) 46 | 47 | export const mapView = (mapf, vnode) => ({...vnode, mapf: compose(vnode.mapf, mapf)}) 48 | export const mapProp = (mapf, prop) => prop[0] == 2 ? [2, mapf(prop[1])] : prop 49 | export const propImpl = (k, v) => [0, k, v] 50 | export const attrImpl = (k, v) => [1, k, v] 51 | export const unsafeOnWithEffectImpl = (k, v) => [2, k, v] 52 | export const class_ = cls => [3, cls] 53 | export const noProp = [-1] 54 | export const styleImpl = (k, v) => [4, k, v] 55 | export const text = createTextVNode 56 | export const lazyImpl = (view, val) => ({ memo: [val], type: view}) 57 | export const lazy2Impl = (view, val1, val2) => ({ memo: [val1, val2], type: view}) 58 | export const lazy3Impl = (view, val1, val2, val3) => ({ memo: [val1, val2, val3], type: view}) 59 | export const lazy4Impl = (view, val1, val2, val3, val4) => ({ memo: [val1, val2, val3, val4], type: view}) 60 | export const lazy5Impl = (view, val1, val2, val3, val4, val5) => ({ memo: [val1, val2, val3, val4, val5], type: view}) -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # purescript-pha 2 | a simple and fast Elm-like library also inspired by Halogen. 3 | 4 | ### Documentation 5 | Documentation is [published on Pursuit](https://pursuit.purescript.org/packages/purescript-pha) 6 | 7 | ### Minimal example 8 | ```purescript 9 | module Example.Counter where 10 | import Prelude 11 | import Effect (Effect) 12 | import Pha.App (sandbox) 13 | import Pha.Html (Html) 14 | import Pha.Html as H 15 | import Pha.Html.Attributes as P 16 | import Pha.Html.Events as E 17 | 18 | type Model = Int 19 | data Msg = Increment | Decrement 20 | 21 | init ∷ Model 22 | init = 0 23 | 24 | update ∷ Msg → Model → Model 25 | update Increment n = n + 1 26 | update Decrement n = n - 1 27 | 28 | view ∷ Model → Html Msg 29 | view counter = 30 | H.div [] 31 | [ H.button [E.onClick \_ → Decrement] [H.text "-"] 32 | , H.span [] [H.text $ show counter] 33 | , H.button [E.onClick \_ → Increment] [H.text "+"] 34 | ] 35 | 36 | main ∷ Effect Unit 37 | main = sandbox {init, update, view, selector: "#root"} 38 | ``` 39 | 40 | ### Example with side effects 41 | ```purescript 42 | module Example.Counter where 43 | import Prelude 44 | import Effect (Effect) 45 | import Effect.Aff (Aff) 46 | import Effect.Random (randomInt) 47 | import Pha.App (app) 48 | import Pha.Html (Html) 49 | import Pha.Html as H 50 | import Pha.Html.Attributes as P 51 | import Pha.Html.Events as E 52 | import Pha.Update (Update, liftEffect, put) 53 | 54 | type Model = Int 55 | data Msg = RollDice 56 | 57 | update ∷ Msg → Update Model Msg Aff Unit 58 | update RollDice = put =<< liftEffect (randomInt 1 6) 59 | 60 | view ∷ State → Html Msg 61 | view dice = 62 | H.div [] 63 | [ H.button [E.onClick \_ → RollDice] [H.text "Roll dice"] 64 | , H.span [] [H.text $ show dice] 65 | ] 66 | 67 | main ∷ Effect Unit 68 | main = 69 | app 70 | { init: { model: 0, msg: Just RollDice } 71 | , view 72 | , update 73 | , selector: "#root" 74 | } 75 | ``` 76 | 77 | ### More examples 78 | 79 | https://github.com/gbagan/purescript-pha-examples/tree/master/src 80 | 81 | ### Some projects using purescript-pha 82 | 83 | - https://github.com/gbagan/valise-mam 84 | - https://github.com/gbagan/nim-machine 85 | - https://github.com/gbagan/neuron 86 | - https://github.com/gbagan/graphparams 87 | - https://github.com/gbagan/sudoku-solver 88 | -------------------------------------------------------------------------------- /src/Pha/Html/Attributes.purs: -------------------------------------------------------------------------------- 1 | module Pha.Html.Attributes where 2 | import Prelude 3 | import Pha.Html.Core (Prop, attr, prop) 4 | 5 | action ∷ ∀msg. String → Prop msg 6 | action = attr "action" 7 | 8 | alt ∷ ∀msg. String → Prop msg 9 | alt = attr "alt" 10 | 11 | charset ∷ ∀msg. String → Prop msg 12 | charset = attr "charset" 13 | 14 | checked ∷ ∀msg. Boolean → Prop msg 15 | checked b = prop "checked" b 16 | 17 | cols ∷ ∀msg. Int → Prop msg 18 | cols = attr "cols" <<< show 19 | 20 | colSpan ∷ ∀msg. Int → Prop msg 21 | colSpan = attr "colSpan" <<< show 22 | 23 | disabled ∷ ∀msg. Boolean → Prop msg 24 | disabled b = prop "disabled" b 25 | 26 | download ∷ ∀msg. String → Prop msg 27 | download = attr "download" 28 | 29 | height ∷ ∀msg. Int → Prop msg 30 | height = prop "height" 31 | 32 | hidden ∷ ∀msg. Boolean → Prop msg 33 | hidden b = prop "hidden" b 34 | 35 | href ∷ ∀msg. String → Prop msg 36 | href = attr "href" 37 | 38 | id ∷ ∀msg. String → Prop msg 39 | id = attr "id" 40 | 41 | max ∷ ∀msg. Int → Prop msg 42 | max = attr "max" <<< show 43 | 44 | maxlength ∷ ∀msg. Int → Prop msg 45 | maxlength = attr "maxlength" <<< show 46 | 47 | min ∷ ∀msg. Int → Prop msg 48 | min = attr "min" <<< show 49 | 50 | minlength ∷ ∀msg. Int → Prop msg 51 | minlength = attr "minlength" <<< show 52 | 53 | name ∷ ∀msg. String → Prop msg 54 | name = attr "name" 55 | 56 | placeholder ∷ ∀msg. String → Prop msg 57 | placeholder = attr "placeholder" 58 | 59 | readonly ∷ ∀msg. Boolean → Prop msg 60 | readonly b = prop "selected" b 61 | 62 | rel ∷ ∀msg. String → Prop msg 63 | rel = attr "rel" 64 | 65 | 66 | required ∷ ∀msg. Boolean → Prop msg 67 | required b = prop "selected" b 68 | 69 | rows ∷ ∀msg. Int → Prop msg 70 | rows = attr "rows" <<< show 71 | 72 | rowSpan ∷ ∀msg. Int → Prop msg 73 | rowSpan = attr "rowSpan" <<< show 74 | 75 | selected ∷ ∀msg. Boolean → Prop msg 76 | selected b = prop "selected" b 77 | 78 | size ∷ ∀msg. Int → Prop msg 79 | size = attr "size" <<< show 80 | 81 | src ∷ ∀msg. String → Prop msg 82 | src = attr "src" 83 | 84 | target ∷ ∀msg. String → Prop msg 85 | target = attr "target" 86 | 87 | title ∷ ∀msg. String → Prop msg 88 | title = attr "title" 89 | 90 | type_ ∷ ∀msg. String → Prop msg 91 | type_ = attr "type" 92 | 93 | value ∷ ∀msg. String → Prop msg 94 | value = prop "value" 95 | 96 | width ∷ ∀msg. Int → Prop msg 97 | width = prop "width" -------------------------------------------------------------------------------- /examples/Counter2.purs: -------------------------------------------------------------------------------- 1 | module Example.Counter2 where 2 | import Prelude hiding (div) 3 | import Data.Int (even) 4 | import Data.Maybe (Maybe(..)) 5 | import Data.Array ((..), replicate) 6 | import Effect (Effect) 7 | import Effect.Aff (Aff) 8 | import Pha.Html (Html) 9 | import Pha.Html as H 10 | import Pha.Html.Attributes as P 11 | import Pha.Html.Events as E 12 | import Pha.App (app) 13 | import Pha.Update (Update, Milliseconds(..), modify_, delay) 14 | import Pha.Subscriptions (onKeyDown) 15 | 16 | type Model = Int 17 | 18 | -- initial state 19 | model ∷ Model 20 | model = 0 21 | 22 | data Msg = Init | Increment | DelayedIncrement 23 | 24 | update ∷ Msg → Update Model Msg Aff Unit 25 | update Init = void $ onKeyDown keyDownHandler 26 | update Increment = modify_ (_ + 1) 27 | update DelayedIncrement = do 28 | delay (Milliseconds 1000.0) 29 | modify_ (_ + 1) 30 | 31 | spanCounter ∷ Int → Html Msg 32 | spanCounter v = H.span [] [H.text $ show v] 33 | 34 | view ∷ Model → Html Msg 35 | view counter = 36 | H.div [] 37 | [ H.div [H.class_ "counter"] [H.text $ show counter] 38 | , H.button [E.onClick \_ → Increment] [H.text "Increment"] 39 | , H.button [E.onClick \_ → DelayedIncrement] [H.text "Delayed Increment"] 40 | , H.div [] 41 | [ H.span [] [H.text "green when the counter is even"] 42 | , H.div 43 | [ H.class_ "box" 44 | , P.width counter 45 | , H.style "background-color" $ if even counter then "blue" else "red" 46 | ] [] 47 | ] 48 | 49 | , H.h3 [] [H.text "press I to increment the counter"] 50 | 51 | , H.hr [] 52 | , H.h3 [] [H.text "keyed"] 53 | 54 | , H.keyed "div" [] $ 55 | ((0 .. (counter `mod` 4)) <#> \i → 56 | {key: "r" <> show i, html: H.text ("r" <> show i)} 57 | ) <> 58 | [{key: "test", html: H.text "test"}] 59 | <> 60 | ((0 .. (counter `mod` 4)) <#> \i → 61 | {key: "q" <> show i, html: H.text ("q" <> show i)} 62 | ) 63 | , H.hr [] 64 | , H.h3 [] [H.text "non keyed"] 65 | , H.div [] $ 66 | ((0 .. (counter `mod` 4)) <#> H.text <<< show) 67 | <> [H.text "test"] 68 | <> ((0 .. (counter `mod` 4)) <#> H.text <<< show) 69 | , H.hr [] 70 | , H.h3 [] [H.text "lazy"] 71 | , H.lazy spanCounter (counter / 2) 72 | 73 | , H.hr [] 74 | , H.h3 [] [ H.text "duplicate" ] 75 | , H.div [] $ 76 | replicate (counter `mod` 4) (H.text "t") 77 | ] 78 | 79 | keyDownHandler ∷ String → Maybe Msg 80 | keyDownHandler "i" = Just Increment 81 | keyDownHandler _ = Nothing 82 | 83 | main ∷ Effect Unit 84 | main = app 85 | { init: {model, msg: Just Init} 86 | , view 87 | , update 88 | , selector: "#root" 89 | } -------------------------------------------------------------------------------- /src/Pha/Svg/Attributes.purs: -------------------------------------------------------------------------------- 1 | module Pha.Svg.Attributes where 2 | 3 | import Prelude 4 | import Pha.Html.Core (Prop, attr) 5 | 6 | class IsLength :: Type → Constraint 7 | class IsLength a where 8 | toString :: a → String 9 | 10 | instance IsLength Int where 11 | toString = show 12 | 13 | instance IsLength Number where 14 | toString = show 15 | 16 | instance IsLength String where 17 | toString = identity 18 | 19 | 20 | x ∷ ∀msg a. IsLength a => a → Prop msg 21 | x = attr "x" <<< toString 22 | y ∷ ∀msg a. IsLength a => a → Prop msg 23 | y = attr "y" <<< toString 24 | x1 ∷ ∀msg a. IsLength a => a → Prop msg 25 | x1 = attr "x1" <<< toString 26 | y1 ∷ ∀msg a. IsLength a => a → Prop msg 27 | y1 = attr "y1" <<< toString 28 | x2 ∷ ∀msg a. IsLength a => a → Prop msg 29 | x2 = attr "x2" <<< toString 30 | y2 ∷ ∀msg a. IsLength a => a → Prop msg 31 | y2 = attr "y2" <<< toString 32 | cx ∷ ∀msg a. IsLength a => a → Prop msg 33 | cx = attr "cx" <<< toString 34 | cy ∷ ∀msg a. IsLength a => a → Prop msg 35 | cy = attr "cy" <<< toString 36 | dx ∷ ∀msg a. IsLength a => a → Prop msg 37 | dx = attr "dx" <<< toString 38 | dy ∷ ∀msg a. IsLength a => a → Prop msg 39 | dy = attr "dy" <<< toString 40 | r ∷ ∀msg a. IsLength a => a → Prop msg 41 | r = attr "r" <<< toString 42 | rx ∷ ∀msg a. IsLength a => a → Prop msg 43 | rx = attr "rx" <<< toString 44 | ry ∷ ∀msg a. IsLength a => a → Prop msg 45 | ry = attr "ry" <<< toString 46 | 47 | clipPath ∷ ∀msg. String → Prop msg 48 | clipPath = attr "clip-path" 49 | 50 | d ∷ ∀msg. String → Prop msg 51 | d = attr "d" 52 | 53 | width ∷ ∀msg i. IsLength i => i → Prop msg 54 | width i = attr "width" (toString i) 55 | 56 | height ∷ ∀msg i. IsLength i => i → Prop msg 57 | height i = attr "height" (toString i) 58 | 59 | opacity ∷ ∀msg. Number → Prop msg 60 | opacity = attr "opacity" <<< show 61 | 62 | fill ∷ ∀msg. String → Prop msg 63 | fill = attr "fill" 64 | 65 | fillOpacity ∷ ∀msg. Number → Prop msg 66 | fillOpacity = attr "fill-opacity" <<< show 67 | 68 | fillRule ∷ ∀msg. String → Prop msg 69 | fillRule = attr "fill-rule" 70 | 71 | fontSize ∷ ∀msg a. IsLength a => a → Prop msg 72 | fontSize = attr "font-size" <<< toString 73 | 74 | offset ∷ ∀msg. String → Prop msg 75 | offset = attr "offset" 76 | 77 | patternTransform ∷ ∀msg. String → Prop msg 78 | patternTransform = attr "pattern-transform" 79 | 80 | patternUnits ∷ ∀msg. String → Prop msg 81 | patternUnits = attr "pattern-units" 82 | 83 | points ∷ ∀msg. String → Prop msg 84 | points = attr "points" 85 | 86 | viewBox ∷ ∀msg. Number → Number → Number → Number → Prop msg 87 | viewBox a b c d2 = attr "viewBox" $ show a <> " " <> show b <> " " <> show c <> " " <> show d2 88 | 89 | transform ∷ ∀msg. String → Prop msg 90 | transform = attr "transform" 91 | 92 | stopColor ∷ ∀msg. String → Prop msg 93 | stopColor = attr "stop-color" 94 | 95 | stroke ∷ ∀msg. String → Prop msg 96 | stroke = attr "stroke" 97 | 98 | strokeDasharray ∷ ∀msg. String → Prop msg 99 | strokeDasharray = attr "stroke-dasharray" 100 | 101 | strokeOpacity ∷ ∀msg. Number → Prop msg 102 | strokeOpacity = attr "stroke-opacity" <<< show 103 | 104 | strokeWidth ∷ ∀msg. Number → Prop msg 105 | strokeWidth = attr "stroke-width" <<< show -------------------------------------------------------------------------------- /src/Pha/Update/Internal.purs: -------------------------------------------------------------------------------- 1 | module Pha.Update.Internal where 2 | 3 | import Prelude 4 | 5 | import Control.Monad.Free (Free, liftF, hoistFree) 6 | import Data.Bifunctor (lmap) 7 | import Data.Lens (Lens', view, set) 8 | import Data.Tuple (Tuple(..)) 9 | import Effect (Effect) 10 | import Effect.Aff.Class (class MonadAff, liftAff) 11 | import Effect.Class (class MonadEffect, liftEffect) 12 | import Control.Monad.Rec.Class (class MonadRec) 13 | import Control.Monad.Reader.Class (class MonadAsk, ask) 14 | import Control.Monad.State.Class (class MonadState) 15 | import Control.Monad.Trans.Class (class MonadTrans) 16 | import Unsafe.Reference (unsafeRefEq) 17 | 18 | newtype SubscriptionId = SubscriptionId Int 19 | 20 | derive newtype instance Eq SubscriptionId 21 | derive newtype instance Ord SubscriptionId 22 | 23 | type Subscription msg = (msg → Effect Unit) → Effect (Effect Unit) 24 | 25 | data UpdateF model msg m a 26 | = State (model → Tuple a model) 27 | | Lift (m a) 28 | | Subscribe ((msg → Effect Unit) → Effect (Effect Unit)) (SubscriptionId → a) 29 | | Unsubscribe SubscriptionId a 30 | 31 | instance Functor m ⇒ Functor (UpdateF model msg m) where 32 | map f (State k) = State (lmap f <<< k) 33 | map f (Lift q) = Lift (map f q) 34 | map f (Subscribe g a) = Subscribe g (f <<< a) 35 | map f (Unsubscribe id a) = Unsubscribe id (f a) 36 | 37 | newtype Update model msg m a = Update (Free (UpdateF model msg m) a) 38 | 39 | derive newtype instance Functor (Update model msg m) 40 | derive newtype instance Apply (Update model msg m) 41 | derive newtype instance Applicative (Update model state m) 42 | derive newtype instance Bind (Update model msg m) 43 | derive newtype instance Monad (Update model msg m) 44 | derive newtype instance MonadRec (Update model msg m) 45 | 46 | instance MonadState model (Update model msg m) where 47 | state = Update <<< liftF <<< State 48 | 49 | instance MonadTrans (Update model msg) where 50 | lift = Update <<< liftF <<< Lift 51 | 52 | instance MonadEffect m ⇒ MonadEffect (Update model msg m) where 53 | liftEffect = Update <<< liftF <<< Lift <<< liftEffect 54 | 55 | instance MonadAff m ⇒ MonadAff (Update model msg m) where 56 | liftAff = Update <<< liftF <<< Lift <<< liftAff 57 | 58 | instance MonadAsk r m => MonadAsk r (Update model msg m) where 59 | ask = Update $ liftF $ Lift ask 60 | 61 | subscribe ∷ ∀ model msg m. Subscription msg → Update model msg m SubscriptionId 62 | subscribe f = Update $ liftF $ Subscribe f identity 63 | 64 | unsubscribe ∷ ∀ model msg m. SubscriptionId → Update model msg m Unit 65 | unsubscribe id = Update $ liftF $ Unsubscribe id unit 66 | 67 | mapMessage ∷ ∀ model msg msg' m. (msg → msg') → Update model msg m ~> Update model msg' m 68 | mapMessage f (Update m) = Update $ m # hoistFree case _ of 69 | State k → State k 70 | Lift x → Lift x 71 | Subscribe g a → Subscribe (\dispatch → g \msg → dispatch (f msg)) a 72 | Unsubscribe id a → Unsubscribe id a 73 | 74 | mapModel ∷ ∀ model model' msg m. Lens' model model' → Update model' msg m ~> Update model msg m 75 | mapModel lens (Update m) = Update $ m # hoistFree case _ of 76 | State k → State \s → 77 | let 78 | s2 = view lens s 79 | Tuple a s3 = k s2 80 | in 81 | if unsafeRefEq s2 s3 then 82 | Tuple a s 83 | else 84 | Tuple a (set lens s3 s) 85 | 86 | Lift x → Lift x 87 | Subscribe x a → Subscribe x a 88 | Unsubscribe id a → Unsubscribe id a 89 | 90 | hoist ∷ ∀ model msg m m'. (m ~> m') → Update model msg m ~> Update model msg m' 91 | hoist f (Update m) = Update $ m # hoistFree case _ of 92 | State k → State k 93 | Lift x → Lift (f x) 94 | Subscribe g a → Subscribe g a 95 | Unsubscribe id a → Unsubscribe id a -------------------------------------------------------------------------------- /src/Pha/Html/Elements.purs: -------------------------------------------------------------------------------- 1 | module Pha.Html.Elements where 2 | 3 | import Pha.Html.Core (Html, Prop, elem) 4 | 5 | a ∷ ∀msg. Array (Prop msg) → Array (Html msg) → Html msg 6 | a = elem "a" 7 | 8 | abbr ∷ ∀msg. Array (Prop msg) → Array (Html msg) → Html msg 9 | abbr = elem "abbr" 10 | 11 | area ∷ ∀msg. Array (Prop msg) → Html msg 12 | area attrs = elem "area" attrs [] 13 | 14 | article ∷ ∀msg. Array (Prop msg) → Array (Html msg) → Html msg 15 | article = elem "article" 16 | 17 | aside ∷ ∀msg. Array (Prop msg) → Array (Html msg) → Html msg 18 | aside = elem "aside" 19 | 20 | audio ∷ ∀msg. Array (Prop msg) → Array (Html msg) → Html msg 21 | audio = elem "audio" 22 | 23 | b ∷ ∀msg. Array (Prop msg) → Array (Html msg) → Html msg 24 | b = elem "b" 25 | 26 | br ∷ ∀msg. Html msg 27 | br = elem "br" [] [] 28 | 29 | button ∷ ∀msg. Array (Prop msg) → Array (Html msg) → Html msg 30 | button = elem "button" 31 | 32 | canvas ∷ ∀msg. Array (Prop msg) → Html msg 33 | canvas attrs = elem "canvas" attrs [] 34 | 35 | div ∷ ∀msg. Array (Prop msg) → Array (Html msg) → Html msg 36 | div = elem "div" 37 | 38 | em ∷ ∀msg. Array (Prop msg) → Array (Html msg) → Html msg 39 | em = elem "em" 40 | 41 | footer ∷ ∀msg. Array (Prop msg) → Array (Html msg) → Html msg 42 | footer = elem "footer" 43 | 44 | form ∷ ∀msg. Array (Prop msg) → Array (Html msg) → Html msg 45 | form = elem "form" 46 | 47 | h1 ∷ ∀msg. Array (Prop msg) → Array (Html msg) → Html msg 48 | h1 = elem "h1" 49 | 50 | h2 ∷ ∀msg. Array (Prop msg) → Array (Html msg) → Html msg 51 | h2 = elem "h2" 52 | 53 | h3 ∷ ∀msg. Array (Prop msg) → Array (Html msg) → Html msg 54 | h3 = elem "h3" 55 | 56 | h4 ∷ ∀msg. Array (Prop msg) → Array (Html msg) → Html msg 57 | h4 = elem "h4" 58 | 59 | h5 ∷ ∀msg. Array (Prop msg) → Array (Html msg) → Html msg 60 | h5 = elem "h5" 61 | 62 | h6 ∷ ∀msg. Array (Prop msg) → Array (Html msg) → Html msg 63 | h6 = elem "h6" 64 | 65 | header ∷ ∀msg. Array (Prop msg) → Array (Html msg) → Html msg 66 | header = elem "header" 67 | 68 | hr ∷ ∀msg. Array (Prop msg) → Html msg 69 | hr attrs = elem "hr" attrs [] 70 | 71 | i ∷ ∀msg. Array (Prop msg) → Array (Html msg) → Html msg 72 | i = elem "i" 73 | 74 | img ∷ ∀msg. Array (Prop msg) → Html msg 75 | img attrs = elem "img" attrs [] 76 | 77 | input ∷ ∀msg. Array (Prop msg) → Html msg 78 | input attrs = elem "input" attrs [] 79 | 80 | label ∷ ∀msg. Array (Prop msg) → Array (Html msg) → Html msg 81 | label = elem "label" 82 | 83 | li ∷ ∀msg. Array (Prop msg) → Array (Html msg) → Html msg 84 | li = elem "li" 85 | 86 | link ∷ ∀msg. Array (Prop msg) → Html msg 87 | link attrs = elem "link" attrs [] 88 | 89 | main ∷ ∀msg. Array (Prop msg) → Array (Html msg) → Html msg 90 | main = elem "main" 91 | 92 | menu ∷ ∀msg. Array (Prop msg) → Array (Html msg) → Html msg 93 | menu = elem "menu" 94 | 95 | nav ∷ ∀msg. Array (Prop msg) → Array (Html msg) → Html msg 96 | nav = elem "nav" 97 | 98 | ol ∷ ∀msg. Array (Prop msg) → Array (Html msg) → Html msg 99 | ol = elem "ol" 100 | 101 | option ∷ ∀msg. Array (Prop msg) → Array (Html msg) → Html msg 102 | option = elem "option" 103 | 104 | p ∷ ∀msg. Array (Prop msg) → Array (Html msg) → Html msg 105 | p = elem "p" 106 | 107 | pre ∷ ∀msg. Array (Prop msg) → Array (Html msg) → Html msg 108 | pre = elem "pre" 109 | 110 | section ∷ ∀msg. Array (Prop msg) → Array (Html msg) → Html msg 111 | section = elem "section" 112 | 113 | select ∷ ∀msg. Array (Prop msg) → Array (Html msg) → Html msg 114 | select = elem "select" 115 | 116 | span ∷ ∀msg. Array (Prop msg) → Array (Html msg) → Html msg 117 | span = elem "span" 118 | 119 | table ∷ ∀msg. Array (Prop msg) → Array (Html msg) → Html msg 120 | table = elem "table" 121 | 122 | td ∷ ∀msg. Array (Prop msg) → Array (Html msg) → Html msg 123 | td = elem "td" 124 | 125 | textarea ∷ ∀msg. Array (Prop msg) → Html msg 126 | textarea attrs = elem "textarea" attrs [] 127 | 128 | tr ∷ ∀msg. Array (Prop msg) → Array (Html msg) → Html msg 129 | tr = elem "tr" 130 | 131 | ul ∷ ∀msg. Array (Prop msg) → Array (Html msg) → Html msg 132 | ul = elem "ul" 133 | -------------------------------------------------------------------------------- /src/Pha/Html/Core.purs: -------------------------------------------------------------------------------- 1 | module Pha.Html.Core 2 | ( EventHandler 3 | , Html 4 | , KeyedHtml 5 | , Prop 6 | , elem 7 | , keyed 8 | , text 9 | , attr 10 | , prop 11 | , noProp 12 | , style 13 | , class_ 14 | , class' 15 | , empty 16 | , lazy 17 | , lazy2 18 | , lazy3 19 | , lazy4 20 | , lazy5 21 | , when 22 | , fromMaybe 23 | , maybe 24 | , on_ 25 | , unsafeOnWithEffect 26 | , module E 27 | ) 28 | where 29 | import Prelude hiding (when) 30 | import Effect (Effect) 31 | import Data.Function.Uncurried (Fn2, Fn3, Fn4, Fn5, Fn6, mkFn2, mkFn3, mkFn4, mkFn5, runFn2, runFn3, runFn4, runFn5, runFn6) 32 | import Data.Maybe (Maybe) 33 | import Data.Maybe as M 34 | import Web.Event.Event (Event) as E 35 | import Web.Event.Event (Event) 36 | 37 | foreign import data Html ∷ Type → Type 38 | type KeyedHtml a = {key ∷ String, html ∷ Html a} 39 | 40 | type EventHandler msg = Event → Effect (Maybe msg) 41 | 42 | foreign import data Prop ∷ Type → Type 43 | 44 | -- | Create a HTML attribute. 45 | attr ∷ ∀msg. String → String → Prop msg 46 | attr key val = runFn2 attrImpl key val 47 | 48 | -- | Create a HTML property. 49 | prop ∷ ∀msg value. String → value → Prop msg 50 | prop key val = runFn2 propImpl key val 51 | 52 | foreign import attrImpl ∷ ∀msg. Fn2 String String (Prop msg) 53 | 54 | foreign import propImpl ∷ ∀msg value. Fn2 String value (Prop msg) 55 | 56 | -- | Create a CSS class. 57 | foreign import class_ ∷ ∀msg. String → Prop msg 58 | 59 | foreign import noProp ∷ ∀msg. Prop msg 60 | 61 | -- | Create a CSS class if the boolean is True. 62 | class' ∷ ∀msg. String → Boolean → Prop msg 63 | class' c b = if b then class_ c else noProp 64 | 65 | foreign import unsafeOnWithEffectImpl ∷ ∀msg. Fn2 String (EventHandler msg) (Prop msg) 66 | 67 | unsafeOnWithEffect ∷ ∀msg. String → EventHandler msg → Prop msg 68 | unsafeOnWithEffect name handler = runFn2 unsafeOnWithEffectImpl name handler 69 | 70 | on_ ∷ ∀msg. String → (Event → Maybe msg) → Prop msg 71 | on_ n handler = unsafeOnWithEffect n \ev → pure (handler ev) 72 | 73 | -- | Create a CSS property. 74 | style ∷ ∀msg. String → String → Prop msg 75 | style key val = runFn2 styleImpl key val 76 | 77 | foreign import styleImpl ∷ ∀msg. Fn2 String String (Prop msg) 78 | 79 | -- | Create a HTML element. 80 | elem ∷ ∀msg. String → Array (Prop msg) → Array (Html msg) → Html msg 81 | elem name attrs children = runFn3 elemImpl name attrs children 82 | 83 | foreign import elemImpl ∷ ∀msg. Fn3 String (Array (Prop msg)) (Array (Html msg)) (Html msg) 84 | 85 | -- | Create a HTML element where children are keyed. 86 | keyed ∷ ∀msg. String → Array (Prop msg) → Array (KeyedHtml msg) → Html msg 87 | keyed name attrs children = runFn3 keyedImpl name attrs children 88 | 89 | foreign import keyedImpl ∷ ∀msg. Fn3 String (Array (Prop msg)) (Array (KeyedHtml msg)) (Html msg) 90 | 91 | -- | Create a text node HTML value. 92 | foreign import text ∷ ∀msg. String → Html msg 93 | 94 | -- | Create a empty HTML value. 95 | empty ∷ ∀msg. Html msg 96 | empty = text "" 97 | 98 | 99 | -- | Creates a lazy node. 100 | -- | 101 | -- | Lazy nodes are only updated if the parameter changes (compared by reference) 102 | lazy ∷ ∀a msg. (a → Html msg) → a → Html msg 103 | lazy f a = runFn2 lazyImpl f a 104 | 105 | -- | Same as `lazy` but checks on two arguments. 106 | lazy2 ∷ ∀a b msg. (a → b → Html msg) → a → b → Html msg 107 | lazy2 f a b = runFn3 lazy2Impl (mkFn2 f) a b 108 | 109 | -- | Same as `lazy` but checks on three arguments. 110 | lazy3 ∷ ∀a b c msg. (a → b → c → Html msg) → a → b → c → Html msg 111 | lazy3 f a b c = runFn4 lazy3Impl (mkFn3 f) a b c 112 | 113 | -- | Same as `lazy` but checks on four arguments. 114 | lazy4 ∷ ∀a b c d msg. (a → b → c → d → Html msg) → a → b → c → d → Html msg 115 | lazy4 f a b c d = runFn5 lazy4Impl (mkFn4 f) a b c d 116 | 117 | -- | Same as `lazy` but checks on five arguments. 118 | lazy5 ∷ ∀a b c d e msg. (a → b → c → d → e → Html msg) → a → b → c → d → e → Html msg 119 | lazy5 f a b c d = runFn6 lazy5Impl (mkFn5 f) a b c d 120 | 121 | foreign import lazyImpl ∷ ∀a msg. Fn2 (a → Html msg) a (Html msg) 122 | foreign import lazy2Impl ∷ ∀a b msg. Fn3 (Fn2 a b (Html msg)) a b (Html msg) 123 | foreign import lazy3Impl ∷ ∀a b c msg. Fn4 (Fn3 a b c (Html msg)) a b c (Html msg) 124 | foreign import lazy4Impl ∷ ∀a b c d msg. Fn5 (Fn4 a b c d (Html msg)) a b c d (Html msg) 125 | foreign import lazy5Impl ∷ ∀a b c d e msg. Fn6 (Fn5 a b c d e (Html msg)) a b c d e (Html msg) 126 | 127 | -- | Create a VDOM tree only if the boolean is True 128 | when ∷ ∀msg. Boolean → (Unit → Html msg) → Html msg 129 | when cond vdom = if cond then vdom unit else empty 130 | 131 | -- | ```purescript 132 | -- | fromMaybe (Just html) = html 133 | -- | fromMaybe Nothing = empty 134 | -- | ``` 135 | fromMaybe ∷ ∀msg. Maybe (Html msg) → Html msg 136 | fromMaybe = M.fromMaybe empty 137 | 138 | maybe ∷ ∀a msg. Maybe a → (a → Html msg) → Html msg 139 | maybe = flip (M.maybe empty) 140 | 141 | mapHandler :: ∀a b. (a → b) → EventHandler a → EventHandler b 142 | mapHandler fn handler ev = map (map fn) (handler ev) 143 | 144 | foreign import mapProp ∷ ∀a b. Fn2 (EventHandler a → EventHandler b) (Prop a) (Prop b) 145 | 146 | instance Functor Prop where 147 | map fn pr = runFn2 mapProp (mapHandler fn) pr 148 | 149 | foreign import mapView ∷ ∀a b. Fn2 (EventHandler a → EventHandler b) (Html a) (Html b) 150 | 151 | instance Functor Html where 152 | map fn html = runFn2 mapView (mapHandler fn) html 153 | -------------------------------------------------------------------------------- /src/Pha/Html/Events.purs: -------------------------------------------------------------------------------- 1 | module Pha.Html.Events 2 | ( on 3 | , onClick 4 | , onClick' 5 | , onAuxClick 6 | , onContextMenu 7 | , onContextMenuPrevent 8 | , onPointerDown 9 | , onPointerDown' 10 | , onPointerEnter 11 | , onPointerEnter' 12 | , onPointerLeave 13 | , onPointerLeave' 14 | , onPointerMove 15 | , onPointerMove' 16 | , onPointerOut 17 | , onPointerOut' 18 | , onPointerOver 19 | , onPointerOver' 20 | , onPointerUp 21 | , onPointerUp' 22 | , onBlur 23 | , onFocus 24 | , onFocusIn 25 | , onFocusOut 26 | , onChecked 27 | , onValueChange 28 | ) where 29 | 30 | import Prelude hiding (div) 31 | 32 | import Data.Maybe (Maybe(..)) 33 | import Effect (Effect) 34 | import Effect.Uncurried (EffectFn3, runEffectFn3) 35 | import Pha.Html.Core (Prop, EventHandler, unsafeOnWithEffect) 36 | import Unsafe.Coerce (unsafeCoerce) 37 | import Web.Event.Event (Event) 38 | import Web.Event.Event as Event 39 | import Web.Event.EventTarget (EventTarget) 40 | import Web.HTML.HTMLInputElement as HTMLInput 41 | import Web.PointerEvent (PointerEvent) 42 | import Web.UIEvent.FocusEvent (FocusEvent) 43 | import Web.UIEvent.MouseEvent (MouseEvent) 44 | 45 | on ∷ ∀ msg. String → EventHandler msg → Prop msg 46 | on = unsafeOnWithEffect 47 | 48 | mouseCoerce ∷ Event → MouseEvent 49 | mouseCoerce = unsafeCoerce 50 | 51 | pointerCoerce ∷ Event → PointerEvent 52 | pointerCoerce = unsafeCoerce 53 | 54 | focusCoerce ∷ Event → FocusEvent 55 | focusCoerce = unsafeCoerce 56 | 57 | onClick ∷ ∀ msg. (MouseEvent → msg) → Prop msg 58 | onClick handler = on "click" (pure <<< Just <<< handler <<< mouseCoerce) 59 | 60 | onClick' ∷ ∀ msg. (MouseEvent → Effect (Maybe msg)) → Prop msg 61 | onClick' handler = on "click" (handler <<< mouseCoerce) 62 | 63 | onAuxClick ∷ ∀ msg. (MouseEvent → msg) → Prop msg 64 | onAuxClick handler = on "auxclick" (pure <<< Just <<< handler <<< mouseCoerce) 65 | 66 | onContextMenu ∷ ∀ msg. (MouseEvent → msg) → Prop msg 67 | onContextMenu handler = on "contextmenu" (pure <<< Just <<< handler <<< mouseCoerce) 68 | 69 | onContextMenuPrevent ∷ ∀ msg. (MouseEvent → msg) → Prop msg 70 | onContextMenuPrevent handler = on "contextmenu" \ev → do 71 | Event.preventDefault ev 72 | pure <<< Just <<< handler <<< mouseCoerce $ ev 73 | 74 | onPointerUp ∷ ∀ msg. (PointerEvent → msg) → Prop msg 75 | onPointerUp handler = on "pointerup" (pure <<< Just <<< handler <<< pointerCoerce) 76 | 77 | onPointerUp' ∷ ∀ msg. (PointerEvent → Effect (Maybe msg)) → Prop msg 78 | onPointerUp' handler = on "pointerup" (handler <<< pointerCoerce) 79 | 80 | onPointerDown ∷ ∀ msg. (PointerEvent → msg) → Prop msg 81 | onPointerDown handler = on "pointerdown" (pure <<< Just <<< handler <<< pointerCoerce) 82 | 83 | onPointerDown' ∷ ∀ msg. (PointerEvent → Effect (Maybe msg)) → Prop msg 84 | onPointerDown' handler = on "pointerdown" (handler <<< pointerCoerce) 85 | 86 | onPointerEnter ∷ ∀ msg. (PointerEvent → msg) → Prop msg 87 | onPointerEnter handler = on "pointerenter" (pure <<< Just <<< handler <<< pointerCoerce) 88 | 89 | onPointerEnter' ∷ ∀ msg. (PointerEvent → Effect (Maybe msg)) → Prop msg 90 | onPointerEnter' handler = on "pointerenter" (handler <<< pointerCoerce) 91 | 92 | onPointerLeave ∷ ∀ msg. (PointerEvent → msg) → Prop msg 93 | onPointerLeave handler = on "pointerleave" (pure <<< Just <<< handler <<< pointerCoerce) 94 | 95 | onPointerLeave' ∷ ∀ msg. (PointerEvent → Effect (Maybe msg)) → Prop msg 96 | onPointerLeave' handler = on "pointerleave" (handler <<< pointerCoerce) 97 | 98 | onPointerOver ∷ ∀ msg. (PointerEvent → msg) → Prop msg 99 | onPointerOver handler = on "pointerover" (pure <<< Just <<< handler <<< pointerCoerce) 100 | 101 | onPointerOver' ∷ ∀ msg. (PointerEvent → Effect (Maybe msg)) → Prop msg 102 | onPointerOver' handler = on "pointerover" (handler <<< pointerCoerce) 103 | 104 | onPointerOut ∷ ∀ msg. (PointerEvent → msg) → Prop msg 105 | onPointerOut handler = on "pointerout" (pure <<< Just <<< handler <<< pointerCoerce) 106 | 107 | onPointerOut' ∷ ∀ msg. (PointerEvent → Effect (Maybe msg)) → Prop msg 108 | onPointerOut' handler = on "pointerout" (handler <<< pointerCoerce) 109 | 110 | onPointerMove ∷ ∀ msg. (PointerEvent → msg) → Prop msg 111 | onPointerMove handler = on "pointermove" (pure <<< Just <<< handler <<< pointerCoerce) 112 | 113 | onPointerMove' ∷ ∀ msg. (PointerEvent → Effect (Maybe msg)) → Prop msg 114 | onPointerMove' handler = on "pointermove" (handler <<< pointerCoerce) 115 | 116 | 117 | onBlur ∷ ∀ msg. (FocusEvent → msg) → Prop msg 118 | onBlur handler = on "blur" (pure <<< Just <<< handler <<< focusCoerce) 119 | 120 | onFocus ∷ ∀ msg. (FocusEvent → msg) → Prop msg 121 | onFocus handler = on "focus" (pure <<< Just <<< handler <<< focusCoerce) 122 | 123 | onFocusIn ∷ ∀ msg. (FocusEvent → msg) → Prop msg 124 | onFocusIn handler = on "focusin" (pure <<< Just <<< handler <<< focusCoerce) 125 | 126 | onFocusOut ∷ ∀ msg. (FocusEvent → msg) → Prop msg 127 | onFocusOut handler = on "focusout" (pure <<< Just <<< handler <<< focusCoerce) 128 | 129 | foreign import valueImpl :: ∀ a. EffectFn3 EventTarget (Maybe a) (a -> Maybe a) (Maybe String) 130 | 131 | onValueChange ∷ ∀ msg. (String → msg) → Prop msg 132 | onValueChange f = on "change" fn 133 | where 134 | fn ev = 135 | case Event.currentTarget ev of 136 | Just target → map f <$> runEffectFn3 valueImpl target Nothing Just 137 | Nothing → pure Nothing 138 | 139 | onChecked ∷ ∀ msg. (Boolean → msg) → Prop msg 140 | onChecked f = on "change" fn 141 | where 142 | fn ev = 143 | case Event.currentTarget ev >>= HTMLInput.fromEventTarget of 144 | Nothing → pure Nothing 145 | Just target → Just <$> f <$> HTMLInput.checked target 146 | -------------------------------------------------------------------------------- /src/Pha/App.purs: -------------------------------------------------------------------------------- 1 | module Pha.App (app, sandbox) where 2 | 3 | import Prelude 4 | 5 | import Control.Monad.Free (runFreeM) 6 | import Data.Foldable (for_) 7 | import Data.Map (Map) 8 | import Data.Map as Map 9 | import Data.Maybe (Maybe(..)) 10 | import Data.Tuple (Tuple(..)) 11 | import Effect (Effect) 12 | import Effect.Uncurried(mkEffectFn1, runEffectFn2, runEffectFn5) 13 | import Effect.Aff (Aff, launchAff_) 14 | import Effect.Class (liftEffect) 15 | import Effect.Ref (Ref) 16 | import Effect.Ref as Ref 17 | import Pha.App.Internal as I 18 | import Pha.Html.Core (Html, Event, EventHandler, text) 19 | import Pha.Update.Internal (UpdateF(..), Update(..), SubscriptionId(..)) 20 | import Unsafe.Reference (unsafeRefEq) 21 | import Web.DOM.Document (createTextNode) 22 | import Web.DOM.Element as El 23 | import Web.DOM.Node as Node 24 | import Web.DOM.ParentNode (QuerySelector(..), querySelector) 25 | import Web.DOM.Text as Text 26 | import Web.Event.Event (EventType(..)) 27 | import Web.Event.Event as Ev 28 | import Web.HTML (window) 29 | import Web.HTML.HTMLDocument (toParentNode, toDocument) 30 | import Web.HTML.Window (document) 31 | 32 | newtype IApp model msg = IApp 33 | { state ∷ Ref model 34 | , node ∷ Ref Node.Node 35 | , vdom ∷ Ref (Html msg) 36 | , subscriptions ∷ Ref (Map SubscriptionId (Effect Unit)) 37 | , freshId ∷ Ref Int 38 | , update ∷ IApp model msg → msg → Effect Unit 39 | , view ∷ model → Html msg 40 | } 41 | 42 | app' 43 | ∷ ∀ msg model 44 | . { init ∷ { model ∷ model, msg ∷ Maybe msg } 45 | , view ∷ model → Html msg 46 | , update ∷ IApp model msg → msg → Effect Unit 47 | , selector ∷ String 48 | } 49 | → Effect Unit 50 | app' { init: { model, msg }, update, view, selector } = do 51 | parentNode ← window >>= document <#> toParentNode 52 | selected ← map El.toNode <$> querySelector (QuerySelector selector) parentNode 53 | for_ selected \node_ → do 54 | state ← Ref.new model 55 | emptyNode ← window >>= document <#> toDocument >>= createTextNode "" <#> Text.toNode 56 | Node.appendChild emptyNode node_ 57 | node ← Ref.new emptyNode 58 | vdom ← Ref.new $ I.unsafeLinkNode emptyNode (text "") 59 | subscriptions ← Ref.new $ Map.empty 60 | freshId ← Ref.new 0 61 | let iapp = IApp { view, update, state, node, vdom, subscriptions, freshId } 62 | render iapp (view model) 63 | for_ msg (dispatch iapp) 64 | 65 | render ∷ ∀ model msg. IApp model msg → Html msg → Effect Unit 66 | render iapp@(IApp { vdom, node }) newVDom = do 67 | oldVDom ← Ref.read vdom 68 | node1 ← Ref.read node 69 | pnode ← Node.parentNode node1 70 | for_ pnode \pnode' → do 71 | let vdom2 = I.copyVNode newVDom 72 | node2 ← runEffectFn5 I.unsafePatch pnode' node1 oldVDom vdom2 listener 73 | Ref.write node2 node 74 | Ref.write vdom2 vdom 75 | where 76 | listener = mkEffectFn1 \e → do 77 | let EventType t = Ev.type_ e 78 | for_ (Ev.currentTarget e) \target → do 79 | fn ← runEffectFn2 I.getAction target t 80 | dispatchEvent iapp e fn 81 | 82 | getState ∷ ∀ model msg. IApp model msg → Effect model 83 | getState (IApp { state }) = Ref.read state 84 | 85 | setState ∷ ∀ model msg. IApp model msg → model → Effect Unit 86 | setState iapp@(IApp { state, view }) newState = do 87 | oldState ← Ref.read state 88 | unless (unsafeRefEq oldState newState) do 89 | Ref.write newState state 90 | render iapp $ view newState 91 | 92 | dispatch ∷ ∀ model msg. IApp model msg → msg → Effect Unit 93 | -- eta expansion pour casser la dépendance cyclique 94 | dispatch iapp@(IApp { update }) = update iapp 95 | 96 | dispatchEvent ∷ ∀ model msg. IApp model msg → Event → EventHandler msg → Effect Unit 97 | dispatchEvent iapp ev handler = do 98 | msg' ← handler ev 99 | for_ msg' (dispatch iapp) 100 | 101 | getFreshId ∷ ∀ model msg. IApp model msg → Effect SubscriptionId 102 | getFreshId (IApp { freshId }) = do 103 | id ← Ref.read freshId 104 | Ref.write (id + 1) freshId 105 | pure $ SubscriptionId id 106 | 107 | interpret 108 | ∷ ∀ model msg 109 | . (msg → Update model msg Aff Unit) 110 | → IApp model msg 111 | → Update model msg Aff Unit 112 | → Aff Unit 113 | interpret update iapp@(IApp { subscriptions }) (Update m) = runFreeM go m 114 | where 115 | go (State k) = do 116 | st ← liftEffect $ getState iapp 117 | let Tuple a st2 = k st 118 | liftEffect $ setState iapp st2 119 | pure a 120 | go (Lift a) = a 121 | go (Subscribe f next) = do 122 | canceler ← liftEffect $ f \msg → launchAff_ $ interpret update iapp (update msg) 123 | id ← liftEffect $ getFreshId iapp 124 | liftEffect $ Ref.modify_ (Map.insert id canceler) subscriptions 125 | pure (next id) 126 | go (Unsubscribe id a) = do 127 | subs ← liftEffect $ Ref.read subscriptions 128 | for_ (Map.lookup id subs) liftEffect 129 | pure a 130 | 131 | -- | ```purescript 132 | -- | app ∷ ∀msg model. 133 | -- | { init ∷ {model ∷ model, msg ∷ Maybe msg} 134 | -- | , view ∷ model → Html msg 135 | -- | , update ∷ msg → Update model msg Aff Unit 136 | -- | , selector ∷ String 137 | -- | } → Effect Unit 138 | -- | ``` 139 | 140 | app 141 | ∷ ∀ msg model 142 | . { init ∷ { model ∷ model, msg ∷ Maybe msg } 143 | , view ∷ model → Html msg 144 | , update ∷ msg → Update model msg Aff Unit 145 | , selector ∷ String 146 | } 147 | → Effect Unit 148 | 149 | app { init, view, update, selector } = app' { init, view, selector, update: update' } 150 | where 151 | update' iapp msg = launchAff_ $ interpret update iapp (update msg) 152 | 153 | -- | ```purescript 154 | -- | sandbox ∷ ∀msg model. 155 | -- | { init ∷ model 156 | -- | , view ∷ model → Html msg 157 | -- | , update ∷ msg → model → model 158 | -- | , selector ∷ String 159 | -- | } → Effect Unit 160 | -- | ``` 161 | 162 | sandbox 163 | ∷ ∀ msg model 164 | . { init ∷ model 165 | , view ∷ model → Html msg 166 | , update ∷ msg → model → model 167 | , selector ∷ String 168 | } 169 | → Effect Unit 170 | 171 | sandbox { init, view, update, selector } = 172 | app' 173 | { init: { model: init, msg: Nothing } 174 | , view 175 | , update: \iapp msg → do 176 | st ← getState iapp 177 | setState iapp (update msg st) 178 | , selector 179 | } 180 | -------------------------------------------------------------------------------- /src/Pha/App/Internal.js: -------------------------------------------------------------------------------- 1 | // code comes from hyperapp by Jorge Bucaran 2 | // https://github.com/jorgebucaran/hyperapp 3 | // modified by Guillaume Bagan 4 | 5 | const TEXT_NODE = 3 6 | 7 | const compose = (f, g) => f && g ? x => f(g(x)) : f || g 8 | 9 | const patchProperty = (node, key, newValue) => { 10 | node[key] = newValue; 11 | } 12 | 13 | const patchAttribute = (node, key, newValue) => { 14 | if (newValue == null || (key === "class" && !newValue)) { 15 | node.removeAttribute(key) 16 | } else { 17 | node.setAttribute(key, newValue) 18 | } 19 | } 20 | 21 | const patchEvent = (node, key, oldValue, newValue, listener, mapf) => { 22 | if (!node.actions) 23 | node.actions = {} 24 | node.actions[key] = mapf && newValue ? mapf(newValue) : newValue 25 | if (!newValue) { 26 | node.removeEventListener(key, listener) 27 | } else if (!oldValue) { 28 | node.addEventListener(key, listener) 29 | } 30 | } 31 | 32 | const createNode = (vnode, listener, isSvg, mapf) => { 33 | const node = 34 | vnode.type === TEXT_NODE 35 | ? document.createTextNode(vnode.tag) 36 | : (isSvg = isSvg || vnode.tag === "svg") 37 | ? document.createElementNS("http://www.w3.org/2000/svg", vnode.tag) 38 | : document.createElement(vnode.tag) 39 | const props = vnode.props 40 | const attrs = vnode.attrs 41 | const events = vnode.events 42 | const mapf2 = compose(mapf, vnode.mapf) 43 | 44 | 45 | for (let k in props) { 46 | patchProperty(node, k, props[k]) 47 | } 48 | for (let k in attrs) { 49 | patchAttribute(node, k, attrs[k]) 50 | } 51 | for (let k in events) { 52 | patchEvent(node, k, null, events[k], listener, mapf2) 53 | } 54 | 55 | for (let i = 0, len = vnode.children.length; i < len; i++) { 56 | node.appendChild( 57 | createNode( 58 | getVNode(vnode.children[i]).html, 59 | listener, 60 | isSvg, 61 | mapf2 62 | ) 63 | ) 64 | } 65 | vnode.node = node 66 | return node 67 | } 68 | 69 | const patch = (parent, node, oldVNode, newVNode, listener, isSvg, mapf) => { 70 | if (oldVNode === newVNode) return 71 | 72 | if (oldVNode != null && oldVNode.type === TEXT_NODE && newVNode.type === TEXT_NODE) { 73 | if (oldVNode.tag !== newVNode.tag) 74 | node.nodeValue = newVNode.tag 75 | } else if (oldVNode == null || oldVNode.tag !== newVNode.tag) { 76 | node = parent.insertBefore( 77 | createNode(newVNode, listener, isSvg, mapf), 78 | node 79 | ) 80 | if (oldVNode) { 81 | oldVNode.node.remove() 82 | } 83 | } else { 84 | const oldProps = oldVNode.props 85 | const newProps = newVNode.props 86 | 87 | for (let i in {...oldProps, ...newProps}) { 88 | if (oldProps[i] !== newProps[i]) { 89 | patchProperty(node, i, newProps[i]) 90 | } 91 | } 92 | 93 | const oldAttrs = oldVNode.attrs 94 | const newAttrs = newVNode.attrs 95 | 96 | for (let i in {...oldAttrs, ...newAttrs}) { 97 | if (oldAttrs[i] !== newAttrs[i]) { 98 | patchAttribute(node, i, newAttrs[i]) 99 | } 100 | } 101 | 102 | const oldEvents = oldVNode.events 103 | const newEvents = newVNode.events 104 | 105 | for (let i in {...oldEvents, ...newEvents}) { 106 | if (oldEvents[i] !== newEvents[i]) { 107 | patchEvent(node, i, oldEvents[i], newEvents[i], listener, mapf) 108 | } 109 | } 110 | 111 | const oldVKids = oldVNode.children 112 | const newVKids = newVNode.children 113 | let oldTail = oldVKids.length - 1 114 | let newTail = newVKids.length - 1 115 | 116 | mapf = compose(mapf, newVNode.mapf) 117 | isSvg = isSvg || newVNode.tag === "svg" 118 | 119 | if(!newVNode.keyed) { 120 | for (let i = 0; i <= oldTail && i <= newTail; i++) { 121 | const oldVNode = oldVKids[i].html 122 | const newVNode = getVNode(newVKids[i], oldVNode).html 123 | patch(node, oldVNode.node, oldVNode, newVNode, listener, isSvg, mapf) 124 | } 125 | for (let i = oldTail + 1; i <= newTail; i++) { 126 | const newVNode = getVNode(newVKids[i], oldVNode).html 127 | node.appendChild( 128 | createNode(newVNode, listener, isSvg, mapf) 129 | ) 130 | } 131 | for (let i = newTail + 1; i <= oldTail; i++) { 132 | oldVKids[i].html.node.remove() 133 | } 134 | 135 | } else { // node.keyed == true 136 | let oldHead = 0 137 | let newHead = 0 138 | while (newHead <= newTail && oldHead <= oldTail) { 139 | const {key: oldKey, html: oldVNode} = oldVKids[oldHead] 140 | if (oldKey !== newVKids[newHead].key) 141 | break 142 | const newKNode = getVNode(newVKids[newHead], oldVNode) //////////////////// 143 | patch(node, oldVNode.node, oldVNode, newKNode.html, listener, isSvg, mapf) 144 | newHead++ 145 | oldHead++ 146 | } 147 | 148 | while (newHead <= newTail && oldHead <= oldTail) { 149 | const {key: oldKey, html: oldVNode} = oldVKids[oldTail] 150 | if (oldKey !== newVKids[newTail].key) 151 | break 152 | const newKNode = getVNode(newVKids[newTail], oldVNode) //////////////////// 153 | patch(node, oldVNode.node, oldVNode, newKNode.html, listener, isSvg, mapf) 154 | newTail-- 155 | oldTail-- 156 | } 157 | 158 | if (oldHead > oldTail) { 159 | while (newHead <= newTail) { 160 | const newVNode = getVNode(newVKids[newHead]).html 161 | node.insertBefore( 162 | createNode(newVNode, listener, isSvg, mapf), 163 | oldVKids[oldHead] && oldVKids[oldHead].html.node 164 | ) 165 | newHead++ 166 | } 167 | } else if (newHead > newTail) { 168 | while (oldHead <= oldTail) { 169 | oldVKids[oldHead].html.node.remove() 170 | oldHead++ 171 | } 172 | } else { 173 | const keyed = {} 174 | const newKeyed = {} 175 | for (let i = oldHead; i <= oldTail; i++) { 176 | keyed[oldVKids[i].key] = oldVKids[i].html 177 | } 178 | 179 | while (newHead <= newTail) { 180 | const {key: oldKey, html: oldVKid} = oldVKids[oldHead] || {key: null, html: null} 181 | const {key: newKey, html: newVKid} = getVNode(newVKids[newHead], oldVKid) 182 | 183 | if (newKeyed[oldKey] || oldVKids[oldHead+1] && newKey === oldVKids[oldHead+1].key) { 184 | oldHead++ 185 | continue 186 | } 187 | if (oldKey === newKey) { 188 | patch(node, oldVKid.node, oldVKid, newVKid, listener, isSvg, mapf) 189 | newKeyed[newKey] = true 190 | oldHead++ 191 | } else { 192 | const vkid = keyed[newKey] 193 | if (vkid != null) { 194 | patch( 195 | node, 196 | node.insertBefore(vkid.node, oldVKid.node), 197 | vkid, 198 | newVKids[newHead].html, 199 | listener, 200 | isSvg, 201 | mapf 202 | ) 203 | newKeyed[newKey] = true 204 | } else { 205 | patch(node, oldVKid && oldVKid.node, null, newVKids[newHead].html, listener, isSvg, mapf) 206 | } 207 | } 208 | newHead++ 209 | } 210 | /* 211 | while (oldHead <= oldTail) { 212 | // dans certaines situations, removeChild est appelé ici et 213 | // dans le cas juste après 214 | console.log("3", oldVKids[oldHead].html.node) 215 | node.removeChild(oldVKids[oldHead].html.node) 216 | oldHead++ 217 | } 218 | */ 219 | for (let i in keyed) { 220 | if (!newKeyed[i]) { 221 | keyed[i].node.remove() 222 | } 223 | } 224 | } 225 | } 226 | } 227 | newVNode.node = node 228 | return node 229 | } 230 | 231 | const propsChanged = (a, b) => { 232 | for (let i = 0; i < a.length; i++) 233 | if (a[i] !== b[i]) 234 | return true 235 | return false 236 | } 237 | 238 | const getVNode = (newVNode, oldVNode) => { 239 | if (typeof newVNode.html.type === "function") { 240 | if (!oldVNode || oldVNode.memo == null || propsChanged(oldVNode.memo, newVNode.html.memo)) { 241 | oldVNode = copyVNode(newVNode.html.type(...newVNode.html.memo)) 242 | oldVNode.memo = newVNode.html.memo 243 | } 244 | newVNode.html = oldVNode 245 | } 246 | return newVNode 247 | } 248 | 249 | export const copyVNode = vnode => ({ 250 | ...vnode, 251 | children: vnode.children && vnode.children.map(({key, html}) => ({key, html: copyVNode(html)})) 252 | }) 253 | export const getAction = (target, type) => target.actions[type] 254 | export const unsafePatch = patch 255 | 256 | export const unsafeLinkNode = node => vdom => { vdom.node = node; return vdom; } --------------------------------------------------------------------------------