@@ -0,0 +1,724 @@
1+module Plum.View
2+ ( View
3+ , Nerve(..)
4+ , Meat(..)
5+ , Font
6+ , BorderStyle(..)
7+ , Corner(..)
8+ , Shadow(..)
9+ , ShadowCfg
10+ , Side(..)
11+ , Bones(..)
12+ , grow
13+ , Direction(..)
14+ , Alignment(..)
15+ , Length(..)
16+ , Color(..)
17+ , rgb255
18+ , rgba255
19+ , rgb
20+ , rgba
21+ , UI
22+ , GenericUI(..)
23+ , GenericUIView
24+ , column
25+ , row
26+ , stack
27+ , text
28+ , link
29+ , newTabLink
30+ , download
31+ , downloadAs
32+ , image
33+ , textInput
34+ , spacing
35+ , explain
36+ , align
37+ , width
38+ , height
39+ , wrapped
40+ , bgColor
41+ , padding
42+ , spread
43+ , opacity
44+ , pointer
45+ , move
46+ , clip
47+ , borders
48+ , border
49+ , borderStyle
50+ , roundAll
51+ , round
52+ , shadow
53+ , innerShadow
54+ , onHover
55+ , onMouseDown
56+ , font
57+ , fontColor
58+ , fontSize
59+ , fontWeight
60+ , onClick
61+ , onPress
62+ , onKey
63+ ) where
64+
65+import Prelude
66+
67+import Control.Monad.Writer (Writer, runWriter, tell)
68+import Control.Monad.Writer.Trans (mapWriterT)
69+import Data.Array (foldMap)
70+import Data.Array as Array
71+import Data.Array.NonEmpty (concatMap)
72+import Data.Int as Int
73+import Data.Maybe (Maybe(..))
74+import Data.Maybe as Maybe
75+import Data.String as String
76+import Data.Traversable (traverse)
77+import Data.TraversableWithIndex (traverseWithIndex)
78+import Data.Tuple.Nested (type (/\), (/\))
79+import Effect (Effect)
80+import Foreign.Object (Object)
81+import Foreign.Object as Object
82+import Literals.Undefined (undefined)
83+import Prim.TypeError (class Warn)
84+import Prim.TypeError as TypeError
85+import Snabbdom (VNode)
86+import Snabbdom as Snabbdom
87+import Type.Row.Homogeneous (class Homogeneous)
88+import Unsafe.Coerce (unsafeCoerce)
89+import Untagged.Union (asOneOf)
90+import Web.DOM.Element as Element
91+import Web.DOM.ParentNode (firstElementChild)
92+import Web.Event.Event (Event)
93+import Web.Event.Event as Event
94+import Web.HTML.HTMLInputElement as HTMLInputElement
95+import Web.UIEvent.InputEvent as InputEvent
96+import Web.UIEvent.KeyboardEvent (KeyboardEvent)
97+import Web.UIEvent.KeyboardEvent as KeyboardEvent
98+
99+type GenericUIView children msg =
100+ { nerves :: Array (Nerve msg)
101+ , meat :: Array Meat
102+ , hover :: Array Meat
103+ , down :: Array Meat
104+ , children :: children
105+ }
106+
107+type UIView msg = GenericUIView (Array (View msg)) msg
108+
109+data GenericUI children msg a = UI (GenericUIView children msg) a
110+
111+instance (Semigroup children, Semigroup a) => Semigroup (GenericUI children msg a) where
112+ append (UI v a) (UI v' a') = UI (v <> v') (a <> a')
113+
114+instance (Monoid children, Monoid a) => Monoid (GenericUI children msg a) where
115+ mempty = UI mempty mempty
116+
117+type UI msg a = GenericUI (Array (View msg)) msg a
118+
119+instance Functor (GenericUI children msg) where
120+ map f (UI v a) = UI v $ f a
121+
122+instance Monoid children => Apply (GenericUI children msg) where
123+ apply (UI views f) (UI views' a) = UI (views <> views') (f a)
124+
125+instance Monoid children => Applicative (GenericUI children msg) where
126+ pure = UI mempty
127+
128+instance Monoid children => Bind (GenericUI children msg) where
129+ bind (UI views a) f =
130+ let
131+ UI views' b = f a
132+ in
133+ UI (views <> views') b
134+
135+instance Monoid children => Monad (GenericUI children msg)
136+
137+column :: forall msg. UI msg Unit -> UI msg Unit
138+column (UI { nerves, meat, hover, down, children } _) =
139+ UI (mempty :: UIView msg) { children = [ { meat, nerves, hover, down } /\ Column children ] } unit
140+
141+row :: forall msg a. UI msg a -> UI msg a
142+row (UI { nerves, meat, hover, down, children } a) =
143+ UI (mempty :: UIView msg) { children = [ { meat, nerves, hover, down } /\ Row children ] } a
144+
145+stack :: forall msg a. UI msg a -> UI msg a
146+stack (UI { nerves, meat, hover, down, children } a) =
147+ UI (mempty :: UIView msg) { children = [ { meat, nerves, hover, down } /\ Stack children ] } a
148+
149+text :: forall msg. String -> GenericUI Unit msg Unit -> UI msg Unit
150+text s (UI { nerves, meat, hover, down } a) = UI (mempty :: UIView msg) { children = [ { meat, nerves, hover, down } /\ Text s ] } a
151+
152+link :: forall msg a. String -> UI msg a -> UI msg a
153+link url (UI { nerves, meat, hover, down, children } a) = UI
154+ (mempty :: UIView msg)
155+ { children =
156+ [ { meat
157+ , nerves
158+ , hover
159+ , down
160+ } /\ Link url { newTab: false } (Maybe.fromMaybe none $ Array.head children)
161+ ]
162+ }
163+ a
164+
165+newTabLink :: forall msg a. String -> UI msg a -> UI msg a
166+newTabLink url (UI { nerves, meat, hover, down, children } a) = UI
167+ (mempty :: UIView msg)
168+ { children =
169+ [ { meat
170+ , nerves
171+ , hover
172+ , down
173+ } /\ Link url { newTab: true } (Maybe.fromMaybe none $ Array.head children)
174+ ]
175+ }
176+ a
177+
178+download :: forall msg a. String -> UI msg a -> UI msg a
179+download url (UI { nerves, meat, children, down, hover } a) = UI
180+ (mempty :: UIView msg)
181+ { children =
182+ [ { meat
183+ , nerves
184+ , down
185+ , hover
186+ } /\ Download url { filename: Nothing } (Maybe.fromMaybe none $ Array.head children)
187+ ]
188+ }
189+ a
190+
191+downloadAs :: forall msg a. String -> { filename :: String } -> UI msg a -> UI msg a
192+downloadAs url { filename } (UI { nerves, meat, hover, down, children } a) = UI
193+ (mempty :: UIView msg)
194+ { children =
195+ [ { meat
196+ , nerves
197+ , hover
198+ , down
199+ } /\ Download url { filename: Just filename } (Maybe.fromMaybe none $ Array.head children)
200+ ]
201+ }
202+ a
203+
204+image :: forall msg a. String -> { description :: String } -> GenericUI Unit msg a -> UI msg a
205+image url description (UI { nerves, meat, hover, down } a) =
206+ UI (mempty :: UIView msg) { children = [ { meat, nerves, hover, down } /\ Image url description ] } a
207+
208+textInput :: forall msg a. { value :: String, onChange :: String -> msg } -> GenericUI Unit msg a -> UI msg a
209+textInput props (UI { nerves, meat, hover, down } a) =
210+ UI (mempty :: UIView msg) { children = [ { meat, nerves, hover, down } /\ TextInput props ] } a
211+
212+string :: String -> Classes -> WiredNerves -> String -> VNode
213+string elem classes (WiredNerves on) s =
214+ Snabbdom.h elem
215+ { attrs: Object.singleton "class" (Array.intercalate " " classes)
216+ , on
217+ , style: Object.empty
218+ , props: Object.empty
219+ }
220+ []
221+ (asOneOf s)
222+
223+h :: String -> Classes -> WiredNerves -> Array VNode -> VNode
224+h elem classes (WiredNerves on) children =
225+ Snabbdom.h elem
226+ { attrs: Object.singleton "class" (Array.intercalate " " classes)
227+ , on
228+ , props: Object.empty
229+ , style: Object.empty
230+ }
231+ children
232+ (asOneOf undefined)
233+
234+hWith :: forall props. Homogeneous props String => String -> Record props -> Classes -> WiredNerves -> Array VNode -> VNode
235+hWith elem props classes (WiredNerves on) children =
236+ Snabbdom.h elem
237+ { attrs: Object.singleton "class" (Array.intercalate " " classes)
238+ , on
239+ , props: Object.fromHomogeneous props
240+ , style: Object.empty
241+ }
242+ children
243+ (asOneOf undefined)
244+
245+data Length = Px Int | Fill | Fit | Max Int Length | Min Int Length
246+
247+data Alignment = Start | Center | End
248+
249+data Direction = X | Y
250+
251+n :: forall ch msg. Monoid ch => Nerve msg -> GenericUI ch msg Unit
252+n nerve = UI (mempty :: GenericUIView ch msg) { nerves = [ nerve ] } mempty
253+
254+onClick :: forall ch msg. Monoid ch => msg -> GenericUI ch msg Unit
255+onClick msg = n $ OnClick msg
256+
257+onPress :: forall ch msg. Monoid ch => (KeyboardEvent -> msg) -> GenericUI ch msg Unit
258+onPress msg = n $ OnPress msg
259+
260+-- | https://developer.mozilla.org/en-US/docs/Web/API/UI_Events/Keyboard_event_code_values
261+onKey :: forall ch msg. Monoid ch => String -> msg -> GenericUI ch msg Unit
262+onKey key msg = n $ OnKey key msg
263+
264+m :: forall ch msg. Monoid ch => Meat -> GenericUI ch msg Unit
265+m meat = UI (mempty :: GenericUIView ch msg) { meat = [ meat ] } mempty
266+
267+spacing :: forall ch msg. Monoid ch => { x :: Int, y :: Int } -> GenericUI ch msg Unit
268+spacing { x, y } = m $ Spacing x y
269+
270+explain :: forall ch msg. Monoid ch => Warn (TypeError.Text "Debug explain present") => GenericUI ch msg Unit
271+explain = m Explain
272+
273+align :: forall ch msg. Monoid ch => Direction -> Alignment -> GenericUI ch msg Unit
274+align dir al = m $ Align dir al
275+
276+width :: forall ch msg. Monoid ch => Length -> GenericUI ch msg Unit
277+width l = m $ Width l
278+
279+height :: forall ch msg. Monoid ch => Length -> GenericUI ch msg Unit
280+height l = m $ Height l
281+
282+wrapped :: forall ch msg. Monoid ch => GenericUI ch msg Unit
283+wrapped = m Wrapped
284+
285+bgColor :: forall ch msg. Monoid ch => Color -> GenericUI ch msg Unit
286+bgColor c = m $ BackgroundColor c
287+
288+padding :: forall ch msg. Monoid ch => Side -> Int -> GenericUI ch msg Unit
289+padding s l = m $ Padding s l
290+
291+spread :: forall ch msg. Monoid ch => GenericUI ch msg Unit
292+spread = m Spread
293+
294+opacity :: forall ch msg. Monoid ch => Number -> GenericUI ch msg Unit
295+opacity o = m $ Opacity o
296+
297+pointer :: forall ch msg. Monoid ch => GenericUI ch msg Unit
298+pointer = m Pointer
299+
300+move :: forall ch msg. Monoid ch => { x :: Int, y :: Int } -> GenericUI ch msg Unit
301+move a = m $ Move a
302+
303+clip :: forall ch msg. Monoid ch => Direction -> GenericUI ch msg Unit
304+clip dir = m $ Clip dir
305+
306+onHover :: forall ch msg. Monoid ch => GenericUI Unit msg Unit -> GenericUI ch msg Unit
307+onHover (UI { meat } a) = UI (mempty :: GenericUIView ch msg) { hover = meat } a
308+
309+onMouseDown :: forall ch msg. Monoid ch => GenericUI Unit msg Unit -> GenericUI ch msg Unit
310+onMouseDown (UI { meat } a) = UI (mempty :: GenericUIView ch msg) { down = meat } a
311+
312+borders :: forall ch msg. Monoid ch => Int -> GenericUI ch msg Unit
313+borders l = Array.foldMap (\s -> m $ BorderWidth s l) [ Top, Right, Bottom, Left ]
314+
315+border :: forall ch msg. Monoid ch => Side -> Int -> GenericUI ch msg Unit
316+border s l = m $ BorderWidth s l
317+
318+borderStyle :: forall ch msg. Monoid ch => BorderStyle -> GenericUI ch msg Unit
319+borderStyle s = m $ BorderStyle s
320+
321+roundAll :: forall ch msg. Monoid ch => Int -> GenericUI ch msg Unit
322+roundAll l = Array.foldMap (\c -> m $ Round c l) [ TopLeft, TopRight, BottomRight, BottomLeft ]
323+
324+round :: forall ch msg. Monoid ch => Corner -> Int -> GenericUI ch msg Unit
325+round c l = m $ Round c l
326+
327+shadow :: forall ch msg. Monoid ch => ShadowCfg -> GenericUI ch msg Unit
328+shadow cfg = m $ Shadow $ ShadowCfg cfg
329+
330+innerShadow :: forall ch msg. Monoid ch => ShadowCfg -> GenericUI ch msg Unit
331+innerShadow cfg = m $ InnerShadow $ ShadowCfg cfg
332+
333+font :: forall ch msg. Monoid ch => String -> GenericUI ch msg Unit
334+font f = m $ Font f
335+
336+fontColor :: forall ch msg. Monoid ch => Color -> GenericUI ch msg Unit
337+fontColor c = m $ FontColor c
338+
339+fontSize :: forall ch msg. Monoid ch => Int -> GenericUI ch msg Unit
340+fontSize f = m $ FontSize f
341+
342+fontWeight :: forall ch msg. Monoid ch => Int -> GenericUI ch msg Unit
343+fontWeight f = m $ FontWeight f
344+
345+data Meat
346+ = Spacing Int Int
347+ | Explain
348+ | Align Direction Alignment
349+ | Width Length
350+ | Height Length
351+ | Wrapped
352+ | BackgroundColor Color
353+ | Padding Side Int
354+ | Spread
355+ | Opacity Number
356+ | Pointer
357+ | Move { x :: Int, y :: Int }
358+ | Clip Direction
359+ | BorderWidth Side Int
360+ | BorderStyle BorderStyle
361+ | Round Corner Int
362+ | Shadow Shadow
363+ | InnerShadow Shadow
364+ | FontColor Color
365+ | FontWeight Int
366+ | FontSize Int
367+ | Font Font
368+
369+type Font = String
370+
371+type ShadowCfg = { offset :: { x :: Int, y :: Int }, size :: Number, blur :: Number, color :: Color }
372+
373+newtype Shadow = ShadowCfg ShadowCfg
374+
375+instance Renderable Shadow where
376+ render (ShadowCfg s) = show s.offset.x <> "px " <> show s.offset.y <> "px " <> show s.blur <> "px " <> show s.size <> "px " <> render s.color
377+ renderKey (ShadowCfg s) = show s.offset.x <> "-" <> show s.offset.y <> "-" <> show s.blur <> "-" <> show s.size <> "-" <> renderKey s.color
378+
379+data Corner = TopLeft | TopRight | BottomRight | BottomLeft
380+
381+instance Renderable Corner where
382+ render = case _ of
383+ TopLeft -> "top-left"
384+ TopRight -> "top-right"
385+ BottomRight -> "bottom-right"
386+ BottomLeft -> "bottom-left"
387+ renderKey = case _ of
388+ TopLeft -> "top-left"
389+ TopRight -> "top-right"
390+ BottomRight -> "bottom-right"
391+ BottomLeft -> "bottom-left"
392+
393+data BorderStyle = Solid | Dashed | Dotted
394+
395+instance Renderable BorderStyle where
396+ render = case _ of
397+ Solid -> "solid"
398+ Dashed -> "dashed"
399+ Dotted -> "dotted"
400+ renderKey = case _ of
401+ Solid -> "solid"
402+ Dashed -> "dashed"
403+ Dotted -> "dotted"
404+
405+data Side = Top | Right | Bottom | Left
406+
407+instance Renderable Side where
408+ render = case _ of
409+ Top -> "top"
410+ Right -> "right"
411+ Bottom -> "bottom"
412+ Left -> "left"
413+ renderKey = case _ of
414+ Top -> "top"
415+ Right -> "right"
416+ Bottom -> "bottom"
417+ Left -> "left"
418+
419+data Nerve msg
420+ = OnClick msg
421+ | OnPress (KeyboardEvent -> msg)
422+ | OnKey String msg
423+
424+newtype WiredNerves = WiredNerves (Object (Event -> Effect Unit))
425+
426+instance Semigroup WiredNerves where
427+ append (WiredNerves x) (WiredNerves y) =
428+ WiredNerves $ Object.unionWith (\f g ev -> f ev *> g ev) x y
429+
430+instance Monoid WiredNerves where
431+ mempty = WiredNerves Object.empty
432+
433+wireNerve :: forall msg. (msg -> Effect Unit) -> Nerve msg -> WiredNerves
434+wireNerve fire nerve = WiredNerves $ case nerve of
435+ OnClick msg -> Object.singleton "click" $ \_ev -> fire msg
436+ OnPress msg -> Object.singleton "keypress" $ \ev -> case KeyboardEvent.fromEvent ev of
437+ Nothing -> pure unit
438+ Just keyboardEvent -> fire $ msg keyboardEvent
439+ OnKey key msg -> Object.singleton "keypress" $ \ev -> case KeyboardEvent.fromEvent ev of
440+ Just keyboardEvent | KeyboardEvent.code keyboardEvent == key -> fire msg
441+ _ -> pure unit
442+
443+type View msg =
444+ { nerves :: Array (Nerve msg)
445+ , meat :: Array Meat
446+ , hover :: Array Meat
447+ , down :: Array Meat
448+ } /\ Bones msg
449+
450+none :: forall msg. View msg
451+none = mempty /\ None
452+
453+newtype Skin = Skin (Object String)
454+
455+sk :: String -> String -> String -> Writer SkinGrowth Classes
456+sk cName key value = do
457+ tell $ SkinGrowth $ { meat: Object.singleton cName { key, value }, hover: Object.empty, down: Object.empty }
458+ pure [ cName ]
459+
460+instance Semigroup Skin where
461+ append (Skin x) (Skin y) = Skin $ Object.union x y
462+
463+instance Monoid Skin where
464+ mempty = Skin Object.empty
465+
466+data Context = Grid | Flexbox Direction | Generic | Span
467+
468+skin :: Context -> Meat -> Writer SkinGrowth Classes
469+skin ctx = case _ of
470+ Spacing x y -> sk ("spacing-" <> show x <> "-" <> show y) "gap" (show x <> "px " <> show y <> "px")
471+ Explain -> sk "explain" "border" "dashed magenta"
472+ Align dir alignment -> case ctx of
473+ Generic -> mempty
474+ Span -> mempty
475+ Grid ->
476+ let
477+ k =
478+ ( case dir of
479+ X -> "justify-items"
480+ Y -> "align-items"
481+ )
482+ v =
483+ ( case alignment of
484+ Start -> "start"
485+ Center -> "center"
486+ End -> "end"
487+ )
488+ in
489+ sk ("align-grid-" <> k <> "-" <> v) k v
490+
491+ Flexbox flexDir ->
492+ let
493+ k =
494+ ( case flexDir /\ dir of
495+ X /\ X -> "justify-content"
496+ X /\ Y -> "align-items"
497+ Y /\ X -> "align-items"
498+ Y /\ Y -> "justify-content"
499+ )
500+
501+ v =
502+ ( case alignment of
503+ Start -> "flex-start"
504+ Center -> "center"
505+ End -> "flex-end"
506+ )
507+ in
508+ sk ("align-flexbox-" <> k <> "-" <> v) k v
509+ Width l -> sk ("width-" <> renderKey l) "width" (render l)
510+ Height l -> sk ("height-" <> renderKey l) "height" (render l)
511+ Wrapped -> case ctx of
512+ Flexbox _ -> sk "wrapped" "flex-wrap" "wrap"
513+ _ -> pure []
514+ BackgroundColor color -> sk ("bg-color-" <> renderKey color) "background-color" (render color)
515+ Padding side l ->
516+ sk
517+ ("padding-" <> renderKey side <> "-" <> show l)
518+ ("padding-" <> render side)
519+ (show l <> "px")
520+ Spread -> case ctx of
521+ Flexbox _ -> sk "spread" "justify-content" "space-between"
522+ _ -> pure []
523+ Opacity o -> sk ("opacity-" <> show o) "opacity" (show o)
524+ Pointer -> sk "pointer" "cursor" "pointer"
525+ Move { x, y } -> sk ("move-" <> show x <> "-" <> show y) "transform" ("translate(" <> show x <> "px, " <> show y <> "px)")
526+ Clip X -> sk "clip-x" "overflow-x" "hidden"
527+ Clip Y -> sk "clip-y" "overflow-y" "hidden"
528+ BorderWidth side l -> sk ("border-width-" <> renderKey side <> "-" <> show l) ("border-" <> render side <> "-width") (show l <> "px")
529+ BorderStyle s -> sk ("border-style-" <> renderKey s) "border-style" (render s)
530+ Round corner l -> sk ("round-" <> renderKey corner <> "-" <> show l) ("border-" <> render corner <> "-radius") (show l <> "px")
531+ Shadow s -> sk ("shadow-" <> renderKey s) "box-shadow" (render s)
532+ InnerShadow s -> sk ("inner-shadow-" <> renderKey s) "box-shadow" (render s <> " inset")
533+ FontColor c -> sk ("font-color-" <> renderKey c) "color" (render c)
534+ FontSize l -> sk ("font-size-" <> show l) "font-size" (show l <> "px")
535+ Font f -> sk ("font-" <> removeSpaces f) "font-family" f
536+ FontWeight w -> sk ("font-weight-" <> show w) "font-weight" (show w)
537+
538+removeSpaces :: String -> String
539+removeSpaces = String.replaceAll (String.Pattern " ") (String.Replacement "-")
540+
541+class Renderable x where
542+ render :: x -> String
543+ renderKey :: x -> String
544+
545+instance Renderable Length where
546+ render = case _ of
547+ Px px -> show px <> "px"
548+ Fit -> "fit-content"
549+ Fill -> "100%"
550+ Max px l -> "max(" <> show px <> "px," <> render l <> ")"
551+ Min px l -> "min(" <> show px <> "px," <> render l <> ")"
552+ renderKey = case _ of
553+ Px px -> show px
554+ Fit -> "fit-content"
555+ Fill -> "fill"
556+ Max px l -> "max-" <> show px <> "-" <> renderKey l
557+ Min px l -> "min-" <> show px <> "-" <> renderKey l
558+
559+newtype Color = Color { r :: Int, g :: Int, b :: Int, a :: Int }
560+
561+rgb255 :: Int -> Int -> Int -> Color
562+rgb255 r g b = Color { r, g, b, a: 100 }
563+
564+rgba255 :: Int -> Int -> Int -> Int -> Color
565+rgba255 r g b a = Color { r, g, b, a }
566+
567+rgb :: Number -> Number -> Number -> Color
568+rgb r g b = Color { r: Int.round (r * 255.0), g: Int.round (g * 255.0), b: Int.round (b * 255.0), a: 100 }
569+
570+rgba :: Number -> Number -> Number -> Number -> Color
571+rgba r g b a = Color { r: Int.round (r * 255.0), g: Int.round (g * 255.0), b: Int.round (b * 255.0), a: Int.round (a * 100.0) }
572+
573+instance Renderable Color where
574+ render (Color { r, g, b, a }) = "rgb(" <> show r <> "," <> show g <> "," <> show b <> "," <> show a <> "%)"
575+ renderKey (Color { r, g, b, a }) = show r <> "-" <> show g <> "-" <> show b <> "-" <> show a
576+
577+data Bones :: Type -> Type
578+data Bones msg
579+ = Column (Array (View msg))
580+ | Row (Array (View msg))
581+ | Stack (Array (View msg))
582+ | Wrapper (View msg)
583+ | Text String
584+ | Link String { newTab :: Boolean } (View msg)
585+ | Download String { filename :: Maybe String } (View msg)
586+ | Image String { description :: String }
587+ | TextInput { value :: String, onChange :: String -> msg }
588+ | None
589+
590+type Classes = Array String
591+
592+newtype Mutation = Mutation { extraSkin :: Classes }
593+
594+instance Semigroup Mutation where
595+ append (Mutation x) (Mutation y) = Mutation { extraSkin: x.extraSkin <> y.extraSkin }
596+
597+instance Monoid Mutation where
598+ mempty = Mutation { extraSkin: mempty }
599+
600+newtype SkinGrowth = SkinGrowth
601+ { meat :: Object { key :: String, value :: String }
602+ , hover :: Object { key :: String, value :: String }
603+ , down :: Object { key :: String, value :: String }
604+ }
605+
606+styleSkinGrowth :: SkinGrowth -> String
607+styleSkinGrowth (SkinGrowth o) =
608+ Object.foldMap (\className { key, value } -> "." <> className <> "{" <> key <> ":" <> value <> ";}") o.meat
609+ <> Object.foldMap (\className { key, value } -> "." <> className <> "{" <> key <> ":" <> value <> ";}") o.hover
610+ <> Object.foldMap (\className { key, value } -> "." <> className <> "{" <> key <> ":" <> value <> ";}") o.down
611+
612+instance Semigroup SkinGrowth where
613+ append (SkinGrowth x) (SkinGrowth y) = SkinGrowth $
614+ { meat: Object.union x.meat y.meat
615+ , hover: Object.union x.hover y.hover
616+ , down: Object.union x.down y.down
617+ }
618+
619+instance Monoid SkinGrowth where
620+ mempty = SkinGrowth mempty
621+
622+growSkin :: forall msg. (msg -> Effect Unit) -> Mutation -> View msg -> Writer SkinGrowth VNode
623+growSkin fire (Mutation mutation) ({ meat, hover, down, nerves } /\ bones) = do
624+ let
625+ wiredNerves = Array.foldMap (wireNerve fire) nerves
626+ alignCenter = [ Align X Center, Align Y Center ]
627+ widthFill = [ Width Fill, Height Fill ]
628+ skn ctx = do
629+ meatClasses <- ((_ <> mutation.extraSkin) <<< Array.concat) <$> traverse (skin ctx)
630+ ( meat
631+ <> case ctx of
632+ Span -> mempty
633+ Grid -> widthFill
634+ Flexbox _ -> widthFill
635+ Generic -> widthFill
636+ <> case ctx of
637+ Grid -> alignCenter
638+ Flexbox _ -> alignCenter
639+ Span -> mempty
640+ Generic -> alignCenter
641+ )
642+ let hoverClasses /\ (SkinGrowth hover') = runWriter $ traverse (skin ctx) hover
643+ _ <- traverseWithIndex
644+ ( \key val -> tell $ SkinGrowth $
645+ { meat: Object.empty
646+ , hover: Object.singleton (key <> "-hover:hover") val
647+ , down: Object.empty
648+ }
649+ )
650+ hover'.meat
651+ let downClasses /\ (SkinGrowth down') = runWriter $ traverse (skin ctx) down
652+ _ <- traverseWithIndex
653+ ( \key val -> tell $ SkinGrowth $
654+ { meat: Object.empty
655+ , hover: Object.empty
656+ , down: Object.singleton (key <> "-down:active") val
657+ }
658+ )
659+ down'.meat
660+
661+ pure $ meatClasses <> map (_ <> "-hover") (Array.concat hoverClasses) <> map (_ <> "-down") (Array.concat downClasses)
662+
663+ case bones of
664+ Text t -> (\c -> string "span" c wiredNerves t) <$> (skn Span)
665+ Wrapper x -> do
666+ classes <- (skn (Flexbox X) <> sk "display-flex" "display" "flex" <> sk "flex-direction-row" "flex-direction" "row")
667+ x' <- growSkin fire mempty x
668+ pure $ h "div" classes wiredNerves [ x' ]
669+ Stack children -> do
670+ classes <- (skn Grid <> sk "display-grid" "display" "grid")
671+ extraSkin <- sk "grid-row-1" "grid-row" "1" <> sk "grid-column-1" "grid-column" "1"
672+ children' <- (traverse (growSkin fire $ Mutation { extraSkin }) children)
673+ pure $ h "div" classes wiredNerves children'
674+
675+ Row children -> do
676+ classes <- (skn (Flexbox X) <> sk "display-flex" "display" "flex" <> sk "flex-direction-row" "flex-direction" "row")
677+ children' <- traverse (growSkin fire mempty) children
678+ pure $ h "div" classes wiredNerves children'
679+ Column children -> do
680+ classes <- (skn (Flexbox Y) <> sk "display-flex" "display" "flex" <> sk "flex-direction-column" "flex-direction" "column")
681+ children' <- traverse (growSkin fire mempty) children
682+ pure $ h "div" classes wiredNerves children'
683+ Link href { newTab } child -> do
684+ classes <- (skn (Flexbox X) <> sk "display-flex" "display" "flex" <> sk "flex-direction-row" "flex-direction" "row")
685+ child' <- growSkin fire mempty child
686+ pure $ hWith "a"
687+ { href
688+ , rel: "noopener noreferrer"
689+ , target: if newTab then "_blank" else "_self"
690+ }
691+ classes
692+ wiredNerves
693+ [ child' ]
694+
695+ Download href { filename } child -> do
696+ classes <- (skn (Flexbox X) <> sk "display-flex" "display" "flex" <> sk "flex-direction-row" "flex-direction" "row")
697+ child' <- growSkin fire mempty child
698+ pure $ hWith "a"
699+ { href
700+ , download: Maybe.fromMaybe "" filename
701+ }
702+ classes
703+ wiredNerves
704+ [ child' ]
705+ Image src { description } -> (\c -> hWith "img" { src, alt: description } c wiredNerves []) <$> (skn Generic)
706+ TextInput { value, onChange } -> do
707+ classes <- skn Generic
708+ let
709+ onInputNerve = WiredNerves $ Object.singleton "input" $ \ev ->
710+ case Event.currentTarget ev >>= HTMLInputElement.fromEventTarget of
711+ Nothing -> pure unit
712+ Just inputEl -> do
713+ val <- HTMLInputElement.value inputEl
714+ fire $ onChange val
715+ pure $ hWith "input" { value } classes (wiredNerves <> onInputNerve) []
716+ None -> pure $ h "div" mempty wiredNerves []
717+
718+grow :: forall msg. (msg -> Effect Unit) -> View msg -> { node :: VNode, style :: String }
719+grow fire v =
720+ let
721+ node /\ skinGrowth = runWriter (growSkin fire mempty v)
722+ in
723+ { node, style: styleSkinGrowth skinGrowth }
724+