@@ -1,724 +0,0 @@
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
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
107−type UIView msg = GenericUIView (Array (View msg)) msg
109−data GenericUI children msg a = UI (GenericUIView children msg) a
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')
114−instance (Monoid children, Monoid a) => Monoid (GenericUI children msg a) where
115− mempty = UI mempty mempty
117−type UI msg a = GenericUI (Array (View msg)) msg a
119−instance Functor (GenericUI children msg) where
120− map f (UI v a) = UI v $ f a
122−instance Monoid children => Apply (GenericUI children msg) where
123− apply (UI views f) (UI views' a) = UI (views <> views') (f a)
125−instance Monoid children => Applicative (GenericUI children msg) where
128−instance Monoid children => Bind (GenericUI children msg) where
129− bind (UI views a) f =
133− UI (views <> views') b
135−instance Monoid children => Monad (GenericUI children msg)
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
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
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
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
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)
160− } /\ Link url { newTab: false } (Maybe.fromMaybe none $ Array.head children)
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)
173− } /\ Link url { newTab: true } (Maybe.fromMaybe none $ Array.head children)
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)
186− } /\ Download url { filename: Nothing } (Maybe.fromMaybe none $ Array.head children)
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)
199− } /\ Download url { filename: Just filename } (Maybe.fromMaybe none $ Array.head children)
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
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
212−string :: String -> Classes -> WiredNerves -> String -> VNode
213−string elem classes (WiredNerves on) s =
215− { attrs: Object.singleton "class" (Array.intercalate " " classes)
217− , style: Object.empty
218− , props: Object.empty
223−h :: String -> Classes -> WiredNerves -> Array VNode -> VNode
224−h elem classes (WiredNerves on) children =
226− { attrs: Object.singleton "class" (Array.intercalate " " classes)
228− , props: Object.empty
229− , style: Object.empty
234−hWith :: forall props. Homogeneous props String => String -> Record props -> Classes -> WiredNerves -> Array VNode -> VNode
235−hWith elem props classes (WiredNerves on) children =
237− { attrs: Object.singleton "class" (Array.intercalate " " classes)
239− , props: Object.fromHomogeneous props
240− , style: Object.empty
245−data Length = Px Int | Fill | Fit | Max Int Length | Min Int Length
247−data Alignment = Start | Center | End
249−data Direction = X | Y
251−n :: forall ch msg. Monoid ch => Nerve msg -> GenericUI ch msg Unit
252−n nerve = UI (mempty :: GenericUIView ch msg) { nerves = [ nerve ] } mempty
254−onClick :: forall ch msg. Monoid ch => msg -> GenericUI ch msg Unit
255−onClick msg = n $ OnClick msg
257−onPress :: forall ch msg. Monoid ch => (KeyboardEvent -> msg) -> GenericUI ch msg Unit
258−onPress msg = n $ OnPress msg
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
264−m :: forall ch msg. Monoid ch => Meat -> GenericUI ch msg Unit
265−m meat = UI (mempty :: GenericUIView ch msg) { meat = [ meat ] } mempty
267−spacing :: forall ch msg. Monoid ch => { x :: Int, y :: Int } -> GenericUI ch msg Unit
268−spacing { x, y } = m $ Spacing x y
270−explain :: forall ch msg. Monoid ch => Warn (TypeError.Text "Debug explain present") => GenericUI ch msg Unit
273−align :: forall ch msg. Monoid ch => Direction -> Alignment -> GenericUI ch msg Unit
274−align dir al = m $ Align dir al
276−width :: forall ch msg. Monoid ch => Length -> GenericUI ch msg Unit
277−width l = m $ Width l
279−height :: forall ch msg. Monoid ch => Length -> GenericUI ch msg Unit
280−height l = m $ Height l
282−wrapped :: forall ch msg. Monoid ch => GenericUI ch msg Unit
285−bgColor :: forall ch msg. Monoid ch => Color -> GenericUI ch msg Unit
286−bgColor c = m $ BackgroundColor c
288−padding :: forall ch msg. Monoid ch => Side -> Int -> GenericUI ch msg Unit
289−padding s l = m $ Padding s l
291−spread :: forall ch msg. Monoid ch => GenericUI ch msg Unit
294−opacity :: forall ch msg. Monoid ch => Number -> GenericUI ch msg Unit
295−opacity o = m $ Opacity o
297−pointer :: forall ch msg. Monoid ch => GenericUI ch msg Unit
300−move :: forall ch msg. Monoid ch => { x :: Int, y :: Int } -> GenericUI ch msg Unit
303−clip :: forall ch msg. Monoid ch => Direction -> GenericUI ch msg Unit
304−clip dir = m $ Clip dir
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
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
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 ]
315−border :: forall ch msg. Monoid ch => Side -> Int -> GenericUI ch msg Unit
316−border s l = m $ BorderWidth s l
318−borderStyle :: forall ch msg. Monoid ch => BorderStyle -> GenericUI ch msg Unit
319−borderStyle s = m $ BorderStyle s
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 ]
324−round :: forall ch msg. Monoid ch => Corner -> Int -> GenericUI ch msg Unit
325−round c l = m $ Round c l
327−shadow :: forall ch msg. Monoid ch => ShadowCfg -> GenericUI ch msg Unit
328−shadow cfg = m $ Shadow $ ShadowCfg cfg
330−innerShadow :: forall ch msg. Monoid ch => ShadowCfg -> GenericUI ch msg Unit
331−innerShadow cfg = m $ InnerShadow $ ShadowCfg cfg
333−font :: forall ch msg. Monoid ch => String -> GenericUI ch msg Unit
336−fontColor :: forall ch msg. Monoid ch => Color -> GenericUI ch msg Unit
337−fontColor c = m $ FontColor c
339−fontSize :: forall ch msg. Monoid ch => Int -> GenericUI ch msg Unit
340−fontSize f = m $ FontSize f
342−fontWeight :: forall ch msg. Monoid ch => Int -> GenericUI ch msg Unit
343−fontWeight f = m $ FontWeight f
348− | Align Direction Alignment
352− | BackgroundColor Color
357− | Move { x :: Int, y :: Int }
359− | BorderWidth Side Int
360− | BorderStyle BorderStyle
363− | InnerShadow Shadow
371−type ShadowCfg = { offset :: { x :: Int, y :: Int }, size :: Number, blur :: Number, color :: Color }
373−newtype Shadow = ShadowCfg ShadowCfg
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
379−data Corner = TopLeft | TopRight | BottomRight | BottomLeft
381−instance Renderable Corner where
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"
393−data BorderStyle = Solid | Dashed | Dotted
395−instance Renderable BorderStyle where
400− renderKey = case _ of
405−data Side = Top | Right | Bottom | Left
407−instance Renderable Side where
413− renderKey = case _ of
421− | OnPress (KeyboardEvent -> msg)
424−newtype WiredNerves = WiredNerves (Object (Event -> Effect Unit))
426−instance Semigroup WiredNerves where
427− append (WiredNerves x) (WiredNerves y) =
428− WiredNerves $ Object.unionWith (\f g ev -> f ev *> g ev) x y
430−instance Monoid WiredNerves where
431− mempty = WiredNerves Object.empty
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
444− { nerves :: Array (Nerve msg)
445− , meat :: Array Meat
446− , hover :: Array Meat
447− , down :: Array Meat
450−none :: forall msg. View msg
451−none = mempty /\ None
453−newtype Skin = Skin (Object String)
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 }
460−instance Semigroup Skin where
461− append (Skin x) (Skin y) = Skin $ Object.union x y
463−instance Monoid Skin where
464− mempty = Skin Object.empty
466−data Context = Grid | Flexbox Direction | Generic | Span
468−skin :: Context -> Meat -> Writer SkinGrowth Classes
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
479− X -> "justify-items"
489− sk ("align-grid-" <> k <> "-" <> v) k v
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"
503− Start -> "flex-start"
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"
514− BackgroundColor color -> sk ("bg-color-" <> renderKey color) "background-color" (render color)
517− ("padding-" <> renderKey side <> "-" <> show l)
518− ("padding-" <> render side)
520− Spread -> case ctx of
521− Flexbox _ -> sk "spread" "justify-content" "space-between"
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)
538−removeSpaces :: String -> String
539−removeSpaces = String.replaceAll (String.Pattern " ") (String.Replacement "-")
541−class Renderable x where
542− render :: x -> String
543− renderKey :: x -> String
545−instance Renderable Length where
547− Px px -> show px <> "px"
548− Fit -> "fit-content"
550− Max px l -> "max(" <> show px <> "px," <> render l <> ")"
551− Min px l -> "min(" <> show px <> "px," <> render l <> ")"
552− renderKey = case _ of
554− Fit -> "fit-content"
556− Max px l -> "max-" <> show px <> "-" <> renderKey l
557− Min px l -> "min-" <> show px <> "-" <> renderKey l
559−newtype Color = Color { r :: Int, g :: Int, b :: Int, a :: Int }
561−rgb255 :: Int -> Int -> Int -> Color
562−rgb255 r g b = Color { r, g, b, a: 100 }
564−rgba255 :: Int -> Int -> Int -> Int -> Color
565−rgba255 r g b a = Color { r, g, b, a }
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 }
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) }
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
577−data Bones :: Type -> Type
579− = Column (Array (View msg))
580− | Row (Array (View msg))
581− | Stack (Array (View msg))
582− | Wrapper (View msg)
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 }
590−type Classes = Array String
592−newtype Mutation = Mutation { extraSkin :: Classes }
594−instance Semigroup Mutation where
595− append (Mutation x) (Mutation y) = Mutation { extraSkin: x.extraSkin <> y.extraSkin }
597−instance Monoid Mutation where
598− mempty = Mutation { extraSkin: mempty }
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 }
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
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
619−instance Monoid SkinGrowth where
620− mempty = SkinGrowth mempty
622−growSkin :: forall msg. (msg -> Effect Unit) -> Mutation -> View msg -> Writer SkinGrowth VNode
623−growSkin fire (Mutation mutation) ({ meat, hover, down, nerves } /\ bones) = do
625− wiredNerves = Array.foldMap (wireNerve fire) nerves
626− alignCenter = [ Align X Center, Align Y Center ]
627− widthFill = [ Width Fill, Height Fill ]
629− meatClasses <- ((_ <> mutation.extraSkin) <<< Array.concat) <$> traverse (skin ctx)
634− Flexbox _ -> widthFill
635− Generic -> widthFill
638− Flexbox _ -> alignCenter
640− Generic -> alignCenter
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
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
661− pure $ meatClasses <> map (_ <> "-hover") (Array.concat hoverClasses) <> map (_ <> "-down") (Array.concat downClasses)
664− Text t -> (\c -> string "span" c wiredNerves t) <$> (skn Span)
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'
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
688− , rel: "noopener noreferrer"
689− , target: if newTab then "_blank" else "_self"
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
700− , download: Maybe.fromMaybe "" filename
705− Image src { description } -> (\c -> hWith "img" { src, alt: description } c wiredNerves []) <$> (skn Generic)
706− TextInput { value, onChange } -> do
707− classes <- skn Generic
709− onInputNerve = WiredNerves $ Object.singleton "input" $ \ev ->
710− case Event.currentTarget ev >>= HTMLInputElement.fromEventTarget of
711− Nothing -> pure unit
713− val <- HTMLInputElement.value inputEl
715− pure $ hWith "input" { value } classes (wiredNerves <> onInputNerve) []
716− None -> pure $ h "div" mempty wiredNerves []
718−grow :: forall msg. (msg -> Effect Unit) -> View msg -> { node :: VNode, style :: String }
721− node /\ skinGrowth = runWriter (growSkin fire mempty v)
723− { node, style: styleSkinGrowth skinGrowth }