git.iko.soy/rowtype-yoga/psfp
on 23914d4 help sign in
rowtype-yoga/psfp/components/src/Yoga/JSS.purs
167 lines 5.4 kB history raw
1module JSS where
3import Prelude
4import CSS (Color, Key(..), Rule(..), StyleM, Value(..), cssStringRGBA, plain, runS)
5import Data.Foldable (foldMap)
6import Data.Symbol (class IsSymbol, SProxy(..), reflectSymbol)
7import Debug.Trace (spy)
8import Foreign (unsafeToForeign)
9import Foreign.Object (Object)
10import Foreign.Object as Object
11import Partial.Unsafe (unsafeCrashWith)
12import Prim.RowList (class RowToList, Nil, kind RowList)
13import Record as Record
14import Record.Builder (Builder)
15import Record.Builder as Builder
16import Simple.JSON (class WriteForeign, write, writeImpl)
17import Type.Prelude (RLProxy, Proxy(..))
18import Type.Row as R
19import Type.Row.Homogeneous (class Homogeneous)
20import Type.RowList as RL
21import Untagged.Coercible (coerce)
22import Untagged.Union (type (|+|))
24newtype JSSClasses theme props r
25 = 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
39 built ∷ Record to
40 built = Builder.build builder {}
41 rlp = RL.RLProxy ∷ RL.RLProxy rowRL
42 propsy = Proxy ∷ Proxy props
43 builder ∷ Builder.Builder (Record ()) (Record to)
44 builder = jssifyFields propsy rlp rec
46data JSSElem props
47 = PrimitiveJss (String |+| Int |+| Number)
48 | ArrayJss (Array (JSSElem props))
49 | PropsJss (props -> JSSElem props)
50 | NestedJss (Object (JSSElem props))
52instance semigroupJssElem ∷ Semigroup (JSSElem props) where
53 append = case _, _ of
54 NestedJss n1, NestedJss n2 -> NestedJss (n1 <> n2)
55 ArrayJss a1, ArrayJss a2 -> ArrayJss (a1 <> a2)
56 NestedJss n1, PropsJss fn ->
57 PropsJss \props -> case fn props of
58 NestedJss n2 -> NestedJss (n1 <> n2)
59 other -> do
60 let
61 _ = spy "other" other
62 unsafeCrashWith "Untreated branch, fix me"
63 PropsJss fn1, PropsJss fn2 ->
64 PropsJss \props -> do
65 case fn1 props, fn2 props of
66 n1@(NestedJss _), n2@(NestedJss _) -> n1 <> n2
67 x, y -> do
68 let
69 _ = spy "x" x
71 _ = spy "y" y
72 unsafeCrashWith "Untreated branch second, fix me"
73 x, y -> do
74 let
75 _ = spy "x" x
77 _ = spy "y" y
78 unsafeCrashWith "Untreated branch second, fix me"
80instance wfJSSElem ∷ WriteForeign (JSSElem props) where
81 writeImpl = case _ of
82 PrimitiveJss p -> unsafeToForeign p
83 ArrayJss proper -> write (map writeImpl proper)
84 PropsJss proper -> unsafeToForeign (map writeImpl proper)
85 NestedJss proper -> writeImpl (map writeImpl proper)
87class JSSAble p a | a -> p where
88 jss ∷ a -> JSSElem p
90instance jssAbleJssElem ∷ JSSAble p (JSSElem p) where
91 jss = identity
93instance jssAbleColor ∷ JSSAble p Color where
94 jss c = PrimitiveJss (coerce (cssStringRGBA c))
96instance jssAbleString ∷ JSSAble p String where
97 jss = coerce >>> PrimitiveJss
99instance jssAbleInt ∷ JSSAble p Int where
100 jss = coerce >>> PrimitiveJss
102instance jssAbleNumber ∷ JSSAble p Number where
103 jss = coerce >>> PrimitiveJss
105instance jssAbleArray ∷ JSSAble p a => JSSAble p (Array a) where
106 jss arr = ArrayJss (jss <$> arr)
108instance jssAbleWithProps ∷ JSSAble p jss => JSSAble p (p -> jss) where
109 jss = propsJss
111instance jssAbleNested ∷ JSSAble p jss => JSSAble p (Object jss) where
112 jss = map jss >>> NestedJss
114instance jssAbleCss ∷ JSSAble p (StyleM Unit) where
115 jss someCss = NestedJss (foldMap ruleToObject rules)
116 where
117 rules = runS someCss
118 ruleToObject = case _ of
119 Property (Key k) (Value v) -> Object.singleton (plain k) (jss (plain v))
120 x ->
121 unsafeCrashWith do
122 let
123 _ = spy "Unsupported CSS" x
124 "tried to create CSS that I couldn't understand"
126instance jssAbleRecord ∷
127 ( JSSAbleFields props rowRL row () to
128 , RowToList row rowRL
129 , Homogeneous to (JSSElem props)
130 ) =>
131 JSSAble props (Record row) where
132 jss rec = NestedJss <<< Object.fromHomogeneous $ built
133 where
134 built ∷ Record to
135 built = Builder.build builder {}
136 rlp = RL.RLProxy ∷ RL.RLProxy rowRL
137 propsy = Proxy ∷ Proxy props
138 builder ∷ Builder.Builder (Record ()) (Record to)
139 builder = jssifyFields propsy rlp rec
141propsJss ∷ ∀ p a. JSSAble p a => (p -> a) -> JSSElem p
142propsJss fn = PropsJss (map jss fn)
144class JSSAbleFields props (xs ∷ RowList) (row ∷ #Type) (from ∷ #Type) (to ∷ #Type) | xs -> props row from to where
145 jssifyFields ∷ Proxy props -> RLProxy xs -> Record row -> Builder (Record from) (Record to)
147instance jssAbleFieldsNil ∷ JSSAbleFields props Nil row () () where
148 jssifyFields _ _ _ = identity
150instance jssAbleFieldsCons ∷
151 ( IsSymbol name
152 , JSSAble props a
153 , R.Lacks name from'
154 , R.Cons name a trash row
155 , R.Cons name (JSSElem props) from' to
156 , JSSAbleFields props tail row from from'
157 ) =>
158 JSSAbleFields props (RL.Cons name a tail) row from to where
159 jssifyFields _ _ r = first <<< rest
160 where
161 first = Builder.insert nameP (jss val)
162 val = Record.get nameP r
163 rest = jssifyFields propsP tailP r
164 nameP = SProxy ∷ SProxy name
165 tailP = RL.RLProxy ∷ RL.RLProxy tail
166 propsP = Proxy ∷ Proxy props
167 name = reflectSymbol nameP