git.iko.soy/rowtype-yoga/psfp
on fd4a42d help sign in
rowtype-yoga/psfp/blog/src/components/PSLayout.purs
318 lines 11 kB history raw
1module PSLayout where
3import Prelude
5import Data.Array (foldMap, intercalate)
6import Data.Array as Array
7import Data.Array.NonEmpty as NEA
8import Data.Either (Either(..))
9import Data.Function.Uncurried (mkFn2)
10import Data.Maybe (Maybe(..), fromMaybe, isJust)
11import Data.Monoid (guard)
12import Data.Nullable (Nullable)
13import Data.Nullable as Nullable
14import Data.String as String
15import Data.Traversable (mapAccumL)
16import Data.Tuple.Nested ((/\))
17import Debug.Trace (spy)
18import Effect (Effect)
19import Effect.Aff (launchAff_)
20import Effect.Class (liftEffect)
21import JSS (jssClasses)
22import Justifill (justifill)
23import Milkis.Impl (FetchImpl)
24import React.Basic (JSX, ReactComponent, fragment)
25import React.Basic.DOM (unsafeCreateDOMComponent)
26import React.Basic.DOM as R
27import React.Basic.Helpers (jsx)
28import React.Basic.Hooks (ReactChildren, component, componentWithChildren, element, memo, reactChildrenToArray, useReducer, useState)
29import React.Basic.Hooks as React
30import Shared.Models.Body (CompileResult)
31import Unsafe.Coerce (unsafeCoerce)
32import Yoga.Box.Component as Box
33import Yoga.ClickAway.Component as ClickAway
34import Yoga.CloseIcon.Component as CloseIcon
35import Yoga.CompileEditor.Component (mkCompileEditor)
36import Yoga.Compiler.Api (apiCompiler)
37import Yoga.Compiler.Types (Compiler)
38import Yoga.FillInTheGaps.Component as FillInTheGaps
39import Yoga.FillInTheGaps.Logic (findResult, parseSegments, toCode)
40import Yoga.Header.Component (mkHeader)
41import Yoga.Helpers ((?||))
42import Yoga.InlineCode.Component as InlineCode
43import Yoga.Modal.Component as Modal
44import Yoga.Theme (fromTheme)
45import Yoga.Theme.CSSBaseline (mkCssBaseline)
46import Yoga.Theme.Default (darkTheme)
47import Yoga.Theme.Provider (mkThemeProvider)
48import Yoga.Theme.Styles (makeStylesJSS)
49import Yoga.Theme.Types (CSSTheme)
50import Yoga.Typography.Header (HeadingLevel(..), mkH)
51import Yoga.Typography.Paragraph (mkP)
52import Yoga.WithSidebar.Component (makeComponent) as WithSidebar
54type SiteQueryResult
55 = { site ∷
56 { siteMetadata ∷
57 { title ∷ String
58 , menuLinks ∷ Array { name ∷ String, link ∷ String }
59 }
60 }
61 }
63type PreProps
64 = { children ∷
65 Nullable
66 { props ∷
67 Nullable
68 { mdxType ∷ Nullable String
69 , children ∷ Nullable String
70 , className ∷ Nullable String
71 }
72 }
73 }
75data ShowModal
76 = ShowModal Modal.Props
77 | HideModal
79mkLayout ∷
80 ∀ r.
81 FetchImpl ->
82 Effect
83 ( ReactComponent
84 { children ∷ ReactChildren JSX
85 , siteInfo ∷ SiteQueryResult
86 }
87 )
88mkLayout fetchImpl = do
89 themeProvider <- mkThemeProvider
90 modal <- memo Modal.makeComponent
91 clickAway <- memo ClickAway.makeComponent
92 mdxProviderComponent <- memo $ mkMdxProviderComponent (apiCompiler fetchImpl)
93 componentWithChildren "MDXLayout" \{ children, siteInfo } -> React.do
94 maybeModalProps /\ dispatch <-
95 useReducer Nothing case _, _ of
96 _, ShowModal props -> Just props
97 _, HideModal -> Nothing
98 pure
99 $ element themeProvider
100 { theme: fromTheme darkTheme
101 , children:
102 [ R.div_
103 [ maybeModalProps
104 # foldMap \modalProps ->
105 fragment
106 [ element clickAway { allowEscape: Just true, onClick: dispatch HideModal, style: Nothing }
107 , element modal (justifill modalProps)
108 ]
109 , element mdxProviderComponent
110 { children
111 , siteInfo
112 , showModal: dispatch <<< ShowModal
113 , hideModal: dispatch HideModal
114 }
115 ]
116 ]
117 }
119isQuiz ∷ JSX -> Boolean
120isQuiz a =
121 (unsafeCoerce a).props.mdxType == "pre"
122 && ((unsafeCoerce a).props.children.props.className == "language-purescript")
123 && ((unsafeCoerce a).props.children.props.mdxType == "code")
124 && ((unsafeCoerce a).props.children.props.children # parseSegments # isJust)
126mkMdxProviderComponent ∷
127 ∀ r.
128 { | Compiler r } ->
129 Effect
130 ( ReactComponent
131 { children ∷ ReactChildren JSX
132 , siteInfo ∷ SiteQueryResult
133 , showModal ∷ Modal.Props -> Effect Unit
134 , hideModal :: Effect Unit
135 }
136 )
137mkMdxProviderComponent compiler = do
138 cssBaseline <- memo mkCssBaseline
139 editor <- memo $ mkCompileEditor compiler
140 box <- memo $ Box.makeComponent
141 sidebar <- memo mkSidebar
142 header <- memo mkHeader
143 yogaInlineCode <- InlineCode.makeComponent
144 quiz <- memo $ mkQuiz compiler
145 h <- memo mkH
146 p <- memo mkP
147 closeIcon <- CloseIcon.makeComponent
148 useStyles <-
149 makeStylesJSS
150 $ jssClasses \(theme ∷ CSSTheme) ->
151 { code:
152 { fontFamily: theme.codeFontFamily # NEA.head
153 , backgroundColor: theme.interfaceColour
154 , fontSize: "10pt"
155 , border: "1px solid #383c39"
156 , padding: "3px"
157 , borderRadius: "3px"
158 }
159 }
160 componentWithChildren "MDXProviderComponent" \{ children, siteInfo, showModal, hideModal } -> React.do
161 classes <- useStyles {}
162 visibleUntil /\ updateVisible <- useState 1
163 let
164 onFailure title kids =
165 showModal
166 ( justifill
167 { title
168 , icon: element closeIcon { onClick: hideModal, style: Nothing }
169 , kids
170 } ∷ Modal.Props
171 )
173 onSuccess = updateVisible (_ + one)
175 mapVisible i kid =
176 { accum: i + if isQuiz kid then one else zero
177 , value: guard (i < visibleUntil) (pure kid)
178 }
180 visibleKids ∷ Array JSX
181 visibleKids =
182 reactChildrenToArray children
183 # mapAccumL mapVisible zero
184 # _.value
185 # Array.catMaybes
187 siteInfoJSX =
188 R.div
189 { children:
190 [ jsx header { className: "" } [ R.text siteInfo.site.siteMetadata.title ]
191 , element sidebar { links: siteInfo.site.siteMetadata.menuLinks }
192 , jsx box {} visibleKids
193 ]
194 }
195 mdxComponents /\ _ <-
196 useState
197 { h1:
198 \props ->
199 element h ({ level: H2, text: props.children, className: Nothing })
200 , h2:
201 \props ->
202 element h { level: H3, text: props.children, className: Nothing }
203 , h3:
204 \props ->
205 element h { level: H4, text: props.children, className: Nothing }
206 , hr: (const $ R.hr {})
207 , p:
208 \props ->
209 R.div
210 { children: [ element p { text: props.children } ]
211 }
212 , inlineCode:
213 \props -> do
214 R.span { className: classes.code, children: props.children }
215 , pre:
216 mkFn2 \(props ∷ PreProps) other -> do
217 let
219 childrenQ = Nullable.toMaybe props.children
221 propsQ = (_.props >>> Nullable.toMaybe) =<< childrenQ
223 mdxTypeQ = (_.mdxType >>> Nullable.toMaybe) =<< propsQ
225 childrenQ2 = (_.children >>> Nullable.toMaybe) =<< propsQ
227 classNameQ = (_.className >>> Nullable.toMaybe) =<< propsQ
229 isCode = fromMaybe false (mdxTypeQ <#> eq "code")
231 codeQ = childrenQ2
233 height =
234 (fromMaybe 200 >>> show >>> (_ <> "px")) do
235 code <- codeQ
236 pure
237 ( String.split (String.Pattern "\n") code
238 # Array.length
239 # \x -> (x * 12) + 100
240 )
242 language = fromMaybe "" (classNameQ >>= String.stripPrefix (String.Pattern "language-"))
244 segmentsQ = parseSegments (codeQ ?|| "")
245 case isCode, language, segmentsQ of
246 true, "purescript", Just initialSegments -> element quiz { initialSegments, onFailure, onSuccess }
247 true, _, _ ->
248 element editor
249 { initialCode: fromMaybe "" codeQ
250 , height
251 , language
252 }
253 false, _, _ -> element (unsafeCreateDOMComponent "pre") props
254 }
255 pure
256 $ element mdxProvider
257 { children: pure $ jsx cssBaseline {} [ siteInfoJSX ]
258 , components: mdxComponents
259 }
261mkQuiz ∷ _ -> Effect (ReactComponent _)
262mkQuiz compiler = do
263 fillInTheGaps <- FillInTheGaps.makeComponent
264 box <- Box.makeComponent
265 component "Quiz" \({ initialSegments, onFailure, onSuccess } ∷ { initialSegments ∷ _, onFailure ∷ _, onSuccess ∷ _ }) -> React.do
266 segments /\ updateSegments <- useState initialSegments
267 solvedWith /\ updateSolvedWith <- useState Nothing
268 pure
269 $ jsx box {}
270 [ element fillInTheGaps
271 { segments
272 , incantate:
273 launchAff_ do
274 let
275 code = toCode segments
276 result <- compiler.compileAndRun { code }
277 liftEffect case result of
278 Right r
279 | String.stripSuffix (String.Pattern "\n") r.stdout == (findResult $ join segments) -> do
280 updateSolvedWith (const $ String.stripSuffix (String.Pattern "\n") r.stdout)
281 onSuccess
282 Right r | r.stdout /= "\n" -> onFailure "Oh shit!" [R.text r.stdout]
283 Right r -> onFailure "Oh shit!" [R.text r.stderr]
284 Left (cr :: CompileResult) -> onFailure "Oh shit!" [R.text (intercalate ", " (cr.result <#> _.message))]
285 , updateSegments:
286 \update -> do
287 let
288 updated = update segments
289 case segments, updated of
290 old, new
291 | new == old -> mempty
292 _, _ -> updateSegments (const updated)
293 , solvedWith
294 }
295 ]
297mkSidebar = do
298 withSidebar <- WithSidebar.makeComponent
299 useStyles <-
300 makeStylesJSS
301 $ jssClasses \(theme ∷ CSSTheme) ->
302 {}
303 component "Sidebar" \{ links } -> React.do
304 classes <- useStyles {}
305 pure
306 $ element withSidebar
307 ( justifill
308 { sidebarChildren: [ R.div_ [] ]
309 , notSidebarChildren: [] ∷ Array JSX
310 }
311 )
313foreign import mdxProvider ∷
314 ∀ r.
315 ReactComponent
316 { components ∷ { | r } -- TODO Don't lie
317 , children ∷ Array JSX
318 }