@@ -0,0 +1,818 @@
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+ , PathQuery
24+ , Encoder
25+ , unsafeEncoder
26+ , checkEncoder
27+ , EncoderImpl (..)
28+ , EncoderFunc (..)
29+ , unsafeMkEncoder
30+ , encode
31+ , decode
32+ , tryDecode
33+ , hoistCheck
34+ , hoistParse
35+ , mapSome
36+ , SegmentResult (..)
37+ , pathComponentEncoder
38+ , enumEncoder
39+ , enum1Encoder
40+ , checkEnum1EncoderFunc
41+ , unitEncoder
42+ , pathOnlyEncoder
43+ , singletonListEncoder
44+ , unpackTextEncoder
45+ , prefixTextEncoder
46+ , unsafeTshowEncoder
47+ , someConstEncoder
48+ , singlePathSegmentEncoder
49+ , maybeEncoder
50+ , maybeToEitherEncoder
51+ , justEncoder
52+ , nothingEncoder
53+ , isoEncoder
54+ , wrappedEncoder
55+ , unwrappedEncoder
56+ , listToNonEmptyEncoder
57+ , prefixNonemptyTextEncoder
58+ , joinPairTextEncoder
59+ , toListMapEncoder
60+ , shadowEncoder
61+ , prismEncoder
62+ , rPrism
63+ , obeliskRouteEncoder
64+ , obeliskRouteSegment
65+ , pageNameEncoder
66+ , handleEncoder
67+ , ObeliskRoute (..)
68+ , _ObeliskRoute_App
69+ , _ObeliskRoute_Resource
70+ , ResourceRoute (..)
71+ , JSaddleWarpRoute (..)
72+ , jsaddleWarpRouteEncoder
73+ , IndexOnlyRoute (..)
74+ , indexOnlyRouteSegment
75+ , indexOnlyRouteEncoder
76+ , someSumEncoder
77+ , Void1
78+ , void1Encoder
79+ , pathSegmentsTextEncoder
80+ , queryParametersTextEncoder
81+ ) where
82+
83+import Prelude hiding ((.), id)
84+
85+import Control.Applicative
86+import Control.Category (Category (..))
87+import qualified Control.Categorical.Functor as Cat
88+import Control.Categorical.Bifunctor
89+import Control.Category.Associative
90+import Control.Category.Monoidal
91+import Control.Lens (Identity (..), Prism', makePrisms, itraverse, imap, prism, (^.), re, matching, (^?), _Just, _Nothing, Iso', from, view, Wrapped (..))
92+import Control.Monad.Except
93+import Data.Dependent.Sum (DSum (..))
94+import Data.Dependent.Map (DMap)
95+import qualified Data.Dependent.Map as DMap
96+import Data.Either.Validation (Validation (..))
97+import Data.Foldable
98+import Data.Functor.Sum
99+import Data.GADT.Compare
100+import Data.GADT.Compare.TH
101+import Data.GADT.Show
102+import Data.List.NonEmpty (NonEmpty (..))
103+import Data.Map (Map)
104+import qualified Data.Map as Map
105+import Data.Maybe
106+import Data.Set (Set)
107+import qualified Data.Set as Set
108+import Data.Some (Some)
109+import qualified Data.Some as Some
110+import Data.Some.Universe.Orphans ()
111+import Data.Text (Text)
112+import qualified Data.Text as T
113+import Data.Text.Encoding
114+import Data.Universe
115+import Network.HTTP.Types.URI
116+import Obelisk.Route.TH
117+import Text.Read (readMaybe)
118+
119+-- Design goals:
120+-- No start-up time on the frontend (not yet met)
121+-- Able to ensure that there aren't overlapping routes prior to deployment
122+-- Easy to write common types of parsers
123+-- Completeness checking
124+
125+-- Laws:
126+-- We statically know that all valid Routes can be turned into valid URIs
127+-- - This means we need to know whether there are any overlaps, e.g. with the static file namespace
128+
129+--TODO:
130+-- Backend:
131+-- Redirect the user to a canonical route
132+-- Pre-render
133+-- Frontend:
134+-- Intercept links that can be kept within the app
135+-- Fragments
136+
137+--------------------------------------------------------------------------------
138+-- Subroutes/paths
139+--------------------------------------------------------------------------------
140+
141+type R f = DSum f Identity --TODO: Better name
142+
143+--TODO: COMPLETE pragma
144+infixr 5 :/
145+pattern (:/) :: f a -> a -> R f
146+pattern a :/ b = a :=> Identity b
147+
148+mapSome :: (forall a. f a -> g a) -> Some f -> Some g
149+mapSome f (Some.This a) = Some.This $ f a
150+
151+--------------------------------------------------------------------------------
152+-- Encoder fundamentals
153+--------------------------------------------------------------------------------
154+
155+-- | This is the type of route encoder/decoders. It is parameterised over two monads: Firstly, the monad
156+-- used to check the validity of the encoder (i.e. that it is total), secondly the monad used for parsing
157+-- during the decode phase. The following two parameters are respectively the type of decoded data, and the
158+-- encoded type.
159+newtype Encoder check parse decoded encoded =
160+ Encoder { unEncoder :: check (EncoderImpl parse decoded encoded) }
161+
162+unsafeEncoder :: check (EncoderImpl parse decoded encoded) -> Encoder check parse decoded encoded
163+unsafeEncoder = Encoder
164+
165+-- | The internal type used to construct primitive 'Encoder' values.
166+-- Law:
167+-- forall p. _encoderImpl_decode ve . _encoderImpl_encode ve p == pure
168+-- 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 idempotent.
169+data EncoderImpl parse decoded encoded = EncoderImpl
170+ { _encoderImpl_decode :: !(encoded -> parse decoded) -- Can fail; can lose information; must always succeed on outputs of `_encoderImpl_encode` and result in the original value
171+ , _encoderImpl_encode :: !(decoded -> encoded) -- Must be injective
172+ }
173+
174+-- | Once an 'Encoder' has been checked, so that its check monad has become 'Identity', and its parser is total
175+-- so that its parse monad is also 'Identity', it may be used to actually decode by applying this function.
176+decode :: Encoder Identity Identity decoded encoded -> encoded -> decoded
177+decode e x = runIdentity (tryDecode e x)
178+
179+-- | Once an 'Encoder' has been checked, so that its check monad has become 'Identity', even if the same is not true of the
180+-- parse monad, we may still attempt to decode with it in its parse monad.
181+tryDecode :: Encoder Identity parse decoded encoded -> encoded -> parse decoded
182+tryDecode (Encoder (Identity impl)) x = _encoderImpl_decode impl x
183+
184+-- | Similar to 'decode' above, once an encoder has been checked so that its check monad is Identity, it
185+-- can be used to actually encode by using this. Note that while there's no constraint on the parse monad here,
186+-- one should usually be applying decode and encode to the same 'Encoder'
187+encode :: Encoder Identity parse decoded encoded -> decoded -> encoded
188+encode (Encoder (Identity impl)) x = _encoderImpl_encode impl x
189+
190+-- | This is a primitive used to build encoders which can't fail to check. It should not be used unless one is
191+-- reasonably certain that the law given for 'EncoderImpl' above holds.
192+unsafeMkEncoder :: (Applicative check) => EncoderImpl parse decoded encoded -> Encoder check parse decoded encoded
193+unsafeMkEncoder impl = Encoder (pure impl)
194+
195+-- | Transform the check monad of an 'Encoder' by applying a natural transformation.
196+hoistCheck :: (forall t. check t -> check' t) -> Encoder check parse a b -> Encoder check' parse a b
197+hoistCheck f (Encoder x) = Encoder (f x)
198+
199+-- | Transform the parse monad of an 'Encoder' by applying a natural transformation.
200+hoistParse :: (Functor check)
201+ => (forall t. parse t -> parse' t) -> Encoder check parse a b -> Encoder check parse' a b
202+hoistParse f (Encoder x) = Encoder (fmap (\(EncoderImpl dec enc) -> EncoderImpl (f . dec) enc) x)
203+
204+-- | Check an 'Encoder', transforming it into one whose check monad is anything we want (usually Identity).
205+checkEncoder :: (Applicative check', Functor check)
206+ => Encoder check parse decoded encoded
207+ -> check (Encoder check' parse decoded encoded)
208+checkEncoder = fmap unsafeMkEncoder . unEncoder
209+
210+instance (Applicative check, Monad parse) => Category (Encoder check parse) where
211+ id = Encoder $ pure id
212+ Encoder f . Encoder g = Encoder $ liftA2 (.) f g
213+
214+instance Monad parse => Category (EncoderImpl parse) where
215+ id = EncoderImpl
216+ { _encoderImpl_decode = pure
217+ , _encoderImpl_encode = id
218+ }
219+ f . g = EncoderImpl
220+ { _encoderImpl_decode = _encoderImpl_decode g <=< _encoderImpl_decode f
221+ , _encoderImpl_encode = _encoderImpl_encode f . _encoderImpl_encode g
222+ }
223+
224+instance Monad parse => PFunctor (,) (EncoderImpl parse) (EncoderImpl parse) where
225+ first f = bimap f id
226+instance Monad parse => QFunctor (,) (EncoderImpl parse) (EncoderImpl parse) where
227+ second g = bimap id g
228+instance Monad parse => Bifunctor (,) (EncoderImpl parse) (EncoderImpl parse) (EncoderImpl parse) where
229+ bimap f g = EncoderImpl
230+ { _encoderImpl_encode = bimap (_encoderImpl_encode f) (_encoderImpl_encode g)
231+ , _encoderImpl_decode = \(a, b) -> liftA2 (,) (_encoderImpl_decode f a) (_encoderImpl_decode g b)
232+ }
233+
234+instance (Applicative check, Monad parse) => PFunctor (,) (Encoder check parse) (Encoder check parse) where
235+ first f = bimap f id
236+instance (Applicative check, Monad parse) => QFunctor (,) (Encoder check parse) (Encoder check parse) where
237+ second g = bimap id g
238+instance (Applicative check, Monad parse) => Bifunctor (,) (Encoder check parse) (Encoder check parse) (Encoder check parse) where
239+ bimap f g = Encoder $ liftA2 bimap (unEncoder f) (unEncoder g)
240+
241+instance (Traversable f, Monad parse) => Cat.Functor f (EncoderImpl parse) (EncoderImpl parse) where
242+ fmap ve = EncoderImpl
243+ { _encoderImpl_encode = fmap $ _encoderImpl_encode ve
244+ , _encoderImpl_decode = traverse $ _encoderImpl_decode ve
245+ }
246+
247+instance (Traversable f, Monad check, Monad parse) => Cat.Functor f (Encoder check parse) (Encoder check parse) where
248+ fmap e = Encoder $ do
249+ ve <- unEncoder e
250+ pure $ Cat.fmap ve
251+
252+instance Monad parse => Associative (EncoderImpl parse) (,) where
253+ associate = EncoderImpl
254+ { _encoderImpl_encode = associate
255+ , _encoderImpl_decode = pure . disassociate
256+ }
257+ disassociate = EncoderImpl
258+ { _encoderImpl_encode = disassociate
259+ , _encoderImpl_decode = pure . associate
260+ }
261+
262+instance Monad parse => Monoidal (EncoderImpl parse) (,) where
263+ type Id (EncoderImpl parse) (,) = ()
264+ idl = EncoderImpl
265+ { _encoderImpl_encode = idl
266+ , _encoderImpl_decode = pure . coidl
267+ }
268+ idr = EncoderImpl
269+ { _encoderImpl_encode = idr
270+ , _encoderImpl_decode = pure . coidr
271+ }
272+ coidl = EncoderImpl
273+ { _encoderImpl_encode = coidl
274+ , _encoderImpl_decode = pure . idl
275+ }
276+ coidr = EncoderImpl
277+ { _encoderImpl_encode = coidr
278+ , _encoderImpl_decode = pure . idr
279+ }
280+
281+instance (Applicative check, Monad parse) => Associative (Encoder check parse) (,) where
282+ associate = Encoder $ pure associate
283+ disassociate = Encoder $ pure disassociate
284+
285+instance (Applicative check, Monad parse) => Monoidal (Encoder check parse) (,) where
286+ type Id (Encoder check parse) (,) = ()
287+ idl = Encoder $ pure idl
288+ idr = Encoder $ pure idr
289+ coidl = Encoder $ pure coidl
290+ coidr = Encoder $ pure coidr
291+
292+--------------------------------------------------------------------------------
293+-- Specific instances of encoders
294+--------------------------------------------------------------------------------
295+
296+-- | Given a valid 'Iso' from lens, construct an 'Encoder'
297+isoEncoder :: (Applicative check, Applicative parse) => Iso' a b -> Encoder check parse a b
298+isoEncoder f = unsafeMkEncoder $ EncoderImpl
299+ { _encoderImpl_encode = view f
300+ , _encoderImpl_decode = pure . view (from f)
301+ }
302+
303+wrappedEncoder :: (Wrapped a, Applicative check, Applicative parse) => Encoder check parse (Unwrapped a) a
304+wrappedEncoder = isoEncoder $ from _Wrapped'
305+
306+unwrappedEncoder :: (Wrapped a, Applicative check, Applicative parse) => Encoder check parse a (Unwrapped a)
307+unwrappedEncoder = isoEncoder _Wrapped'
308+
309+maybeToEitherEncoder :: (Applicative check, Applicative parse) => Encoder check parse (Maybe a) (Either () a)
310+maybeToEitherEncoder = unsafeMkEncoder $ EncoderImpl
311+ { _encoderImpl_encode = \case
312+ Nothing -> Left ()
313+ Just a -> Right a
314+ , _encoderImpl_decode = pure . \case
315+ Left _ -> Nothing
316+ Right a -> Just a
317+ }
318+
319+maybeEncoder
320+ :: ( MonadError Text check
321+ , Show a
322+ , Show b
323+ , check ~ parse
324+ )
325+ => Encoder check parse () b
326+ -> Encoder check parse a b
327+ -> Encoder check parse (Maybe a) b
328+maybeEncoder f g = shadowEncoder f g . maybeToEitherEncoder
329+
330+-- | Encode a value by simply applying 'Just'
331+justEncoder :: (Applicative check, MonadError Text parse) => Encoder check parse a (Maybe a)
332+justEncoder = prismEncoder _Just
333+
334+-- |
335+nothingEncoder :: (Applicative check, MonadError Text parse) => Encoder check parse () (Maybe a)
336+nothingEncoder = prismEncoder _Nothing
337+
338+someConstEncoder :: (Applicative check, Applicative parse) => Encoder check parse (Some (Const a)) a
339+someConstEncoder = unsafeMkEncoder $ EncoderImpl
340+ { _encoderImpl_encode = \(Some.This (Const a)) -> a
341+ , _encoderImpl_decode = pure . Some.This . Const
342+ }
343+
344+-- | WARNING: This is only safe if the Show and Read instances for 'a' are
345+-- inverses of each other
346+unsafeTshowEncoder :: (Show a, Read a, Applicative check, MonadError Text parse) => Encoder check parse a Text
347+unsafeTshowEncoder = unsafeMkEncoder $ EncoderImpl
348+ { _encoderImpl_encode = tshow
349+ , _encoderImpl_decode = \raw -> case readMaybe $ T.unpack raw of
350+ Nothing -> throwError $ "unsafeTshowEncoderImpl: couldn't decode " <> tshow raw
351+ Just parsed -> pure parsed
352+ }
353+
354+newtype EncoderFunc check parse p r = EncoderFunc { runEncoderImplFunc :: forall a. p a -> Encoder check parse a r }
355+
356+newtype Flip f a b = Flip { unFlip :: f b a }
357+
358+checkEnum1EncoderFunc
359+ :: forall check check' parse p r.
360+ ( Universe (Some p)
361+ , GCompare p
362+ , Monad check
363+ , Applicative check'
364+ )
365+ => (forall a. p a -> Encoder check parse a r)
366+ -> check (EncoderFunc check' parse p r)
367+checkEnum1EncoderFunc f = do
368+ (encoderImpls :: DMap p (Flip (EncoderImpl parse) r)) <- DMap.fromList <$>
369+ traverse (\(Some.This p) -> (p :=>) . Flip <$> unEncoder (f p)) universe
370+ pure $ EncoderFunc $ \p -> unsafeMkEncoder . unFlip $
371+ DMap.findWithDefault (error "checkEnum1EncoderFunc: EncoderImpl not found (should be impossible)") p encoderImpls
372+
373+-- | This type is used by pathComponentEncoder to allow the user to indicate how to treat various cases when encoding a dependent sum of type `(R p)`.
374+data SegmentResult check parse a =
375+ PathEnd (Encoder check parse a (Map Text (Maybe Text))) -- ^ Indicate that the path is finished, with an Encoder that translates the corresponding value into query parameters
376+ | PathSegment Text (Encoder check parse a PageName) -- ^ Indicate that the key should be represented by an additional path segment with the given 'Text', and give an Encoder for translating the corresponding value into the remainder of the route.
377+
378+-- | Encode a dependent sum of type `(R p)` into a PageName (i.e. the path and query part of a URL) by using the
379+-- supplied function to decide how to encode the constructors of p using the SegmentResult type. It is important
380+-- that the number of values of type `(Some p)` be relatively small in order for checking to complete quickly.
381+pathComponentEncoder
382+ :: forall check parse p.
383+ ( Universe (Some p)
384+ , GShow p
385+ , GCompare p
386+ , MonadError Text check
387+ , MonadError Text parse )
388+ => (forall a. p a -> SegmentResult check parse a)
389+ -> Encoder check parse (R p) PageName
390+pathComponentEncoder f = Encoder $ do
391+ let extractEncoder = \case
392+ PathEnd e -> first (unitEncoder []) . coidl . e
393+ PathSegment _ e -> e
394+ extractPathSegment = \case
395+ PathEnd _ -> Nothing
396+ PathSegment t _ -> Just t
397+ EncoderFunc f' <- checkEnum1EncoderFunc (extractEncoder . f)
398+ unEncoder (pathComponentEncoderImpl (enum1Encoder (extractPathSegment . f)) f')
399+
400+pathComponentEncoderImpl :: forall check parse p. (Monad check, Monad parse)
401+ => (Encoder check parse (Some p) (Maybe Text))
402+ -> (forall a. p a -> Encoder Identity parse a PageName)
403+ -> Encoder check parse (R p) PageName
404+pathComponentEncoderImpl this rest =
405+ chainEncoder (lensEncoder (\(_, b) a -> (a, b)) Prelude.fst consEncoder) this rest
406+
407+--NOTE: Naming convention in this module is to always talk about things in the *encoding* direction, never in the *decoding* direction
408+
409+chainEncoder
410+ :: forall check parse p r b.
411+ ( Monad check
412+ , Monad parse
413+ )
414+ => Encoder check parse (b, r) r
415+ -> Encoder check parse (Some p) b
416+ -> (forall a. p a -> Encoder Identity parse a r)
417+ -> Encoder check parse (R p) r
418+chainEncoder cons this rest = Encoder $ do
419+ consValid <- unEncoder cons
420+ thisValid <- unEncoder this
421+ pure $ EncoderImpl
422+ { _encoderImpl_decode = \v -> do
423+ (here, following) <- _encoderImpl_decode consValid v
424+ Some.This r <- _encoderImpl_decode thisValid here
425+ (r :/) <$> _encoderImpl_decode (runIdentity . unEncoder $ rest r) following
426+ , _encoderImpl_encode = \(r :/ s) ->
427+ _encoderImpl_encode consValid
428+ ( _encoderImpl_encode thisValid $ Some.This r
429+ , _encoderImpl_encode (runIdentity . unEncoder $ rest r) s)
430+ }
431+
432+--TODO: Do this in terms of a lens instead
433+lensEncoder :: (Applicative check, Monad parse)
434+ => (b -> [a] -> b) -> (b -> [a]) -> Encoder check parse (c, [a]) [a] -> Encoder check parse (c, b) b
435+lensEncoder set get g = Encoder $ do
436+ gImpl <- unEncoder g
437+ pure $ EncoderImpl
438+ { _encoderImpl_encode = \(ma, b) -> set b $ _encoderImpl_encode gImpl (ma, get b)
439+ , _encoderImpl_decode = \b -> do
440+ (ma, la) <- _encoderImpl_decode gImpl $ get b
441+ pure (ma, set b la)
442+ }
443+
444+consEncoder :: (Applicative check, Applicative parse) => Encoder check parse (Maybe a, [a]) [a] --TODO: Really shouldn't *always* have the [a], even in the Nothing case
445+consEncoder = unsafeMkEncoder $ EncoderImpl
446+ { _encoderImpl_encode = \(h, t) -> maybeToList h <> t
447+ , _encoderImpl_decode = pure . \case
448+ [] -> (Nothing, [])
449+ h:t -> (Just h, t)
450+ }
451+
452+tshow :: Show a => a -> Text
453+tshow = T.pack . show
454+
455+shadowEncoder
456+ :: ( Universe a
457+ , MonadError Text check
458+ , Show a
459+ , Show b
460+ , Show c
461+ , check ~ parse --TODO: Get rid of this
462+ )
463+ => Encoder check parse a c -- ^ Overlaps; should have a small number of possible routes
464+ -> Encoder check parse b c -- ^ Gets overlapped
465+ -> Encoder check parse (Either a b) c
466+shadowEncoder f g = Encoder $ do
467+ vf <- unEncoder f
468+ vg <- unEncoder g
469+ let gCanParse c = catchError (Just <$> _encoderImpl_decode vg c) (\_ -> pure Nothing)
470+ overlaps <- fmap catMaybes $ forM universe $ \a -> do
471+ let c = _encoderImpl_encode vf a
472+ mb <- gCanParse c
473+ pure $ fmap (\b -> (a, b, c)) mb
474+ case overlaps of
475+ [] -> pure ()
476+ _ -> throwError $ "shadowEncoder: overlap detected: " <> T.unlines
477+ (flip fmap overlaps $ \(a, b, c) -> "first encoder encodes " <> tshow a <> " as " <> tshow c <> ", which second encoder decodes as " <> tshow b)
478+ pure $ EncoderImpl
479+ { _encoderImpl_encode = \case
480+ Left a -> _encoderImpl_encode vf a
481+ Right b -> _encoderImpl_encode vg b
482+ , _encoderImpl_decode = \c -> (Left <$> _encoderImpl_decode vf c) `catchError` \_ -> Right <$> _encoderImpl_decode vg c
483+ }
484+
485+enum1Encoder
486+ :: ( Universe (Some p)
487+ , GShow p
488+ , GCompare p
489+ , MonadError Text check
490+ , MonadError Text parse
491+ , Ord r
492+ , Show r
493+ )
494+ => (forall a. p a -> r) -> Encoder check parse (Some p) r
495+enum1Encoder f = enumEncoder $ \(Some.This p) -> f p
496+
497+-- | Encode an enumerable, bounded type. WARNING: Don't use this on types that
498+-- have a large number of values - it will use a lot of memory.
499+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
500+enumEncoder f = Encoder $ do
501+ let reversed = Map.fromListWith (<>) [ (f p, Set.singleton p) | p <- universe ]
502+ checkSingleton k vs = case Set.toList vs of
503+ [] -> error "enumEncoder: empty reverse mapping; should be impossible"
504+ [e] -> Success e
505+ _ -> Failure $ Map.singleton k vs
506+ showRedundant :: r -> Set p -> [Text]
507+ showRedundant k vs = (" " <> tshow k <> " can decode to any of:")
508+ : fmap ((" "<>) . tshow) (Set.toList vs)
509+ case itraverse checkSingleton reversed :: Validation (Map r (Set p)) (Map r p) of
510+ Failure ambiguousEntries -> throwError $ T.unlines $
511+ "enumEncoder: ambiguous encodings detected:" : concat (Map.elems $ imap showRedundant ambiguousEntries)
512+ Success m -> pure $ EncoderImpl
513+ { _encoderImpl_decode = \r -> case Map.lookup r m of
514+ Just a -> pure a
515+ Nothing -> throwError $ "enumEncoder: not recognized: " <> tshow r --TODO: Report this as a better type
516+ , _encoderImpl_encode = f
517+ }
518+
519+unitEncoder :: (Applicative check, MonadError Text parse, Show r, Eq r) => r -> Encoder check parse () r
520+unitEncoder expected = unsafeMkEncoder $ EncoderImpl
521+ { _encoderImpl_decode = \obtained ->
522+ if obtained == expected
523+ then pure ()
524+ else throwError $ "endEncoderImpl: expected " <> tshow expected <> ", got " <> tshow obtained
525+ , _encoderImpl_encode = \_ -> expected
526+ }
527+
528+singlePathSegmentEncoder :: (Applicative check, MonadError Text parse) => Encoder check parse Text PageName
529+singlePathSegmentEncoder = pathOnlyEncoder . singletonListEncoder
530+
531+pathOnlyEncoder :: (Applicative check, MonadError Text parse) => Encoder check parse [Text] PageName
532+pathOnlyEncoder = unsafeMkEncoder $ EncoderImpl
533+ { _encoderImpl_decode = \(path, query) ->
534+ if query == mempty
535+ then pure path
536+ else throwError "pathOnlyEncoderImpl: query was provided"
537+ , _encoderImpl_encode = \path -> (path, mempty)
538+ }
539+
540+singletonListEncoder :: (Applicative check, MonadError Text parse) => Encoder check parse a [a]
541+singletonListEncoder = unsafeMkEncoder $ EncoderImpl
542+ { _encoderImpl_decode = \case
543+ [a] -> pure a
544+ l -> throwError $ "singletonListEncoderImpl: expected one item, got " <> tshow (length l)
545+ , _encoderImpl_encode = (:[])
546+ }
547+
548+splitTextNonEmpty :: Text -> Text -> NonEmpty Text
549+splitTextNonEmpty separator v = case T.splitOn separator v of
550+ [] -> error "splitTextNonEmpty: Data.Text.splitOn should never return an empty list"
551+ h : t -> h :| t
552+
553+--TODO: To know this is reversible, we must know that the separator isn't included anywhere in the input text
554+pathSegmentsTextEncoder :: (Applicative check, Applicative parse) => Encoder check parse (NonEmpty Text) Text
555+pathSegmentsTextEncoder = unsafeMkEncoder $ EncoderImpl
556+ { _encoderImpl_encode = T.intercalate "/" . fmap (urlEncodeText False) . toList
557+ , _encoderImpl_decode = pure . fmap (urlDecodeText False) . splitTextNonEmpty "/"
558+ }
559+
560+queryParametersTextEncoder :: (Applicative check, Applicative parse) => Encoder check parse [(Text, Maybe Text)] Text
561+queryParametersTextEncoder = Encoder $ pure $ EncoderImpl
562+ { _encoderImpl_encode = \case
563+ [] -> ""
564+ params -> T.intercalate "&" (fmap encodeParameter params)
565+ , _encoderImpl_decode = pure . \case
566+ "" -> []
567+ encoded ->
568+ let h :| t = splitTextNonEmpty "&" encoded
569+ in fmap decodeParameter $ h : t
570+ }
571+ where
572+ encodeParameter (k, mv) = urlEncodeText True k <> case mv of
573+ Nothing -> ""
574+ Just v -> "=" <> urlEncodeText True v
575+ decodeParameter t =
576+ let (k, eqV) = T.breakOn "=" t
577+ mv = T.stripPrefix "=" eqV
578+ in (urlDecodeText True k, urlDecodeText True <$> mv)
579+
580+urlEncodeText :: Bool -> Text -> Text
581+urlEncodeText q = decodeUtf8 . urlEncode q . encodeUtf8
582+
583+urlDecodeText :: Bool -> Text -> Text
584+urlDecodeText q = decodeUtf8 . urlDecode q . encodeUtf8
585+
586+listToNonEmptyEncoder :: (Applicative check, Applicative parse, Monoid a, Eq a) => Encoder check parse [a] (NonEmpty a)
587+listToNonEmptyEncoder = Encoder $ pure $ EncoderImpl
588+ { _encoderImpl_encode = \case
589+ [] -> mempty :| []
590+ h : t -> h :| t
591+ , _encoderImpl_decode = \(h :| t) -> pure $
592+ if h == mempty
593+ then []
594+ else h : t
595+ }
596+
597+prefixTextEncoder :: (Applicative check, MonadError Text parse) => Text -> Encoder check parse Text Text
598+prefixTextEncoder p = Encoder $ pure $ EncoderImpl
599+ { _encoderImpl_encode = mappend p
600+ , _encoderImpl_decode = \v -> case T.stripPrefix p v of
601+ Nothing -> throwError $ "prefixTextEncoder: wrong prefix; expected " <> tshow p <> ", got " <> tshow (T.take (T.length p) v)
602+ Just stripped -> pure stripped
603+ }
604+
605+prefixNonemptyTextEncoder :: (Applicative check, MonadError Text parse) => Text -> Encoder check parse Text Text
606+prefixNonemptyTextEncoder p = Encoder $ pure $ EncoderImpl
607+ { _encoderImpl_encode = \case
608+ "" -> ""
609+ v -> p <> v
610+ , _encoderImpl_decode = \case
611+ "" -> pure ""
612+ v -> case T.stripPrefix p v of
613+ Nothing -> throwError $ "prefixTextEncoder: wrong prefix; expected " <> tshow p
614+ Just stripped -> pure stripped
615+ }
616+
617+unpackTextEncoder :: (Applicative check, Applicative parse) => Encoder check parse Text String
618+unpackTextEncoder = Encoder $ pure $ EncoderImpl
619+ { _encoderImpl_encode = T.unpack
620+ , _encoderImpl_decode = pure . T.pack
621+ }
622+
623+toListMapEncoder :: (Applicative check, Applicative parse, Ord k) => Encoder check parse (Map k v) [(k, v)]
624+toListMapEncoder = Encoder $ pure $ EncoderImpl
625+ { _encoderImpl_encode = Map.toList
626+ , _encoderImpl_decode = pure . Map.fromList --TODO: Should we be stricter about repeated keys?
627+ }
628+
629+joinPairTextEncoder :: (MonadError Text check, MonadError Text parse) => Text -> Encoder check parse (Text, Text) Text
630+joinPairTextEncoder = Encoder . \case
631+ "" -> throwError "joinPairTextEncoder: empty separator"
632+ separator -> pure $ EncoderImpl
633+ { _encoderImpl_encode = \(k, v) -> k <> separator <> v
634+ , _encoderImpl_decode = \r ->
635+ let (kt, vt) = T.breakOn separator r
636+ in case vt of
637+ -- The separator was not found
638+ "" -> throwError $ "joinPairTextEncoder: separator not found; expected " <> tshow separator
639+ _ -> return (kt, T.drop (T.length separator) vt)
640+ }
641+
642+--TODO: Rewrite this by composing the given prism with a lens on the first element of the DSum
643+-- Or, more likely, the user can compose it themselves
644+rPrism :: forall f g. (forall a. Prism' (f a) (g a)) -> Prism' (R f) (R g)
645+rPrism p = prism (\(g :/ x) -> g ^. re p :/ x) (\(f :/ x) -> bimap (:/ x) (:/ x) $ matching p f)
646+
647+-- | An encoder that only works on the items available via the prism. An error will be thrown in the parse monad
648+-- if the prism doesn't match.
649+prismEncoder :: (Applicative check, MonadError Text parse) => Prism' b a -> Encoder check parse a b
650+prismEncoder p = unsafeMkEncoder $ EncoderImpl
651+ { _encoderImpl_encode = (^. re p)
652+ , _encoderImpl_decode = \r -> case r ^? p of
653+ Just a -> pure a
654+ Nothing -> throwError "prismEncoder: value is not present in the prism"
655+ }
656+
657+-- | A URL path and query string, in which trailing slashes don't matter in the path
658+-- and duplicate query parameters are not allowed. A final goal of encoders using this library
659+-- will frequently be to produce this.
660+type PageName = ([Text], Map Text (Maybe Text))
661+
662+-- | A path (separated by slashes), and a query string.
663+type PathQuery = (String, String)
664+
665+-- | Encode a PageName into a path and query string.
666+pageNameEncoder :: (Applicative check, MonadError Text parse) => Encoder check parse PageName PathQuery
667+pageNameEncoder = bimap
668+ (unpackTextEncoder . prefixTextEncoder "/" . pathSegmentsTextEncoder . listToNonEmptyEncoder)
669+ (unpackTextEncoder . prefixNonemptyTextEncoder "?" . queryParametersTextEncoder . toListMapEncoder)
670+
671+-- | Handle an error in parsing, for example, in order to redirect to a 404 page.
672+handleEncoder
673+ :: (Functor check)
674+ => (e -> a)
675+ -> Encoder check (Either e) a b
676+ -> Encoder check Identity a b
677+handleEncoder recover e = Encoder $ do
678+ i <- unEncoder e
679+ return $ i
680+ { _encoderImpl_decode = \a -> pure $ case _encoderImpl_decode i a of
681+ Right r -> r
682+ Left err -> recover err
683+ }
684+
685+--------------------------------------------------------------------------------
686+-- Actual obelisk route info
687+--------------------------------------------------------------------------------
688+
689+-- | A type which can represent Obelisk-specific resource routes, in addition to application specific routes which serve your
690+-- frontend.
691+data ObeliskRoute :: (* -> *) -> * -> * where
692+ -- 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
693+ ObeliskRoute_App :: f a -> ObeliskRoute f a
694+ ObeliskRoute_Resource :: ResourceRoute a -> ObeliskRoute f a
695+
696+instance Universe (Some f) => Universe (Some (ObeliskRoute f)) where
697+ universe = fmap (\(Some.This x) -> Some.This (ObeliskRoute_App x)) universe
698+ ++ fmap (\(Some.This x) -> Some.This (ObeliskRoute_Resource x)) universe
699+
700+instance GEq f => GEq (ObeliskRoute f) where
701+ geq (ObeliskRoute_App x) (ObeliskRoute_App y) = geq x y
702+ geq (ObeliskRoute_Resource x) (ObeliskRoute_Resource y) = geq x y
703+ geq _ _ = Nothing
704+
705+instance GCompare f => GCompare (ObeliskRoute f) where
706+ gcompare (ObeliskRoute_App x) (ObeliskRoute_App y) = gcompare x y
707+ gcompare (ObeliskRoute_Resource x) (ObeliskRoute_Resource y) = gcompare x y
708+ gcompare (ObeliskRoute_App _) (ObeliskRoute_Resource _) = GLT
709+ gcompare (ObeliskRoute_Resource _) (ObeliskRoute_App _) = GGT
710+
711+-- | A type representing the various resource routes served by Obelisk. These can in principle map to any physical routes you want,
712+-- but sane defaults are provided by 'resourceRouteSegment'
713+data ResourceRoute :: * -> * where
714+ 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")
715+ ResourceRoute_Ghcjs :: ResourceRoute [Text]
716+ ResourceRoute_JSaddleWarp :: ResourceRoute (R JSaddleWarpRoute)
717+
718+-- | If there are no additional backend routes in your app (i.e. ObeliskRoute gives you all the routes you need),
719+-- this constructs a suitable 'Encoder' to use for encoding routes to 'PageName's. If you do have additional backend routes,
720+-- you'll want to use 'pathComponentEncoder' yourself, applied to a function that will likely use obeliskRouteSegment in order to
721+-- handle the ObeliskRoute case (i.e. Obelisk resource routes and app frontend routes).
722+obeliskRouteEncoder :: forall check parse appRoute.
723+ ( Universe (Some (ObeliskRoute appRoute))
724+ , GCompare (ObeliskRoute appRoute)
725+ , GShow appRoute
726+ , MonadError Text check
727+ , check ~ parse --TODO: Get rid of this
728+ )
729+ => (forall a. appRoute a -> SegmentResult check parse a)
730+ -> Encoder check parse (R (ObeliskRoute appRoute)) PageName
731+obeliskRouteEncoder appRouteSegment = pathComponentEncoder $ \r ->
732+ obeliskRouteSegment r appRouteSegment
733+
734+-- | From a function which explains how app-specific frontend routes translate into segments, produce a function which does the
735+-- same for ObeliskRoute. This uses the given function for the 'ObeliskRoute_App' case, and 'resourceRouteSegment' for the
736+-- 'ObeliskRoute_Resource' case.
737+obeliskRouteSegment :: forall check parse appRoute a.
738+ (MonadError Text check, MonadError Text parse)
739+ => ObeliskRoute appRoute a
740+ -> (forall b. appRoute b -> SegmentResult check parse b)
741+ -> SegmentResult check parse a
742+obeliskRouteSegment r appRouteSegment = case r of
743+ ObeliskRoute_App appRoute -> appRouteSegment appRoute
744+ ObeliskRoute_Resource resourceRoute -> resourceRouteSegment resourceRoute
745+
746+-- | A function which gives a sane default for how to encode Obelisk resource routes. It's given in this form, because it will
747+-- be combined with other such segment encoders before 'pathComponentEncoder' turns it into a proper 'Encoder'.
748+resourceRouteSegment :: (MonadError Text check, MonadError Text parse) => ResourceRoute a -> SegmentResult check parse a
749+resourceRouteSegment = \case
750+ ResourceRoute_Static -> PathSegment "static" $ pathOnlyEncoder
751+ ResourceRoute_Ghcjs -> PathSegment "ghcjs" $ pathOnlyEncoder
752+ ResourceRoute_JSaddleWarp -> PathSegment "jsaddle" $ jsaddleWarpRouteEncoder
753+
754+data JSaddleWarpRoute :: * -> * where
755+ JSaddleWarpRoute_JavaScript :: JSaddleWarpRoute ()
756+ JSaddleWarpRoute_WebSocket :: JSaddleWarpRoute ()
757+ JSaddleWarpRoute_Sync :: JSaddleWarpRoute [Text]
758+
759+jsaddleWarpRouteEncoder :: (MonadError Text check, MonadError Text parse) => Encoder check parse (R JSaddleWarpRoute) PageName
760+jsaddleWarpRouteEncoder = pathComponentEncoder $ \case
761+ JSaddleWarpRoute_JavaScript -> PathSegment "jsaddle.js" $ unitEncoder mempty
762+ JSaddleWarpRoute_WebSocket -> PathEnd $ unitEncoder mempty
763+ JSaddleWarpRoute_Sync -> PathSegment "sync" $ pathOnlyEncoder
764+
765+instance GShow appRoute => GShow (ObeliskRoute appRoute) where
766+ gshowsPrec prec = \case
767+ ObeliskRoute_App appRoute -> showParen (prec > 10) $
768+ showString "ObeliskRoute_App " . gshowsPrec 11 appRoute
769+ ObeliskRoute_Resource appRoute -> showParen (prec > 10) $
770+ showString "ObeliskRoute_Resource " . gshowsPrec 11 appRoute
771+
772+data IndexOnlyRoute :: * -> * where
773+ IndexOnlyRoute :: IndexOnlyRoute ()
774+
775+indexOnlyRouteSegment :: (Applicative check, MonadError Text parse) => IndexOnlyRoute a -> SegmentResult check parse a
776+indexOnlyRouteSegment = \case
777+ IndexOnlyRoute -> PathEnd $ unitEncoder mempty
778+
779+indexOnlyRouteEncoder :: (MonadError Text check, MonadError Text parse) => Encoder check parse (R IndexOnlyRoute) PageName
780+indexOnlyRouteEncoder = pathComponentEncoder indexOnlyRouteSegment
781+
782+someSumEncoder :: (Applicative check, Applicative parse) => Encoder check parse (Some (Sum a b)) (Either (Some a) (Some b))
783+someSumEncoder = Encoder $ pure $ EncoderImpl
784+ { _encoderImpl_encode = \(Some.This t) -> case t of
785+ InL l -> Left $ Some.This l
786+ InR r -> Right $ Some.This r
787+ , _encoderImpl_decode = pure . \case
788+ Left (Some.This l) -> Some.This (InL l)
789+ Right (Some.This r) -> Some.This (InR r)
790+ }
791+
792+data Void1 :: * -> * where {}
793+
794+instance Universe (Some Void1) where
795+ universe = []
796+
797+void1Encoder :: (Applicative check, MonadError Text parse) => Encoder check parse (Some Void1) a
798+void1Encoder = Encoder $ pure $ EncoderImpl
799+ { _encoderImpl_encode = \case
800+ Some.This f -> case f of {}
801+ , _encoderImpl_decode = \_ -> throwError "void1Encoder: can't decode anything"
802+ }
803+
804+instance GShow Void1 where
805+ gshowsPrec _ = \case {}
806+
807+concat <$> mapM deriveRouteComponent
808+ [ ''ResourceRoute
809+ , ''JSaddleWarpRoute
810+ , ''IndexOnlyRoute
811+ ]
812+
813+makePrisms ''ObeliskRoute
814+
815+deriveGEq ''Void1
816+deriveGCompare ''Void1
817+
818+--TODO: decodeURIComponent as appropriate