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