@@ -0,0 +1,634 @@
1+{-# LANGUAGE ApplicativeDo #-}
2+{-# LANGUAGE ConstraintKinds #-}
3+{-# LANGUAGE EmptyCase #-}
4+{-# LANGUAGE EmptyDataDecls #-}
5+{-# LANGUAGE FlexibleContexts #-}
6+{-# LANGUAGE FlexibleInstances #-}
7+{-# LANGUAGE GADTs #-}
8+{-# LANGUAGE KindSignatures #-}
9+{-# LANGUAGE LambdaCase #-}
10+{-# LANGUAGE MultiParamTypeClasses #-}
11+{-# LANGUAGE OverloadedStrings #-}
12+{-# LANGUAGE PatternSynonyms #-}
13+{-# LANGUAGE RankNTypes #-}
14+{-# LANGUAGE ScopedTypeVariables #-}
15+{-# LANGUAGE TemplateHaskell #-}
16+{-# LANGUAGE TypeFamilies #-}
17+{-# LANGUAGE TypeOperators #-}
18+{-# LANGUAGE ViewPatterns #-}
19+module Obelisk.Route
20+ ( R
21+ , pattern (:/)
22+ , PageName
23+ , Encoder (..) --TODO: unsafe
24+ , checkEncoder
25+ , ValidEncoder (..) --TODO: unsafe
26+ , ValidEncoderFunc (..)
27+ , mapSome
28+ , pathComponentEncoder
29+ , enumEncoder
30+ , enum1Encoder
31+ , endValidEncoder
32+ , pathOnlyValidEncoder
33+ , singletonListValidEncoder
34+ , unpackTextEncoder
35+ , prefixTextEncoder
36+ , intercalateTextEncoder
37+ , listToNonEmptyEncoder
38+ , prefixNonemptyTextEncoder
39+ , joinPairTextEncoder
40+ , toListMapEncoder
41+ , shadowEncoder
42+ , prismValidEncoder
43+ , rPrism
44+ , obeliskRouteEncoder
45+ , obeliskRouteComponentEncoder
46+ , checkObeliskRouteRestEncoder
47+ , pageNameValidEncoder
48+ , catchValidEncoder
49+ , ObeliskRoute (..)
50+ , _ObeliskRoute_App
51+ , _ObeliskRoute_Resource
52+ , ResourceRoute (..)
53+ , JSaddleWarpRoute (..)
54+ , jsaddleWarpRouteEncoder
55+ , IndexOnlyRoute (..)
56+ , indexOnlyRouteComponentEncoder
57+ , indexOnlyRouteRestEncoder
58+ , someSumEncoder
59+ , Void1
60+ , void1Encoder
61+ ) where
62+
63+import Prelude hiding ((.), id)
64+
65+import Control.Applicative
66+import Control.Category (Category (..))
67+import qualified Control.Categorical.Functor as Cat
68+import Control.Categorical.Bifunctor
69+import Control.Lens (Identity (..), Prism', makePrisms, itraverse, imap, prism, (^.), re, matching, (^?))
70+import Control.Monad.Except
71+import Data.Dependent.Sum (DSum (..), ShowTag (..))
72+import Data.Dependent.Map (DMap)
73+import qualified Data.Dependent.Map as DMap
74+import Data.Either.Validation (Validation (..))
75+import Data.Foldable
76+import Data.Functor.Sum
77+import Data.GADT.Compare
78+import Data.GADT.Compare.TH
79+import Data.GADT.Show
80+import Data.GADT.Show.TH
81+import Data.List.NonEmpty (NonEmpty (..))
82+import Data.Map (Map)
83+import qualified Data.Map as Map
84+import Data.Maybe
85+import Data.Set (Set)
86+import qualified Data.Set as Set
87+import Data.Some (Some)
88+import qualified Data.Some as Some
89+import Data.Text (Text)
90+import qualified Data.Text as T
91+import Data.Universe
92+
93+-- Design goals:
94+-- No start-up time on the frontend (not yet met)
95+-- Able to ensure that there aren't overlapping routes prior to deployment
96+-- Easy to write common types of parsers
97+-- Completeness checking
98+
99+-- Laws:
100+-- We statically know that all valid Routes can be turned into valid URIs
101+-- - This means we need to know whether there are any overlaps, e.g. with the static file namespace
102+
103+--TODO:
104+-- Backend:
105+-- Redirect the user to a canonical route
106+-- Pre-render
107+-- Frontend:
108+-- Intercept links that can be kept within the app
109+-- Fragments
110+
111+--------------------------------------------------------------------------------
112+-- Subroutes/paths
113+--------------------------------------------------------------------------------
114+
115+type R f = DSum f Identity --TODO: Better name
116+
117+--TODO: COMPLETE pragma
118+infixr 5 :/
119+pattern (:/) :: f a -> a -> R f
120+pattern a :/ b = a :=> Identity b
121+
122+mapSome :: (forall a. f a -> g a) -> Some f -> Some g
123+mapSome f (Some.This a) = Some.This $ f a
124+
125+--------------------------------------------------------------------------------
126+-- Encoder fundamentals
127+--------------------------------------------------------------------------------
128+
129+newtype Encoder check parse decoded encoded = Encoder { unEncoder :: check (ValidEncoder parse decoded encoded) }
130+
131+-- | Law:
132+-- forall p. _validEncoder_decode ve . _validEncoder_encode ve p == pure
133+-- Note that the reverse may not be the case: when parsing, a route may be canonicalized, and erroneous routes may be collapsed to a single 404 route. However, as a consequence of the law, encode . decode must be idemponent.
134+data ValidEncoder parse decoded encoded = ValidEncoder
135+ { _validEncoder_decode :: !(encoded -> parse decoded) -- Can fail; can lose information; must always succeed on outputs of `_validEncoder_encode` and result in the original value
136+ , _validEncoder_encode :: !(decoded -> encoded) -- Must be injective
137+ }
138+
139+checkEncoder :: Encoder check parse decoded encoded -> check (ValidEncoder parse decoded encoded)
140+checkEncoder = unEncoder
141+
142+instance (Applicative check, Monad parse) => Category (Encoder check parse) where
143+ id = Encoder $ pure id
144+ Encoder f . Encoder g = Encoder $ liftA2 (.) f g
145+
146+instance Monad parse => Category (ValidEncoder parse) where
147+ id = ValidEncoder
148+ { _validEncoder_decode = pure
149+ , _validEncoder_encode = id
150+ }
151+ f . g = ValidEncoder
152+ { _validEncoder_decode = _validEncoder_decode g <=< _validEncoder_decode f
153+ , _validEncoder_encode = _validEncoder_encode f . _validEncoder_encode g
154+ }
155+
156+instance Monad parse => PFunctor (,) (ValidEncoder parse) (ValidEncoder parse) where
157+ first f = bimap f id
158+instance Monad parse => QFunctor (,) (ValidEncoder parse) (ValidEncoder parse) where
159+ second g = bimap id g
160+instance Monad parse => Bifunctor (,) (ValidEncoder parse) (ValidEncoder parse) (ValidEncoder parse) where
161+ bimap f g = ValidEncoder
162+ { _validEncoder_encode = bimap (_validEncoder_encode f) (_validEncoder_encode g)
163+ , _validEncoder_decode = \(a, b) -> liftA2 (,) (_validEncoder_decode f a) (_validEncoder_decode g b)
164+ }
165+
166+instance (Applicative check, Monad parse) => PFunctor (,) (Encoder check parse) (Encoder check parse) where
167+ first f = bimap f id
168+instance (Applicative check, Monad parse) => QFunctor (,) (Encoder check parse) (Encoder check parse) where
169+ second g = bimap id g
170+instance (Applicative check, Monad parse) => Bifunctor (,) (Encoder check parse) (Encoder check parse) (Encoder check parse) where
171+ bimap f g = Encoder $ liftA2 bimap (checkEncoder f) (checkEncoder g)
172+
173+instance (Traversable f, Monad check, Monad parse) => Cat.Functor f (Encoder check parse) (Encoder check parse) where
174+ fmap e = Encoder $ do
175+ ve <- checkEncoder e
176+ pure $ ValidEncoder
177+ { _validEncoder_encode = fmap $ _validEncoder_encode ve
178+ , _validEncoder_decode = traverse $ _validEncoder_decode ve
179+ }
180+
181+--------------------------------------------------------------------------------
182+-- Specific instances of encoders
183+--------------------------------------------------------------------------------
184+
185+-- | A path and query string, in which trailing slashes don't matter in the path
186+-- and duplicate query parameters are not allowed
187+type PageName = ([Text], Map Text Text)
188+
189+newtype Flip f a b = Flip { unFlip :: f b a }
190+
191+pathComponentEncoder :: forall check parse p. (Monad check, Monad parse) => (Encoder check parse (Some p) (Maybe Text)) -> (forall a. p a -> ValidEncoder parse a PageName) -> Encoder check parse (R p) PageName
192+pathComponentEncoder this rest = chainEncoder (lensEncoder (\(_, b) a -> (a, b)) Prelude.fst consValidEncoder) this rest
193+
194+--NOTE: Naming convention in this module is to always talk about things in the *encoding* direction, never in the *decoding* direction
195+
196+chainEncoder
197+ :: forall check parse p r b.
198+ ( Monad check
199+ , Monad parse
200+ )
201+ => ValidEncoder parse (b, r) r
202+ -> Encoder check parse (Some p) b
203+ -> (forall a. p a -> ValidEncoder parse a r)
204+ -> Encoder check parse (R p) r
205+chainEncoder cons this rest = Encoder $ do
206+ thisValid <- checkEncoder this
207+ pure $ ValidEncoder
208+ { _validEncoder_decode = \v -> do
209+ (here, following) <- _validEncoder_decode cons v
210+ Some.This r <- _validEncoder_decode thisValid here
211+ (r :/) <$> _validEncoder_decode (rest r) following
212+ , _validEncoder_encode = \(r :/ s) ->
213+ _validEncoder_encode cons (_validEncoder_encode thisValid $ Some.This r, _validEncoder_encode (rest r) s)
214+ }
215+
216+--TODO: Do this in terms of a lens instead
217+lensEncoder :: Monad parse => (b -> [a] -> b) -> (b -> [a]) -> ValidEncoder parse (c, [a]) [a] -> ValidEncoder parse (c, b) b
218+lensEncoder set get g = ValidEncoder
219+ { _validEncoder_encode = \(ma, b) -> set b $ _validEncoder_encode g (ma, get b)
220+ , _validEncoder_decode = \b -> do
221+ (ma, la) <- _validEncoder_decode g $ get b
222+ pure (ma, set b la)
223+ }
224+
225+consValidEncoder :: Applicative parse => ValidEncoder parse (Maybe a, [a]) [a] --TODO: Really shouldn't *always* have the [a], even in the Nothing case
226+consValidEncoder = ValidEncoder
227+ { _validEncoder_encode = \(h, t) -> maybeToList h <> t
228+ , _validEncoder_decode = pure . \case
229+ [] -> (Nothing, [])
230+ h:t -> (Just h, t)
231+ }
232+
233+tshow :: Show a => a -> Text
234+tshow = T.pack . show
235+
236+shadowEncoder
237+ :: ( Universe a
238+ , MonadError Text check
239+ , Show a
240+ , Show b
241+ , Show c
242+ , check ~ parse --TODO: Get rid of this
243+ )
244+ => Encoder check parse a c -- ^ Overlaps; should have a small number of possible routes
245+ -> Encoder check parse b c -- ^ Gets overlapped
246+ -> Encoder check parse (Either a b) c
247+shadowEncoder f g = Encoder $ do
248+ vf <- checkEncoder f
249+ vg <- checkEncoder g
250+ let gCanParse c = catchError (Just <$> _validEncoder_decode vg c) (\_ -> pure Nothing)
251+ overlaps <- fmap catMaybes $ forM universe $ \a -> do
252+ let c = _validEncoder_encode vf a
253+ mb <- gCanParse c
254+ pure $ fmap (\b -> (a, b, c)) mb
255+ case overlaps of
256+ [] -> pure ()
257+ _ -> throwError $ "shadowEncoder: overlap detected: " <> T.unlines
258+ (flip fmap overlaps $ \(a, b, c) -> "first encoder encodes " <> tshow a <> " as " <> tshow c <> ", which second encoder decodes as " <> tshow b)
259+ pure $ ValidEncoder
260+ { _validEncoder_encode = \case
261+ Left a -> _validEncoder_encode vf a
262+ Right b -> _validEncoder_encode vg b
263+ , _validEncoder_decode = \c -> (Left <$> _validEncoder_decode vf c) `catchError` \_ -> Right <$> _validEncoder_decode vg c
264+ }
265+
266+enum1Encoder
267+ :: ( Universe (Some p)
268+ , GShow p
269+ , GCompare p
270+ , Ord r
271+ , MonadError Text check
272+ , MonadError Text parse
273+ , Show r
274+ )
275+ => (forall a. p a -> r) -> Encoder check parse (Some p) r
276+enum1Encoder f = enumEncoder $ \(Some.This p) -> f p
277+
278+-- | Encode an enumerable, bounded type. WARNING: Don't use this on types that
279+-- have a large number of values - it will use a lot of memory.
280+enumEncoder :: forall parse check p r. (Universe p, Show p, Ord p, Ord r, MonadError Text parse, MonadError Text check, Show r) => (p -> r) -> Encoder check parse p r
281+enumEncoder f = Encoder $ do
282+ let reversed = Map.fromListWith (<>) [ (f p, Set.singleton p) | p <- universe ]
283+ checkSingleton k vs = case Set.toList vs of
284+ [] -> error "enumEncoder: empty reverse mapping; should be impossible"
285+ [e] -> Success e
286+ _ -> Failure $ Map.singleton k vs
287+ showRedundant :: r -> Set p -> [Text]
288+ showRedundant k vs = (" " <> tshow k <> " can decode to any of:")
289+ : fmap ((" "<>) . tshow) (Set.toList vs)
290+ case itraverse checkSingleton reversed :: Validation (Map r (Set p)) (Map r p) of
291+ Failure ambiguousEntries -> throwError $ T.unlines $
292+ "enumEncoder: ambiguous encodings detected:" : concat (Map.elems $ imap showRedundant ambiguousEntries)
293+ Success m -> pure $ ValidEncoder
294+ { _validEncoder_decode = \r -> case Map.lookup r m of
295+ Just a -> pure a
296+ Nothing -> throwError $ "enumEncoder: not recognized: " <> tshow r --TODO: Report this as a better type
297+ , _validEncoder_encode = f
298+ }
299+
300+endValidEncoder :: (MonadError Text parse, Show r, Eq r) => r -> ValidEncoder parse () r
301+endValidEncoder expected = ValidEncoder
302+ { _validEncoder_decode = \obtained ->
303+ if obtained == expected
304+ then pure ()
305+ else throwError $ "endValidEncoder: expected " <> tshow expected <> ", got " <> tshow obtained
306+ , _validEncoder_encode = \_ -> expected
307+ }
308+
309+pathOnlyValidEncoder :: (MonadError Text parse) => ValidEncoder parse [Text] PageName
310+pathOnlyValidEncoder = ValidEncoder
311+ { _validEncoder_decode = \(path, query) ->
312+ if query == mempty
313+ then pure path
314+ else throwError "pathOnlyValidEncoder: query was provided"
315+ , _validEncoder_encode = \path -> (path, mempty)
316+ }
317+
318+singletonListValidEncoder :: (MonadError Text parse) => ValidEncoder parse a [a]
319+singletonListValidEncoder = ValidEncoder
320+ { _validEncoder_decode = \case
321+ [a] -> pure a
322+ l -> throwError $ "singletonListValidEncoder: expected one item, got " <> tshow (length l)
323+ , _validEncoder_encode = (:[])
324+ }
325+
326+--TODO: To know this is reversible, we must know that the separator isn't included anywhere in the input text
327+intercalateTextEncoder :: (MonadError Text check, Applicative parse) => Text -> Encoder check parse (NonEmpty Text) Text
328+intercalateTextEncoder = Encoder . \case
329+ "" -> throwError "splitOnTextEncoder: empty split string"
330+ separator -> pure $ ValidEncoder
331+ { _validEncoder_encode = T.intercalate separator . toList
332+ , _validEncoder_decode = \r -> pure $ case T.splitOn separator r of
333+ [] -> error "intercalateTextEncoder: Data.Text.splitOn should never return an empty list"
334+ h : t -> h :| t
335+ }
336+
337+listToNonEmptyEncoder :: (Applicative check, Applicative parse, Monoid a, Eq a) => Encoder check parse [a] (NonEmpty a)
338+listToNonEmptyEncoder = Encoder $ pure $ ValidEncoder
339+ { _validEncoder_encode = \case
340+ [] -> mempty :| []
341+ h : t -> h :| t
342+ , _validEncoder_decode = \(h :| t) -> pure $
343+ if h == mempty
344+ then []
345+ else h : t
346+ }
347+
348+prefixTextEncoder :: (Applicative check, MonadError Text parse) => Text -> Encoder check parse Text Text
349+prefixTextEncoder p = Encoder $ pure $ ValidEncoder
350+ { _validEncoder_encode = mappend p
351+ , _validEncoder_decode = \v -> case T.stripPrefix p v of
352+ Nothing -> throwError $ "prefixTextEncoder: wrong prefix; expected " <> tshow p <> ", got " <> tshow (T.take (T.length p) v)
353+ Just stripped -> pure stripped
354+ }
355+
356+prefixNonemptyTextEncoder :: (Applicative check, MonadError Text parse) => Text -> Encoder check parse Text Text
357+prefixNonemptyTextEncoder p = Encoder $ pure $ ValidEncoder
358+ { _validEncoder_encode = \case
359+ "" -> ""
360+ v -> p <> v
361+ , _validEncoder_decode = \case
362+ "" -> pure ""
363+ v -> case T.stripPrefix p v of
364+ Nothing -> throwError $ "prefixTextEncoder: wrong prefix; expected " <> tshow p
365+ Just stripped -> pure stripped
366+ }
367+
368+unpackTextEncoder :: (Applicative check, Applicative parse) => Encoder check parse Text String
369+unpackTextEncoder = Encoder $ pure $ ValidEncoder
370+ { _validEncoder_encode = T.unpack
371+ , _validEncoder_decode = pure . T.pack
372+ }
373+
374+toListMapEncoder :: (Applicative check, Applicative parse, Ord k) => Encoder check parse (Map k v) [(k, v)]
375+toListMapEncoder = Encoder $ pure $ ValidEncoder
376+ { _validEncoder_encode = Map.toList
377+ , _validEncoder_decode = pure . Map.fromList --TODO: Should we be stricter about repeated keys?
378+ }
379+
380+joinPairTextEncoder :: (MonadError Text check, MonadError Text parse) => Text -> Encoder check parse (Text, Text) Text
381+joinPairTextEncoder = Encoder . \case
382+ "" -> throwError "joinPairTextEncoder: empty separator"
383+ separator -> pure $ ValidEncoder
384+ { _validEncoder_encode = \(k, v) -> k <> separator <> v
385+ , _validEncoder_decode = \r ->
386+ let (kt, vt) = T.breakOn separator r
387+ in case vt of
388+ -- The separator was not found
389+ "" -> throwError $ "joinPairTextEncoder: separator not found; expected " <> tshow separator
390+ _ -> return (kt, T.drop (T.length separator) vt)
391+ }
392+
393+--TODO: Rewrite this by composing the given prism with a lens on the first element of the DSum
394+-- Or, more likely, the user can compose it themselves
395+rPrism :: forall f g. (forall a. Prism' (f a) (g a)) -> Prism' (R f) (R g)
396+rPrism p = prism (\(g :/ x) -> g ^. re p :/ x) (\(f :/ x) -> bimap (:/ x) (:/ x) $ matching p f)
397+
398+-- An encoder that only works on the items available via the prism
399+prismValidEncoder :: MonadError Text parse => Prism' b a -> ValidEncoder parse a b
400+prismValidEncoder p = ValidEncoder
401+ { _validEncoder_encode = (^. re p)
402+ , _validEncoder_decode = \r -> case r ^? p of
403+ Just a -> pure a
404+ Nothing -> throwError "prismValidEncoder: value is not present in the prism"
405+ }
406+
407+
408+-- | Encode a PageName into a path and query string, suitable for use in the
409+-- 'URI' type
410+pageNameValidEncoder :: MonadError Text parse => ValidEncoder parse PageName (String, String)
411+pageNameValidEncoder = ve
412+ where Right ve = checkEncoder $ bimap
413+ (unpackTextEncoder . prefixTextEncoder "/" . intercalateTextEncoder "/" . listToNonEmptyEncoder)
414+ (unpackTextEncoder . prefixNonemptyTextEncoder "?" . intercalateTextEncoder "&" . listToNonEmptyEncoder . Cat.fmap (joinPairTextEncoder "=") . toListMapEncoder)
415+
416+catchValidEncoder :: (e -> a) -> ValidEncoder (Either e) a b -> ValidEncoder Identity a b
417+catchValidEncoder recover ve = ve
418+ { _validEncoder_decode = \a -> pure $ case _validEncoder_decode ve a of
419+ Right r -> r
420+ Left err -> recover err
421+ }
422+
423+--------------------------------------------------------------------------------
424+-- Actual obelisk route info
425+--------------------------------------------------------------------------------
426+
427+data ObeliskRoute :: (* -> *) -> * -> * where
428+ -- We need to have the `f a` as an argument here, because otherwise we have no way to specifically check for overlap between us and the given encoder
429+ ObeliskRoute_App :: f a -> ObeliskRoute f a
430+ ObeliskRoute_Resource :: ResourceRoute a -> ObeliskRoute f a
431+
432+data ResourceRoute :: * -> * where
433+ ResourceRoute_Static :: ResourceRoute [Text] -- This [Text] represents the *path in our static files directory*, not necessarily the URL path that the asset gets served at (although that will often be "/static/this/text/thing")
434+ ResourceRoute_Ghcjs :: ResourceRoute [Text]
435+ ResourceRoute_JSaddleWarp :: ResourceRoute (R JSaddleWarpRoute)
436+
437+--TODO: Generate this
438+instance Universe (Some ResourceRoute) where
439+ universe =
440+ [ Some.This ResourceRoute_Static
441+ , Some.This ResourceRoute_Ghcjs
442+ , Some.This ResourceRoute_JSaddleWarp
443+ ]
444+
445+--TODO: Figure out a way to check this
446+obeliskComponentEncoder :: (Applicative check, Applicative parse) => Encoder check parse (Some (ObeliskRoute f)) (Either (Some ResourceRoute) (Some f))
447+obeliskComponentEncoder = Encoder $ pure $ ValidEncoder
448+ { _validEncoder_encode = \(Some.This o) -> case o of
449+ ObeliskRoute_App r -> Right $ Some.This r
450+ ObeliskRoute_Resource r -> Left $ Some.This r
451+ , _validEncoder_decode = pure . \case
452+ Right (Some.This r) -> Some.This $ ObeliskRoute_App r
453+ Left (Some.This r) -> Some.This $ ObeliskRoute_Resource r
454+ }
455+
456+newtype ValidEncoderFunc parse p r = ValidEncoderFunc { runValidEncoderFunc :: forall a. p a -> ValidEncoder parse a r }
457+
458+checkSomeUniverseEncoder
459+ :: forall check parse p r.
460+ ( Universe (Some p)
461+ , GCompare p
462+ , Monad check
463+ )
464+ => (forall a. p a -> Encoder check parse a r)
465+ -> check (ValidEncoderFunc parse p r)
466+checkSomeUniverseEncoder f = do
467+ validEncoders :: DMap p (Flip (ValidEncoder parse) r) <- DMap.fromList <$> traverse (\(Some.This p) -> (p :=>) . Flip <$> checkEncoder (f p)) universe
468+ pure $ ValidEncoderFunc $ \p -> unFlip $ DMap.findWithDefault (error "checkSomeUniverseEncoder: ValidEncoder not found (should be impossible)") p validEncoders
469+
470+obeliskRouteEncoder
471+ :: forall check parse appRoute.
472+ ( Universe (Some appRoute)
473+ , GCompare appRoute
474+ , GShow appRoute
475+ , MonadError Text check
476+ , check ~ parse --TODO: Get rid of this
477+ )
478+ => (Encoder check parse (Some appRoute) (Maybe Text))
479+ -> (forall a. appRoute a -> Encoder check parse a PageName)
480+ -> Encoder check parse (R (ObeliskRoute appRoute)) PageName
481+obeliskRouteEncoder appComponentEncoder appRouteEncoder = Encoder $ do
482+ let componentEncoder = obeliskRouteComponentEncoder appComponentEncoder
483+ restEncoder <- checkObeliskRouteRestEncoder appRouteEncoder
484+ checkEncoder $ pathComponentEncoder componentEncoder $ runValidEncoderFunc restEncoder
485+
486+checkObeliskRouteRestEncoder
487+ :: ( MonadError Text check
488+ , MonadError Text parse
489+ , Universe (Some appRoute)
490+ , GCompare appRoute
491+ )
492+ => (forall a. appRoute a -> Encoder check parse a PageName)
493+ -> check (ValidEncoderFunc parse (ObeliskRoute appRoute) PageName)
494+checkObeliskRouteRestEncoder appRouteEncoder = do
495+ appRouteValidEncoder <- checkSomeUniverseEncoder appRouteEncoder
496+ resourceRouteValidEncoder <- checkSomeUniverseEncoder resourceRouteEncoder
497+ return $ ValidEncoderFunc $ \case
498+ ObeliskRoute_App appRoute -> runValidEncoderFunc appRouteValidEncoder appRoute
499+ ObeliskRoute_Resource resRoute -> runValidEncoderFunc resourceRouteValidEncoder resRoute
500+
501+obeliskRouteComponentEncoder
502+ :: ( MonadError Text parse
503+ , GShow appRoute
504+ , check ~ parse
505+ )
506+ => Encoder check parse (Some appRoute) (Maybe Text) -> Encoder check parse (Some (ObeliskRoute appRoute)) (Maybe Text)
507+obeliskRouteComponentEncoder appComponentEncoder = (resourceComponentEncoder `shadowEncoder` appComponentEncoder) . obeliskComponentEncoder
508+
509+resourceComponentEncoder :: (MonadError Text check, MonadError Text parse) => Encoder check parse (Some ResourceRoute) (Maybe Text)
510+resourceComponentEncoder = enum1Encoder $ \case
511+ ResourceRoute_Static -> Just "static"
512+ ResourceRoute_Ghcjs -> Just "ghcjs"
513+ ResourceRoute_JSaddleWarp -> Just "jsaddle"
514+
515+resourceRouteEncoder :: (MonadError Text check, MonadError Text parse) => ResourceRoute a -> Encoder check parse a PageName
516+resourceRouteEncoder = \case
517+ ResourceRoute_Static -> Encoder $ pure pathOnlyValidEncoder
518+ ResourceRoute_Ghcjs -> Encoder $ pure pathOnlyValidEncoder
519+ ResourceRoute_JSaddleWarp -> jsaddleWarpRouteEncoder
520+
521+data JSaddleWarpRoute :: * -> * where
522+ JSaddleWarpRoute_JavaScript :: JSaddleWarpRoute ()
523+ JSaddleWarpRoute_WebSocket :: JSaddleWarpRoute ()
524+ JSaddleWarpRoute_Sync :: JSaddleWarpRoute [Text]
525+
526+instance Universe (Some JSaddleWarpRoute) where
527+ universe =
528+ [ Some.This JSaddleWarpRoute_JavaScript
529+ , Some.This JSaddleWarpRoute_WebSocket
530+ , Some.This JSaddleWarpRoute_Sync
531+ ]
532+
533+jsaddleWarpRouteComponentEncoder :: (MonadError Text check, MonadError Text parse) => Encoder check parse (Some JSaddleWarpRoute) (Maybe Text)
534+jsaddleWarpRouteComponentEncoder = enum1Encoder $ \case
535+ JSaddleWarpRoute_JavaScript -> Just "jsaddle.js"
536+ JSaddleWarpRoute_WebSocket -> Nothing
537+ JSaddleWarpRoute_Sync -> Just "sync"
538+
539+jsaddleWarpRouteEncoder :: (MonadError Text check, MonadError Text parse) => Encoder check parse (R JSaddleWarpRoute) PageName
540+jsaddleWarpRouteEncoder = pathComponentEncoder jsaddleWarpRouteComponentEncoder $ \case
541+ JSaddleWarpRoute_JavaScript -> endValidEncoder mempty
542+ JSaddleWarpRoute_WebSocket -> endValidEncoder mempty
543+ JSaddleWarpRoute_Sync -> pathOnlyValidEncoder
544+
545+instance ShowTag appRoute Identity => ShowTag (ObeliskRoute appRoute) Identity where
546+ showTaggedPrec = \case
547+ ObeliskRoute_App a -> showTaggedPrec a
548+ ObeliskRoute_Resource r -> showTaggedPrec r
549+
550+instance ShowTag ResourceRoute Identity where
551+ showTaggedPrec = \case
552+ ResourceRoute_Static -> showsPrec
553+ ResourceRoute_Ghcjs -> showsPrec
554+ ResourceRoute_JSaddleWarp -> showsPrec
555+
556+instance ShowTag JSaddleWarpRoute Identity where
557+ showTaggedPrec = \case
558+ JSaddleWarpRoute_JavaScript -> showsPrec
559+ JSaddleWarpRoute_WebSocket -> showsPrec
560+ JSaddleWarpRoute_Sync -> showsPrec
561+
562+instance Universe (Some appRoute) => Universe (Some (ObeliskRoute appRoute)) where
563+ universe = mconcat
564+ [ mapSome ObeliskRoute_App <$> universe
565+ , mapSome ObeliskRoute_Resource <$> universe
566+ ]
567+
568+instance GShow appRoute => GShow (ObeliskRoute appRoute) where
569+ gshowsPrec prec = \case
570+ ObeliskRoute_App appRoute -> showParen (prec > 10) $
571+ showString "ObeliskRoute_App " . gshowsPrec 11 appRoute
572+ ObeliskRoute_Resource appRoute -> showParen (prec > 10) $
573+ showString "ObeliskRoute_Resource " . gshowsPrec 11 appRoute
574+
575+
576+data IndexOnlyRoute :: * -> * where
577+ IndexOnlyRoute :: IndexOnlyRoute ()
578+
579+instance Universe (Some IndexOnlyRoute) where
580+ universe = [Some.This IndexOnlyRoute]
581+
582+indexOnlyRouteComponentEncoder :: (MonadError Text check, MonadError Text parse) => Encoder check parse (Some IndexOnlyRoute) (Maybe Text)
583+indexOnlyRouteComponentEncoder = enum1Encoder $ \case
584+ IndexOnlyRoute -> Nothing
585+
586+indexOnlyRouteRestEncoder :: (Applicative check, MonadError Text parse) => IndexOnlyRoute a -> Encoder check parse a PageName
587+indexOnlyRouteRestEncoder = \case
588+ IndexOnlyRoute -> Encoder $ pure $ endValidEncoder mempty --TODO: Allow anything to parse
589+
590+instance ShowTag IndexOnlyRoute Identity where
591+ showTaggedPrec = \case
592+ IndexOnlyRoute -> showsPrec
593+
594+someSumEncoder :: (Applicative check, Applicative parse) => Encoder check parse (Some (Sum a b)) (Either (Some a) (Some b))
595+someSumEncoder = Encoder $ pure $ ValidEncoder
596+ { _validEncoder_encode = \(Some.This t) -> case t of
597+ InL l -> Left $ Some.This l
598+ InR r -> Right $ Some.This r
599+ , _validEncoder_decode = pure . \case
600+ Left (Some.This l) -> Some.This (InL l)
601+ Right (Some.This r) -> Some.This (InR r)
602+ }
603+
604+data Void1 :: * -> * where {}
605+
606+instance Universe (Some Void1) where
607+ universe = []
608+
609+void1Encoder :: (Applicative check, MonadError Text parse) => Encoder check parse (Some Void1) a
610+void1Encoder = Encoder $ pure $ ValidEncoder
611+ { _validEncoder_encode = \case
612+ Some.This f -> case f of {}
613+ , _validEncoder_decode = \_ -> throwError "void1Encoder: can't decode anything"
614+ }
615+
616+instance GShow Void1 where
617+ gshowsPrec _ = \case {}
618+
619+makePrisms ''ObeliskRoute
620+--TODO: Prevent deriveGShow from creating this warning:
621+-- Defined but not used: ‘p’
622+deriveGShow ''ResourceRoute
623+deriveGEq ''ResourceRoute
624+deriveGCompare ''ResourceRoute
625+deriveGShow ''JSaddleWarpRoute
626+deriveGEq ''JSaddleWarpRoute
627+deriveGCompare ''JSaddleWarpRoute
628+deriveGShow ''IndexOnlyRoute
629+deriveGEq ''IndexOnlyRoute
630+deriveGCompare ''IndexOnlyRoute
631+deriveGEq ''Void1
632+deriveGCompare ''Void1
633+
634+--TODO: decodeURIComponent as appropriate