@@ -1,724 +0,0 @@
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−