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