/
Core.purs
595 lines (484 loc) · 16 KB
/
Core.purs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
module Chameleon.Styled.Core
( Anim
, ClassName(..)
, ElemName(..)
, ElemScope(..)
, InlineStyle(..)
, Style
, StyleDecl
, StyleMap
, StyleT
, anim
, class HtmlStyled
, class IsDecl
, class IsStyle
, decl
, declWith
, mergeDecl
, registerStyleMap
, runStyleT
, styleKeyedLeaf
, styleKeyedLeafNamed
, styleKeyedNode
, styleKeyedNodeNamed
, styleLeaf
, styleLeafNamed
, styleNode
, styleNodeNamed
, toStyle
) where
import Prelude
import Chameleon (class Html, class MapMaybe, Prop(..))
import Chameleon as C
import Chameleon.Class as VDC
import Chameleon.HTML.Attributes as VP
import Chameleon.HTML.Elements as VDE
import Chameleon.Transformers.Accum.Class (class Accum, class TellAccum, censorAccum, tellAccum)
import Chameleon.Transformers.Accum.Trans (AccumT(..), runAccumT)
import Chameleon.Transformers.Ctx.Trans (CtxT(..))
import Chameleon.Transformers.FunctorTrans.Class (class FunctorTrans)
import Chameleon.Transformers.FunctorTrans.Class as FT
import Chameleon.Transformers.OutMsg.Class (class OutMsg, class RunOutMsg, fromOutHtml, runOutMsg)
import Chameleon.Types (ElemKeyedNode, ElemLeaf, ElemNode, ElemKeyedLeaf)
import Data.Array as Array
import Data.Foldable (fold, foldr)
import Data.HashMap (HashMap)
import Data.HashMap as HashMap
import Data.Hashable (class Hashable, hash)
import Data.Int as Int
import Data.Maybe (Maybe(..), isJust)
import Data.Newtype (class Newtype, unwrap)
import Data.Ord (abs)
import Data.String (Pattern(..), Replacement(..))
import Data.String as Str
import Data.Tuple (Tuple(..))
import Data.Tuple.Nested (type (/\), (/\))
class IsStyle a where
toStyle :: a -> Style
newtype InlineStyle = InlineStyle String
newtype ClassName = ClassName String
newtype StyleDecl = StyleDecl (Array (Maybe Selector /\ Array String))
newtype Selector = Selector String
newtype Style = Style
{ inline :: Array InlineStyle
, classes :: Array ClassName
, declarations :: Array StyleDecl
, animations :: Array Anim
}
newtype AnimName = AnimName String
newtype HashedAnimName = HashedAnimName String
newtype AnimDecl = AnimDecl (Array AnimStep)
newtype Anim = Anim (AnimName /\ AnimDecl)
newtype AnimStep = AnimStep (String /\ Array String)
newtype ElemName = ElemName String
newtype ElemScope = ElemScope String
-------------------------------------------------------------------------------
-- StyleMap
-------------------------------------------------------------------------------
class Html html <= HtmlStyled (html :: Type -> Type) where
registerStyleMap :: forall msg. StyleMap -> html msg -> html msg
newtype StyleMap = StyleMap { anim :: AnimMap, decl :: DeclMap }
type DeclMap = HashMap ClassName StyleDecl
type AnimMap = HashMap HashedAnimName AnimDecl
replaceIds :: HashMap String String -> StyleDecl -> StyleDecl
replaceIds replaceMap (StyleDecl styleDecls) =
StyleDecl (map replaceEntry styleDecls)
where
replaceEntry :: Maybe Selector /\ Array String -> Maybe Selector /\ Array String
replaceEntry (selector /\ strs) =
selector /\ map (replaceByMap replaceMap) strs
getStyleMap :: Maybe ElemName -> Style -> StyleMap /\ Style
getStyleMap elemName style@(Style { declarations, animations }) =
styleMap /\ newStyle
where
styleMap :: StyleMap
styleMap = StyleMap
{ decl: declMap
, anim: animMap
}
animInfo :: Array (HashedAnimName /\ AnimName /\ AnimDecl)
animInfo = animations
# map
( \(Anim (animName /\ animDecl)) ->
mkHashedAnimName animDecl /\ animName /\ animDecl
)
declMap :: DeclMap
declMap = HashMap.fromArrayBy mkClassName identity declarationsReplaced
declarationsReplaced :: Array StyleDecl
declarationsReplaced = map (replaceIds animReplaceMap) declarations
animMap :: AnimMap
animMap =
HashMap.fromArrayBy
(\(key /\ _) -> key)
(\(_ /\ _ /\ value) -> value)
animInfo
animReplaceMap :: HashMap String String
animReplaceMap =
HashMap.fromArrayBy
(\(_ /\ AnimName animName /\ _) -> "$" <> animName)
(\(HashedAnimName hashedAnimName /\ _ /\ _) -> hashedAnimName)
animInfo
mkHashedAnimName :: AnimDecl -> HashedAnimName
mkHashedAnimName animDecl = HashedAnimName (prefixAnim <> niceHash animDecl)
mkClassName :: StyleDecl -> ClassName
mkClassName styleDecl = ClassName (prefix <> niceHash styleDecl)
newStyle :: Style
newStyle =
let
StyleMap { decl } = styleMap
in
style
# \(Style rec) -> Style $ rec
{ declarations = []
, classes = HashMap.keys decl
}
prefix =
( case elemName of
Just (ElemName elemName') -> elemName'
Nothing -> "hashed"
) <> "-"
prefixAnim = prefix <> "-anim-"
niceHash :: forall a. Hashable a => a -> String
niceHash val =
let
numericHash :: Int
numericHash = hash val
stringHash :: String
stringHash =
if numericHash < 0 then
show (abs numericHash) <> "0"
else
show numericHash <> "1"
fixedLength :: Int
fixedLength = 10
length :: Int
length = Str.length stringHash
times :: Int
times = Int.ceil (Int.toNumber fixedLength / Int.toNumber length)
in
Array.replicate times stringHash
# fold
# Str.take fixedLength
printStyleMap :: StyleMap -> String
printStyleMap (StyleMap styleMap) =
printDeclMap styleMap.decl <> "\n\n" <> printAnimMap styleMap.anim
printAnimMap :: AnimMap -> String
printAnimMap animMap =
HashMap.toArrayBy printEntry animMap
# Str.joinWith "\n"
where
printEntry :: HashedAnimName -> AnimDecl -> String
printEntry (HashedAnimName animName) (AnimDecl animSteps) =
Str.joinWith "\n"
[ "@keyframes " <> animName <> " {"
, Str.joinWith "\n" (map printAnimStep animSteps)
, "}"
]
printAnimStep :: AnimStep -> String
printAnimStep (AnimStep (stepName /\ strs)) =
Str.joinWith "\n"
[ stepName <> " {"
, Str.joinWith ";" strs
, "}"
]
printDeclMap :: DeclMap -> String
printDeclMap declMap =
HashMap.toArrayBy printEntry declMap
# join
# Str.joinWith "\n"
where
printEntry :: ClassName -> StyleDecl -> Array String
printEntry className (StyleDecl styleDecls) =
map (printScopedEntry className) styleDecls
printScopedEntry :: ClassName -> Maybe Selector /\ Array String -> String
printScopedEntry (ClassName className) (selector /\ styleDecl) =
Str.joinWith ""
[ "."
, className
, case selector of
Nothing -> ""
Just (Selector str) -> str
, " {\n"
, Str.joinWith "\n" (map (_ <> ";") styleDecl)
, "\n}"
]
foldStyleMaps :: Array StyleMap -> StyleMap
foldStyleMaps = foldr next init
where
next :: StyleMap -> StyleMap -> StyleMap
next (StyleMap styleMap1) (StyleMap styleMap2) = StyleMap
{ anim: HashMap.union styleMap1.anim styleMap2.anim
, decl: HashMap.union styleMap1.decl styleMap2.decl
}
init :: StyleMap
init = StyleMap { anim: HashMap.empty, decl: HashMap.empty }
viewStylemap :: forall html msg. Html html => StyleMap -> html msg
viewStylemap styleMap =
VDE.style_ [ VDC.text $ printStyleMap styleMap ]
decl :: forall decl. IsDecl decl => decl -> StyleDecl
decl dec = StyleDecl [ Nothing /\ [ mergeDecl dec ] ]
declWith :: forall decl. IsDecl decl => String -> decl -> StyleDecl
declWith selector dec = StyleDecl
[ Just (Selector selector) /\ [ mergeDecl dec ] ]
anim :: String -> Array (String /\ Array String) -> Anim
anim animName steps = Anim
( AnimName animName /\
AnimDecl (map (\(stepName /\ strs) -> AnimStep (stepName /\ strs)) steps)
)
-------------------------------------------------------------------------------
-- Impl
-------------------------------------------------------------------------------
newtype StyleT html a = StyleT (AccumT (Array StyleMap) html a)
instance FunctorTrans StyleT where
lift :: forall html a. Functor html => html a -> StyleT html a
lift html = StyleT $ FT.lift html
derive instance (Functor html) => Functor (StyleT html)
derive newtype instance (Html html) => Html (StyleT html)
derive newtype instance (Html html) => MapMaybe (StyleT html)
instance Html html => HtmlStyled (StyleT html) where
registerStyleMap styleMap (StyleT accumT) =
StyleT $ tellAccum [ styleMap ] accumT
runStyleT :: forall html a. Html html => StyleT html a -> html a
runStyleT (StyleT accumT) =
let
html /\ styleMaps = runAccumT accumT
in
C.div_
[ viewStylemap (foldStyleMaps styleMaps)
, html
]
instance (TellAccum acc html) => TellAccum acc (StyleT html) where
tellAccum acc (StyleT (AccumT styleMaps html)) = StyleT $ (AccumT styleMaps (tellAccum acc html))
instance (Accum acc html) => Accum acc (StyleT html) where
censorAccum f (StyleT (AccumT styleMaps html)) = StyleT $ (AccumT styleMaps (censorAccum f html))
instance (OutMsg out html) => OutMsg out (StyleT html) where
fromOutHtml (StyleT (AccumT styleMaps html)) = StyleT $ (AccumT styleMaps (fromOutHtml html))
instance (RunOutMsg out html) => RunOutMsg out (StyleT html) where
runOutMsg (StyleT (AccumT styleMaps html)) = StyleT $ (AccumT styleMaps (runOutMsg html))
---
instance (HtmlStyled html) => HtmlStyled (CtxT ctx html) where
registerStyleMap styleMap (CtxT mkHtml) = CtxT
\ctx -> registerStyleMap styleMap $ mkHtml ctx
-------------------------------------------------------------------------------
-- Style Elements
-------------------------------------------------------------------------------
styleNode
:: forall html style a
. Html html
=> HtmlStyled html
=> IsStyle style
=> ElemNode html a
-> style
-> ElemNode html a
styleNode =
styleNodeNamed Nothing Nothing
styleNodeNamed
:: forall html style a
. Html html
=> HtmlStyled html
=> IsStyle style
=> Maybe ElemName
-> Maybe ElemScope
-> ElemNode html a
-> style
-> ElemNode html a
styleNodeNamed elemName elemScope elem someStyle props children =
registerStyleMap styleMap $
elem
(addIds elemName elemScope $ addStyle newStyle props)
children
where
oldStyle = toStyle someStyle
styleMap /\ newStyle = getStyleMap elemName oldStyle
styleLeaf
:: forall html style a
. Html html
=> HtmlStyled html
=> IsStyle style
=> ElemLeaf html a
-> style
-> ElemLeaf html a
styleLeaf =
styleLeafNamed Nothing Nothing
styleLeafNamed
:: forall html style a
. Html html
=> HtmlStyled html
=> IsStyle style
=> Maybe ElemName
-> Maybe ElemScope
-> ElemLeaf html a
-> style
-> ElemLeaf html a
styleLeafNamed elemName elemScope elem someStyle props =
registerStyleMap styleMap $
elem
(addIds elemName elemScope $ addStyle newStyle props)
where
oldStyle = toStyle someStyle
styleMap /\ newStyle = getStyleMap elemName oldStyle
styleKeyedNode
:: forall html style a
. Html html
=> HtmlStyled html
=> IsStyle style
=> ElemKeyedNode html a
-> style
-> ElemKeyedNode html a
styleKeyedNode =
styleKeyedNodeNamed Nothing Nothing
styleKeyedNodeNamed
:: forall html style a
. Html html
=> HtmlStyled html
=> IsStyle style
=> Maybe ElemName
-> Maybe ElemScope
-> ElemKeyedNode html a
-> style
-> ElemKeyedNode html a
styleKeyedNodeNamed elemName elemScope elem someStyle props children =
registerStyleMap styleMap $
elem
(addIds elemName elemScope $ addStyle newStyle props)
children
where
oldStyle = toStyle someStyle
styleMap /\ newStyle = getStyleMap elemName oldStyle
styleKeyedLeaf
:: forall html style a
. Html html
=> HtmlStyled html
=> IsStyle style
=> ElemKeyedLeaf html a
-> style
-> ElemKeyedLeaf html a
styleKeyedLeaf = styleKeyedLeafNamed Nothing Nothing
styleKeyedLeafNamed
:: forall html style a
. Html html
=> HtmlStyled html
=> IsStyle style
=> Maybe ElemName
-> Maybe ElemScope
-> ElemKeyedLeaf html a
-> style
-> ElemKeyedLeaf html a
styleKeyedLeafNamed elemName elemScope elem someStyle props =
registerStyleMap styleMap $
elem
(addIds elemName elemScope $ addStyle newStyle props)
where
oldStyle = toStyle someStyle
styleMap /\ newStyle = getStyleMap elemName oldStyle
-------------------------------------------------------------------------------
-- Instances
-------------------------------------------------------------------------------
derive instance Newtype InlineStyle _
derive instance Newtype ClassName _
derive newtype instance Semigroup Style
derive newtype instance Monoid Style
derive newtype instance Hashable HashedAnimName
derive instance Eq HashedAnimName
derive newtype instance Hashable AnimDecl
derive instance Eq AnimDecl
derive newtype instance Hashable AnimStep
derive instance Eq AnimStep
derive newtype instance Hashable ClassName
derive instance Eq ClassName
derive newtype instance Hashable Selector
derive instance Eq Selector
derive newtype instance Hashable StyleDecl
derive newtype instance Semigroup StyleDecl
derive instance Eq StyleDecl
derive instance Newtype ElemName _
derive instance Eq ElemName
instance IsStyle Style where
toStyle = identity
instance IsStyle String where
toStyle str = mempty
# \(Style rec) -> Style $ rec { declarations = [ decl str ] }
instance IsStyle Unit where
toStyle _ = mempty
instance IsStyle (Array String) where
toStyle xs = mempty
# \(Style rec) -> Style $ rec
{ declarations =
[ StyleDecl
[ Nothing /\ map mergeDecl xs ]
]
}
else instance IsStyle a => IsStyle (Array a) where
toStyle xs = fold (toStyle <$> xs)
instance IsStyle ClassName where
toStyle c = mempty
# \(Style rec) -> Style $ rec { classes = [ c ] }
instance IsStyle a => IsStyle (Maybe a) where
toStyle = case _ of
Just x -> toStyle x
Nothing -> mempty
instance IsStyle StyleDecl where
toStyle c = mempty
# \(Style rec) -> Style $ rec { declarations = [ c ] }
instance IsStyle Anim where
toStyle anim' = mempty
# \(Style rec) -> Style $ rec { animations = [ anim' ] }
instance (IsStyle a, IsStyle b) => IsStyle (a /\ b) where
toStyle (s1 /\ s2) = toStyle s1 <> toStyle s2
class IsDecl a where
mergeDecl :: a -> String
instance IsDecl String where
mergeDecl str = str
instance IsDecl a => IsDecl (Array a) where
mergeDecl xs = Str.joinWith ";" (mergeDecl <$> xs)
instance IsDecl Unit where
mergeDecl _ = ""
-------------------------------------------------------------------------------
-- Utils
-------------------------------------------------------------------------------
inlineToProp :: forall a. Array InlineStyle -> Prop a
inlineToProp inlineStyles = VP.style (Str.joinWith ";" $ map unwrap inlineStyles)
classesToProp :: forall a. Array ClassName -> Prop a
classesToProp classes = VP.className (Str.joinWith " " $ unwrap <$> classes)
insertProp :: forall a. String -> (Maybe (Prop a) -> Prop a) -> Array (Prop a) -> Array (Prop a)
insertProp key fn props =
if isJust $ Array.find isKey props then
map (\x -> if isKey x then fn (Just x) else x) props
else
props <> [ fn Nothing ]
where
isKey = case _ of
Attr key' _ -> key' == key
Event key' _ -> key' == key
addStyle :: forall a. Style -> Array (Prop a) -> Array (Prop a)
addStyle style props =
( props
# insertProp "style" mapStyle
# insertProp "className" mapClassName
)
where
Style { inline, classes } = toStyle style
mapStyle = case _ of
Just (Attr "style" s) -> inlineToProp (inline <> [ InlineStyle s ])
_ -> inlineToProp inline
mapClassName = case _ of
Just (Attr "className" cs) -> classesToProp (classes <> [ ClassName cs ])
_ -> classesToProp classes
addIds :: forall a. Maybe ElemName -> Maybe ElemScope -> Array (Prop a) -> Array (Prop a)
addIds elemName elemScope props =
let
elemName' = case elemName of
Nothing -> []
Just (ElemName name) ->
[ C.attr "data-el" name ]
elemScope' = case elemScope of
Nothing -> []
Just (ElemScope scope) | elemName == Just (ElemName "root") ->
[ C.attr "data-scope" scope ]
_ -> []
in
elemName' <> elemScope' <> props
replaceByMap :: HashMap String String -> String -> String
replaceByMap replaceMap str =
HashMap.toArrayBy Tuple replaceMap
# foldr (\(key /\ value) -> Str.replace (Pattern key) (Replacement value)) str