git.iko.soy/rowtype-yoga/psfp
on da9406d help sign in
rowtype-yoga/psfp/components/src/Yoga/JSS.purs
184 lines 6.0 kB history raw
1module JSS where
3import Prelude
4import CSS (App(..), BackgroundImage, Color, Key(..), Keyframes(..), Path(..), Refinement(..), Rule(..), Selector(..), StyleM, Value(..), cssStringRGBA, plain, predicate, runS, value)
5import Data.Foldable (foldMap)
6import Data.Int (round)
7import Data.Symbol (class IsSymbol, SProxy(..), reflectSymbol)
8import Data.Tuple (Tuple(..))
9import Foreign (unsafeToForeign)
10import Foreign.Object (Object)
11import Foreign.Object as Object
12import Partial.Unsafe (unsafeCrashWith)
13import Prim.RowList (class RowToList, Nil, kind RowList)
14import Record as Record
15import Record.Builder (Builder)
16import Record.Builder as Builder
17import Simple.JSON (class WriteForeign, write, writeImpl)
18import Type.Prelude (RLProxy, Proxy(..))
19import Type.Row as R
20import Type.Row.Homogeneous (class Homogeneous)
21import Type.RowList as RL
22import Untagged.Union (type (|+|))
23import Untagged.Castable (cast)
25newtype JSSClasses theme props r = JSSClasses ({ | theme } -> { | r })
27jssClasses ∷
28 ∀ theme props row rowRL to.
29 JSSAbleFields props rowRL row () to =>
30 RowToList row rowRL =>
31 Homogeneous to (JSSElem props) =>
32 JSSAble props (Record row) =>
33 ({ | theme } -> { | row }) -> JSSClasses theme props to
34jssClasses f = JSSClasses f'
35 where
36 f' theme = built
37 where
38 rec = f theme
40 built ∷ Record to
41 built = Builder.build builder {}
43 rlp = RL.RLProxy ∷ RL.RLProxy rowRL
45 propsy = Proxy ∷ Proxy props
47 builder ∷ Builder.Builder (Record ()) (Record to)
48 builder = jssifyFields propsy rlp rec
50data JSSElem props
51 = PrimitiveJss (String |+| Int |+| Number)
52 | ArrayJss (Array (JSSElem props))
53 | PropsJss (props -> JSSElem props)
54 | NestedJss (Object (JSSElem props))
56instance semigroupJssElem ∷ Semigroup (JSSElem props) where
57 append = case _, _ of
58 PrimitiveJss p1, PrimitiveJss p2
59 | p1 == p2 -> PrimitiveJss p1
60 NestedJss n1, NestedJss n2 -> NestedJss (n1 <> n2)
61 ArrayJss a1, ArrayJss a2 -> ArrayJss (a1 <> a2)
62 NestedJss n1, PropsJss fn ->
63 PropsJss \props -> case fn props of
64 NestedJss n2 -> NestedJss (n1 <> n2)
65 other -> do
66 unsafeCrashWith "Untreated branch (1), fix me"
67 PropsJss fn1, PropsJss fn2 ->
68 PropsJss \props -> do
69 case fn1 props, fn2 props of
70 n1@(NestedJss _), n2@(NestedJss _) -> n1 <> n2
71 p1@(PrimitiveJss _), p2@(PrimitiveJss _) -> p1 <> p2
72 x, y -> do
73 unsafeCrashWith "Untreated branch (2), fix me"
74 x, y -> do
75 unsafeCrashWith "Untreated branch (3), fix me"
77instance wfJSSElem ∷ WriteForeign (JSSElem props) where
78 writeImpl = case _ of
79 PrimitiveJss p -> unsafeToForeign p
80 ArrayJss proper -> write (map writeImpl proper)
81 PropsJss proper -> unsafeToForeign (map writeImpl proper)
82 NestedJss proper -> writeImpl (map writeImpl proper)
84class JSSAble p a | a -> p where
85 jss ∷ a -> JSSElem p
87instance jssAbleJssElem ∷ JSSAble p (JSSElem p) where
88 jss = identity
90instance jssAbleColor ∷ JSSAble p Color where
91 jss c = PrimitiveJss (cast (cssStringRGBA c))
93instance jssAbleBackgroundImage ∷ JSSAble p BackgroundImage where
94 jss v = PrimitiveJss (cast (render (value v)))
95 where
96 render (Value val) = plain val
98instance jssAbleString ∷ JSSAble p String where
99 jss = cast >>> PrimitiveJss
101instance jssAbleInt ∷ JSSAble p Int where
102 jss = cast >>> PrimitiveJss
104instance jssAbleNumber ∷ JSSAble p Number where
105 jss = cast >>> PrimitiveJss
107instance jssAbleArray ∷ JSSAble p a => JSSAble p (Array a) where
108 jss arr = ArrayJss (jss <$> arr)
110instance jssAbleWithProps ∷ JSSAble p jss => JSSAble p (p -> jss) where
111 jss = propsJss
113instance jssAbleNested ∷ JSSAble p jss => JSSAble p (Object jss) where
114 jss = map jss >>> NestedJss
116instance jssAbleCss ∷ JSSAble p (StyleM Unit) where
117 jss someCss = NestedJss (foldMap ruleToObject rules)
118 where
119 rules = runS someCss
121 ruleToObject = case _ of
122 Property (Key k) (Value v) -> Object.singleton (plain k) (jss (plain v))
123 Nested (Sub (Selector (Refinement preds) (Elem el))) rules -> Object.singleton (el <> foldMap predicate preds) (jss (foldMap ruleToObject rules))
124 Keyframe (Keyframes name frames) ->
125 frames
126 # foldMap \(Tuple pos rules) ->
127 Object.singleton
128 (show (round pos) <> "%")
129 (NestedJss (foldMap ruleToObject rules))
130 x ->
131 unsafeCrashWith do
132 "tried to create CSS that I couldn't understand"
134instance jssAbleRecord ∷
135 ( JSSAbleFields props rowRL row () to
136 , RowToList row rowRL
137 , Homogeneous to (JSSElem props)
138 ) =>
139 JSSAble props (Record row) where
140 jss rec = NestedJss <<< Object.fromHomogeneous $ built
141 where
142 built ∷ Record to
143 built = Builder.build builder {}
145 rlp = RL.RLProxy ∷ RL.RLProxy rowRL
147 propsy = Proxy ∷ Proxy props
149 builder ∷ Builder.Builder (Record ()) (Record to)
150 builder = jssifyFields propsy rlp rec
152propsJss ∷ ∀ p a. JSSAble p a => (p -> a) -> JSSElem p
153propsJss fn = PropsJss (map jss fn)
155class JSSAbleFields props (xs ∷ RowList Type) (row ∷ #Type) (from ∷ #Type) (to ∷ #Type) | xs -> props row from to where
156 jssifyFields ∷ Proxy props -> RLProxy xs -> Record row -> Builder (Record from) (Record to)
158instance jssAbleFieldsNil ∷ JSSAbleFields props Nil row () () where
159 jssifyFields _ _ _ = identity
161instance jssAbleFieldsCons ∷
162 ( IsSymbol name
163 , JSSAble props a
164 , R.Lacks name from'
165 , R.Cons name a trash row
166 , R.Cons name (JSSElem props) from' to
167 , JSSAbleFields props tail row from from'
168 ) =>
169 JSSAbleFields props (RL.Cons name a tail) row from to where
170 jssifyFields _ _ r = first <<< rest
171 where
172 first = Builder.insert nameP (jss val)
174 val = Record.get nameP r
176 rest = jssifyFields propsP tailP r
178 nameP = SProxy ∷ SProxy name
180 tailP = RL.RLProxy ∷ RL.RLProxy tail
182 propsP = Proxy ∷ Proxy props
184 name = reflectSymbol nameP