@@ -12,7 +12,9 @@
1212{-# LANGUAGE PatternSynonyms #-}
1313{-# LANGUAGE RankNTypes #-}
1414{-# LANGUAGE ScopedTypeVariables #-}
15+{-# LANGUAGE StandaloneDeriving #-}
1516{-# LANGUAGE TemplateHaskell #-}
17+{-# LANGUAGE TypeApplications #-}
1618{-# LANGUAGE TypeFamilies #-}
1719{-# LANGUAGE TypeOperators #-}
1820{-# LANGUAGE ViewPatterns #-}
@@ -61,10 +63,15 @@ module Obelisk.Route
6163 , shadowEncoder
6264 , prismEncoder
6365 , rPrism
66+ , _R
6467 , obeliskRouteEncoder
6568 , obeliskRouteSegment
6669 , pageNameEncoder
6770 , handleEncoder
71+ , FullRoute (..)
72+ , _FullRoute_Frontend
73+ , _FullRoute_Backend
74+ , mkFullRouteEncoder
6875 , ObeliskRoute (..)
6976 , _ObeliskRoute_App
7077 , _ObeliskRoute_Resource
@@ -85,6 +92,13 @@ module Obelisk.Route
8592 , readShowEncoder
8693 , integralEncoder
8794 , pathSegmentEncoder
95+ , queryOnlyEncoder
96+ , Decoder(..)
97+ , dmapEncoder
98+ , fieldMapEncoder
99+ , pathFieldEncoder
100+ , jsonEncoder
101+ , byteStringsToPageName
88102 ) where
89103
90104import Prelude hiding ((.), id)
@@ -95,8 +109,32 @@ import qualified Control.Categorical.Functor as Cat
95109import Control.Categorical.Bifunctor
96110import Control.Category.Associative
97111import Control.Category.Monoidal
98−import Control.Lens (Identity (..), Prism', makePrisms, itraverse, imap, prism, (^.), re, matching, (^?), _Just, _Nothing, Iso', from, view, Wrapped (..))
112+import Control.Category.Braided
113+import Control.Lens
114+ ( Identity (..)
115+ , (^.)
116+ , (^?)
117+ , _Just
118+ , _Nothing
119+ , Cons(..)
120+ , from
121+ , imap
122+ , iso
123+ , Iso'
124+ , itraverse
125+ , makePrisms
126+ , Prism'
127+ , prism'
128+ , re
129+ , view
130+ , Wrapped (..)
131+ )
99132import Control.Monad.Except
133+import Control.Monad.Writer (execWriter, tell)
134+import qualified Control.Monad.State.Strict as State
135+import Control.Monad.Trans (lift)
136+import qualified Data.ByteString as BS
137+import qualified Data.ByteString.Lazy as BSL
100138import Data.Dependent.Sum (DSum (..))
101139import Data.Dependent.Map (DMap)
102140import qualified Data.Dependent.Map as DMap
@@ -113,17 +151,19 @@ import Data.Maybe
113151import Data.Monoid ((<>))
114152import Data.Set (Set)
115153import qualified Data.Set as Set
116−import Data.Some (Some)
117−import qualified Data.Some as Some
118−import Data.Some.Universe.Orphans ()
154+import Data.Some (Some(Some))
119155import Data.Text (Text)
120156import qualified Data.Text as T
121−import Data.Text.Encoding
157+import qualified Data.Text.Encoding as T
122158import Data.Universe
159+import Data.Universe.Some
123160import Network.HTTP.Types.URI
124161import qualified Numeric.Lens
125162import Obelisk.Route.TH
126163import Text.Read (readMaybe)
164+import Data.Tabulation
165+import qualified Data.Aeson as Aeson
166+import Data.Aeson (FromJSON, ToJSON)
127167
128168-- Design goals:
129169-- No start-up time on the frontend (not yet met)
@@ -149,13 +189,13 @@ import Text.Read (readMaybe)
149189
150190type R f = DSum f Identity --TODO: Better name
151191
152−--TODO: COMPLETE pragma
192+{-# COMPLETE (:/) #-}
153193infixr 5 :/
154194pattern (:/) :: f a -> a -> R f
155195pattern a :/ b = a :=> Identity b
156196
157197mapSome :: (forall a. f a -> g a) -> Some f -> Some g
158−mapSome f (Some.This a) = Some.This $ f a
198+mapSome f (Some a) = Some $ f a
159199
160200hoistR :: (forall x. f x -> g x) -> R f -> R g
161201hoistR f (x :=> Identity y) = f x :/ y
@@ -243,6 +283,10 @@ instance Monad parse => Bifunctor (,) (EncoderImpl parse) (EncoderImpl parse) (E
243283 , _encoderImpl_decode = \(a, b) -> liftA2 (,) (_encoderImpl_decode f a) (_encoderImpl_decode g b)
244284 }
245285
286+instance (Monad parse, Applicative check) => Braided (Encoder check parse) (,) where
287+ braid = isoEncoder (iso swap swap)
288+
289+
246290instance (Applicative check, Monad parse) => PFunctor (,) (Encoder check parse) (Encoder check parse) where
247291 first f = bimap f id
248292instance (Applicative check, Monad parse) => QFunctor (,) (Encoder check parse) (Encoder check parse) where
@@ -256,6 +300,34 @@ instance (Traversable f, Monad parse) => Cat.Functor f (EncoderImpl parse) (Enco
256300 , _encoderImpl_decode = traverse $ _encoderImpl_decode ve
257301 }
258302
303+instance Monad parse => PFunctor Either (EncoderImpl parse) (EncoderImpl parse) where
304+ first f = bimap f id
305+instance Monad parse => QFunctor Either (EncoderImpl parse) (EncoderImpl parse) where
306+ second g = bimap id g
307+instance Monad parse => Bifunctor Either (EncoderImpl parse) (EncoderImpl parse) (EncoderImpl parse) where
308+ bimap f g = EncoderImpl
309+ { _encoderImpl_encode = bimap (_encoderImpl_encode f) (_encoderImpl_encode g)
310+ , _encoderImpl_decode = \case
311+ Left a -> Left <$> _encoderImpl_decode f a
312+ Right b -> Right <$> _encoderImpl_decode g b
313+ }
314+
315+instance (Monad parse, Applicative check) => QFunctor Either (Encoder check parse) (Encoder check parse) where
316+ second g = bimap id g
317+instance (Monad parse, Applicative check) => PFunctor Either (Encoder check parse) (Encoder check parse) where
318+ first f = bimap f id
319+instance (Monad parse, Applicative check) => Bifunctor Either (Encoder check parse) (Encoder check parse) (Encoder check parse) where
320+ bimap f g = Encoder $ liftA2 bimap (unEncoder f) (unEncoder g)
321+
322+instance (Applicative check, Monad parse) => Associative (Encoder check parse) Either where
323+ associate = isoEncoder (iso (associate @(->) @Either) disassociate)
324+ disassociate = isoEncoder (iso disassociate associate)
325+
326+instance (Monad parse, Applicative check) => Braided (Encoder check parse) Either where
327+ braid = isoEncoder (iso swap swap)
328+
329+
330+
259331instance (Traversable f, Monad check, Monad parse) => Cat.Functor f (Encoder check parse) (Encoder check parse) where
260332 fmap e = Encoder $ do
261333 ve <- unEncoder e
@@ -343,14 +415,14 @@ maybeEncoder f g = shadowEncoder f g . maybeToEitherEncoder
343415justEncoder :: (Applicative check, MonadError Text parse) => Encoder check parse a (Maybe a)
344416justEncoder = prismEncoder _Just
345417
346−-- |
418+-- | Encode () to 'Nothing'.
347419nothingEncoder :: (Applicative check, MonadError Text parse) => Encoder check parse () (Maybe a)
348420nothingEncoder = prismEncoder _Nothing
349421
350422someConstEncoder :: (Applicative check, Applicative parse) => Encoder check parse (Some (Const a)) a
351423someConstEncoder = unsafeMkEncoder $ EncoderImpl
352− { _encoderImpl_encode = \(Some.This (Const a)) -> a
353− , _encoderImpl_decode = pure . Some.This . Const
424+ { _encoderImpl_encode = \(Some (Const a)) -> a
425+ , _encoderImpl_decode = pure . Some . Const
354426 }
355427
356428-- | WARNING: This is only safe if the Show and Read instances for 'a' are
@@ -378,7 +450,7 @@ checkEnum1EncoderFunc
378450 -> check (EncoderFunc check' parse p r)
379451checkEnum1EncoderFunc f = do
380452 (encoderImpls :: DMap p (Flip (EncoderImpl parse) r)) <- DMap.fromList <$>
381− traverse (\(Some.This p) -> (p :=>) . Flip <$> unEncoder (f p)) universe
453+ traverse (\(Some p) -> (p :=>) . Flip <$> unEncoder (f p)) universe
382454 pure $ EncoderFunc $ \p -> unsafeMkEncoder . unFlip $
383455 DMap.findWithDefault (error "checkEnum1EncoderFunc: EncoderImpl not found (should be impossible)") p encoderImpls
384456
@@ -433,11 +505,11 @@ chainEncoder cons this rest = Encoder $ do
433505 pure $ EncoderImpl
434506 { _encoderImpl_decode = \v -> do
435507 (here, following) <- _encoderImpl_decode consValid v
436− Some.This r <- _encoderImpl_decode thisValid here
508+ Some r <- _encoderImpl_decode thisValid here
437509 (r :/) <$> _encoderImpl_decode (runIdentity . unEncoder $ rest r) following
438510 , _encoderImpl_encode = \(r :/ s) ->
439511 _encoderImpl_encode consValid
440− ( _encoderImpl_encode thisValid $ Some.This r
512+ ( _encoderImpl_encode thisValid $ Some r
441513 , _encoderImpl_encode (runIdentity . unEncoder $ rest r) s)
442514 }
443515
@@ -504,7 +576,7 @@ enum1Encoder
504576 , Show r
505577 )
506578 => (forall a. p a -> r) -> Encoder check parse (Some p) r
507−enum1Encoder f = enumEncoder $ \(Some.This p) -> f p
579+enum1Encoder f = enumEncoder $ \(Some p) -> f p
508580
509581-- | Encode an enumerable, bounded type. WARNING: Don't use this on types that
510582-- have a large number of values - it will use a lot of memory.
@@ -547,13 +619,10 @@ pathOnlyEncoderIgnoringQuery = unsafeMkEncoder $ EncoderImpl
547619 }
548620
549621pathOnlyEncoder :: (Applicative check, MonadError Text parse) => Encoder check parse [Text] PageName
550−pathOnlyEncoder = unsafeMkEncoder $ EncoderImpl
551− { _encoderImpl_decode = \(path, query) ->
552− if query == mempty
553− then pure path
554− else throwError "pathOnlyEncoderImpl: query was provided"
555− , _encoderImpl_encode = \path -> (path, mempty)
556− }
622+pathOnlyEncoder = second (unitEncoder mempty) . coidr
623+
624+queryOnlyEncoder :: (Applicative check, MonadError Text parse) => Encoder check parse (Map Text (Maybe Text)) PageName
625+queryOnlyEncoder = first (unitEncoder []) . coidl
557626
558627singletonListEncoder :: (Applicative check, MonadError Text parse) => Encoder check parse a [a]
559628singletonListEncoder = unsafeMkEncoder $ EncoderImpl
@@ -596,10 +665,10 @@ queryParametersTextEncoder = Encoder $ pure $ EncoderImpl
596665 in (urlDecodeText True k, urlDecodeText True <$> mv)
597666
598667urlEncodeText :: Bool -> Text -> Text
599−urlEncodeText q = decodeUtf8 . urlEncode q . encodeUtf8
668+urlEncodeText q = T.decodeUtf8 . urlEncode q . T.encodeUtf8
600669
601670urlDecodeText :: Bool -> Text -> Text
602−urlDecodeText q = decodeUtf8 . urlDecode q . encodeUtf8
671+urlDecodeText q = T.decodeUtf8 . urlDecode q . T.encodeUtf8
603672
604673listToNonEmptyEncoder :: (Applicative check, Applicative parse, Monoid a, Eq a) => Encoder check parse [a] (NonEmpty a)
605674listToNonEmptyEncoder = Encoder $ pure $ EncoderImpl
@@ -657,10 +726,47 @@ joinPairTextEncoder = Encoder . \case
657726 _ -> return (kt, T.drop (T.length separator) vt)
658727 }
659728
660−--TODO: Rewrite this by composing the given prism with a lens on the first element of the DSum
661−-- Or, more likely, the user can compose it themselves
662−rPrism :: forall f g. (forall a. Prism' (f a) (g a)) -> Prism' (R f) (R g)
663−rPrism p = prism (\(g :/ x) -> g ^. re p :/ x) (\(f :/ x) -> bimap (:/ x) (:/ x) $ matching p f)
729+-- This slight generalization of 'rPrism' happens to be enough to write all our
730+-- prism combinators so far.
731+dSumPrism
732+ :: forall f f' g
733+ . (forall a. Prism' (f a) (f' a))
734+ -> Prism' (DSum f g) (DSum f' g)
735+dSumPrism p = prism'
736+ (\(f' :=> x) -> f' ^. re p :=> x)
737+ (\(f :=> x) -> (:=> x) <$> (f ^? p))
738+
739+-- already in obelisk
740+rPrism
741+ :: forall f f'
742+ . (forall a. Prism' (f a) (f' a))
743+ -> Prism' (R f) (R f')
744+rPrism p = dSumPrism p
745+
746+dSumPrism'
747+ :: forall f g a
748+ . (forall b. Prism' (f b) (a :~: b))
749+ -> Prism' (DSum f g) (g a)
750+dSumPrism' p = dSumPrism p . iso (\(Refl :=> b) -> b) (Refl :=>)
751+
752+dSumGEqPrism
753+ :: GEq f
754+ => f a
755+ -> Prism' (DSum f g) (g a)
756+dSumGEqPrism variant = dSumPrism' $ prism' (\Refl -> variant) (\x -> geq variant x)
757+
758+-- | Given a 'tag :: f a', make a prism for 'R f'. This generalizes the usual
759+-- prisms for a sum type (the ones that 'mkPrisms' would make), just as 'R'
760+-- generalized a usual sum type.
761+--
762+-- [This is given the '_R' name of the "cannonical" prism not because it is the
763+-- most general, but because it seems the most useful for routes, and 'R' itself
764+-- trades generality for route-specificity.]
765+_R
766+ :: GEq f
767+ => f a
768+ -> Prism' (R f) a
769+_R variant = dSumGEqPrism variant . iso runIdentity Identity
664770
665771-- | An encoder that only works on the items available via the prism. An error will be thrown in the parse monad
666772-- if the prism doesn't match.
@@ -704,6 +810,45 @@ handleEncoder recover e = Encoder $ do
704810-- Actual obelisk route info
705811--------------------------------------------------------------------------------
706812
813+-- | The typical full route type comprising all of an Obelisk application's routes.
814+-- Parameterised by the top level GADTs that define backend and frontend routes, respectively.
815+data FullRoute :: (* -> *) -> (* -> *) -> * -> * where
816+ FullRoute_Backend :: br a -> FullRoute br fr a
817+ FullRoute_Frontend :: ObeliskRoute fr a -> FullRoute br fr a
818+
819+instance (GShow br, GShow fr) => GShow (FullRoute br fr) where
820+ gshowsPrec p = \case
821+ FullRoute_Backend x -> showParen (p > 10) (showString "FullRoute_Backend " . gshowsPrec 11 x)
822+ FullRoute_Frontend x -> showParen (p > 10) (showString "FullRoute_Frontend " . gshowsPrec 11 x)
823+
824+instance (GEq br, GEq fr) => GEq (FullRoute br fr) where
825+ geq (FullRoute_Backend x) (FullRoute_Backend y) = geq x y
826+ geq (FullRoute_Frontend x) (FullRoute_Frontend y) = geq x y
827+ geq _ _ = Nothing
828+
829+instance (GCompare br, GCompare fr) => GCompare (FullRoute br fr) where
830+ gcompare (FullRoute_Backend _) (FullRoute_Frontend _) = GLT
831+ gcompare (FullRoute_Frontend _) (FullRoute_Backend _) = GGT
832+ gcompare (FullRoute_Backend x) (FullRoute_Backend y) = gcompare x y
833+ gcompare (FullRoute_Frontend x) (FullRoute_Frontend y) = gcompare x y
834+
835+instance (UniverseSome br, UniverseSome fr) => UniverseSome (FullRoute br fr) where
836+ universeSome = [Some (FullRoute_Backend x) | Some x <- universeSome]
837+ ++ [Some (FullRoute_Frontend x) | Some x <- universeSome]
838+
839+-- | Build the typical top level application route encoder from a route for handling 404's,
840+-- and segment encoders for backend and frontend routes.
841+mkFullRouteEncoder
842+ :: (GCompare br, GCompare fr, GShow br, GShow fr, UniverseSome br, UniverseSome fr)
843+ => R (FullRoute br fr) -- ^ 404 handler
844+ -> (forall a. br a -> SegmentResult (Either Text) (Either Text) a) -- ^ How to encode a single backend route segment
845+ -> (forall a. fr a -> SegmentResult (Either Text) (Either Text) a) -- ^ How to encode a single frontend route segment
846+ -> Encoder (Either Text) Identity (R (FullRoute br fr)) PageName
847+mkFullRouteEncoder missing backendSegment frontendSegment = handleEncoder (const missing) $
848+ pathComponentEncoder $ \case
849+ FullRoute_Backend backendRoute -> backendSegment backendRoute
850+ FullRoute_Frontend obeliskRoute -> obeliskRouteSegment obeliskRoute frontendSegment
851+
707852-- | A type which can represent Obelisk-specific resource routes, in addition to application specific routes which serve your
708853-- frontend.
709854data ObeliskRoute :: (* -> *) -> * -> * where
@@ -711,9 +856,11 @@ data ObeliskRoute :: (* -> *) -> * -> * where
711856 ObeliskRoute_App :: f a -> ObeliskRoute f a
712857 ObeliskRoute_Resource :: ResourceRoute a -> ObeliskRoute f a
713858
714−instance Universe (Some f) => Universe (Some (ObeliskRoute f)) where
715− universe = fmap (\(Some.This x) -> Some.This (ObeliskRoute_App x)) universe
716− ++ fmap (\(Some.This x) -> Some.This (ObeliskRoute_Resource x)) universe
859+instance UniverseSome f => UniverseSome (ObeliskRoute f) where
860+ universeSome = concat
861+ [ (\(Some x) -> Some (ObeliskRoute_App x)) <$> universe
862+ , (\(Some x) -> Some (ObeliskRoute_Resource x)) <$> universe
863+ ]
717864
718865instance GEq f => GEq (ObeliskRoute f) where
719866 geq (ObeliskRoute_App x) (ObeliskRoute_App y) = geq x y
@@ -801,12 +948,12 @@ indexOnlyRouteEncoder = pathComponentEncoder indexOnlyRouteSegment
801948
802949someSumEncoder :: (Applicative check, Applicative parse) => Encoder check parse (Some (Sum a b)) (Either (Some a) (Some b))
803950someSumEncoder = Encoder $ pure $ EncoderImpl
804− { _encoderImpl_encode = \(Some.This t) -> case t of
805− InL l -> Left $ Some.This l
806− InR r -> Right $ Some.This r
951+ { _encoderImpl_encode = \(Some t) -> case t of
952+ InL l -> Left $ Some l
953+ InR r -> Right $ Some r
807954 , _encoderImpl_decode = pure . \case
808− Left (Some.This l) -> Some.This (InL l)
809− Right (Some.This r) -> Some.This (InR r)
955+ Left (Some l) -> Some (InL l)
956+ Right (Some r) -> Some (InR r)
810957 }
811958
812959data Void1 :: * -> * where {}
@@ -817,7 +964,7 @@ instance Universe (Some Void1) where
817964void1Encoder :: (Applicative check, MonadError Text parse) => Encoder check parse (Some Void1) a
818965void1Encoder = Encoder $ pure $ EncoderImpl
819966 { _encoderImpl_encode = \case
820− Some.This f -> case f of {}
967+ Some f -> case f of {}
821968 , _encoderImpl_decode = \_ -> throwError "void1Encoder: can't decode anything"
822969 }
823970
@@ -831,7 +978,7 @@ concat <$> mapM deriveRouteComponent
831978 ]
832979
833980makePrisms ''ObeliskRoute
834−
981+makePrisms ''FullRoute
835982deriveGEq ''Void1
836983deriveGCompare ''Void1
837984
@@ -839,44 +986,142 @@ deriveGCompare ''Void1
839986-- and query string). See 'checkEncoder' for how to produce a checked encoder.
840987renderBackendRoute
841988 :: forall br a.
842− Encoder Identity Identity (R (Sum br a)) PageName
989+ Encoder Identity Identity (R (FullRoute br a)) PageName
843990 -> R br
844991 -> Text
845−renderBackendRoute enc = renderObeliskRoute enc . hoistR InL
992+renderBackendRoute enc = renderObeliskRoute enc . hoistR FullRoute_Backend
846993
847994-- | Renders a frontend route with the supplied checked encoder
848995renderFrontendRoute
849996 :: forall a fr.
850− Encoder Identity Identity (R (Sum a (ObeliskRoute fr))) PageName
997+ Encoder Identity Identity (R (FullRoute a fr)) PageName
851998 -> R fr
852999 -> Text
853−renderFrontendRoute enc = renderObeliskRoute enc . hoistR (InR . ObeliskRoute_App)
1000+renderFrontendRoute enc = renderObeliskRoute enc . hoistR (FullRoute_Frontend . ObeliskRoute_App)
8541001
8551002-- | Renders a route of the form typically found in an Obelisk project
8561003renderObeliskRoute
8571004 :: forall a b.
858− Encoder Identity Identity (R (Sum a b)) PageName
859− -> R (Sum a b)
1005+ Encoder Identity Identity (R (FullRoute a b)) PageName
1006+ -> R (FullRoute a b)
8601007 -> Text
8611008renderObeliskRoute e r =
862− let enc :: Encoder Identity (Either Text) (R (Sum a b)) PathQuery
1009+ let enc :: Encoder Identity (Either Text) (R (FullRoute a b)) PathQuery
8631010 enc = (pageNameEncoder . hoistParse (pure . runIdentity) e)
8641011 in (T.pack . uncurry (<>)) $ encode enc r
8651012
8661013readShowEncoder :: (MonadError Text parse, Read a, Show a, Applicative check) => Encoder check parse a PageName
8671014readShowEncoder = singlePathSegmentEncoder . unsafeTshowEncoder
8681015
869−
8701016integralEncoder :: (MonadError Text parse, Applicative check, Integral a) => Encoder check parse a Integer
8711017integralEncoder = prismEncoder (Numeric.Lens.integral)
8721018
873−pathSegmentEncoder :: (MonadError Text parse, Applicative check) =>
874− Encoder check parse (Text, PageName) PageName
875−pathSegmentEncoder = unsafeMkEncoder EncoderImpl
876− { _encoderImpl_encode = \(x, (y, z)) -> (x:y, z)
877− , _encoderImpl_decode = \(xss, y) -> case xss of
878− [] -> throwError "not enough path segments"
879− (x:xs) -> pure (x, (xs, y))
880− }
1019+pathSegmentEncoder :: (MonadError Text parse, Applicative check, Cons as as a a) =>
1020+ Encoder check parse (a, (as, b)) (as, b)
1021+pathSegmentEncoder = first (prismEncoder _Cons) . disassociate
1022+
1023+newtype Decoder check parse b a = Decoder { toEncoder :: Encoder check parse a b }
1024+
1025+dmapEncoder :: forall check parse k k' v.
1026+ ( Monad check
1027+ , MonadError Text parse
1028+ , Universe (Some k')
1029+ , Ord k
1030+ , GCompare k'
1031+ , GShow k'
1032+ )
1033+ => Encoder check parse (Some k') k
1034+ -> (forall v'. k' v' -> Encoder check parse v' v)
1035+ -> Encoder check parse (DMap k' Identity) (Map k v)
1036+dmapEncoder keyEncoder' valueEncoderFor = unsafeEncoder $ do
1037+ keyEncoder :: Encoder Identity parse (Some k') k <- checkEncoder keyEncoder'
1038+ valueDecoders :: DMap k' (Decoder Identity parse v) <- fmap DMap.fromList . forM universe $ \(Some (k' :: k' t)) -> do
1039+ ve :: Encoder Identity parse t v <- checkEncoder (valueEncoderFor k')
1040+ return $ (k' :: k' t) :=> (Decoder ve :: Decoder Identity parse v t)
1041+ let keyError k = "dmapEncoder: key `" <> k <> "' was missing from the Universe instance for its type."
1042+ return $ EncoderImpl
1043+ { _encoderImpl_encode = \dm -> Map.fromList $ do
1044+ ((k' :: k' t) :=> Identity v') <- DMap.toList dm
1045+ return ( encode keyEncoder (Some k')
1046+ , encode (toEncoder (DMap.findWithDefault (error . keyError $ gshow k') k' valueDecoders)) v'
1047+ )
1048+ , _encoderImpl_decode = \m -> fmap DMap.fromList . forM (Map.toList m) $ \(k,v) -> do
1049+ Some (k' :: k' t) <- tryDecode keyEncoder k
1050+ case DMap.lookup k' valueDecoders of
1051+ Nothing -> throwError . T.pack . keyError $ gshow k'
1052+ Just (Decoder e) -> do
1053+ v' <- tryDecode e v
1054+ return (k' :=> Identity v')
1055+ }
1056+
1057+fieldMapEncoder :: forall check parse r.
1058+ ( Applicative check
1059+ , MonadError Text parse
1060+ , HasFields r
1061+ , Universe (Some (Field r))
1062+ , GShow (Field r)
1063+ , GCompare (Field r)
1064+ )
1065+ => Encoder check parse r (DMap (Field r) Identity)
1066+fieldMapEncoder = unsafeEncoder $ do
1067+ pure $ EncoderImpl
1068+ { _encoderImpl_encode = \r -> DMap.fromList [ f :=> Identity (indexField r f) | Some f <- universe ]
1069+ , _encoderImpl_decode = \dm -> tabulateFieldsA $ \f -> do
1070+ case DMap.lookup f dm of
1071+ Nothing -> throwError $ "fieldMapEncoder: Couldn't find key for `" <> T.pack (gshow f) <> "' in DMap."
1072+ Just (Identity v) -> return v
1073+ }
1074+
1075+-- this is in base 4.12 (GHC 8.6);
1076+newtype Ap f a = Ap {getAp :: f a}
1077+
1078+instance (Applicative f, Semigroup a) => Semigroup (Ap f a) where
1079+ Ap x <> Ap y = Ap (liftA2 (<>) x y)
1080+
1081+instance (Applicative f, Monoid a) => Monoid (Ap f a) where
1082+ mappend = (<>)
1083+ mempty = Ap (pure mempty)
1084+
1085+pathFieldEncoder :: forall a p check parse . (HasFields a, Monad check, MonadError Text parse, GCompare (Field a)) => (forall x. Field a x -> Encoder check parse x p) -> Encoder check parse (a, [p]) [p]
1086+pathFieldEncoder fieldEncoder = unsafeEncoder $ do
1087+ fieldEncoderPureMap :: DMap.DMap (Field a) (Decoder Identity parse p) <- getAp $ getConst $ tabulateFieldsA @a $ \f -> Const (Ap $ fmap (DMap.singleton f . Decoder) $ (checkEncoder @Identity) $ fieldEncoder f)
1088+ let fieldEncoderPure :: forall x. Field a x -> Encoder Identity parse x p
1089+ fieldEncoderPure f = toEncoder (DMap.findWithDefault (error "bad") f fieldEncoderPureMap)
1090+ pure $ EncoderImpl
1091+ { _encoderImpl_encode = \(x, rest) -> execWriter $ do
1092+ _ <- traverseWithField (\f x_i -> tell (pure $ encode (fieldEncoderPure f) x_i) *> pure x_i) x
1093+ tell rest
1094+ , _encoderImpl_decode = State.runStateT $ tabulateFieldsA $ \f -> State.get >>= \case
1095+ [] -> throwError $ T.pack "not enough path components"
1096+ p:ps -> do
1097+ State.put ps
1098+ lift $ tryDecode (fieldEncoderPure f) p
1099+ }
1100+
1101+-- | Use ToJSON/FromJSON to encode to Text. The correctness of this encoder is dependent on the encoding being injective and round-tripping correctly.
1102+jsonEncoder :: forall check parse r.
1103+ ( ToJSON r
1104+ , FromJSON r
1105+ , Applicative check
1106+ , MonadError Text parse
1107+ )
1108+ => Encoder check parse r Text
1109+jsonEncoder = unsafeEncoder $ do
1110+ pure $ EncoderImpl
1111+ { _encoderImpl_encode = \r -> T.decodeUtf8 . BSL.toStrict $ Aeson.encode r
1112+ , _encoderImpl_decode = \t -> case Aeson.eitherDecodeStrict $ T.encodeUtf8 t of
1113+ Left err -> throwError ("jsonEncoder: " <> T.pack err)
1114+ Right x -> return x
1115+ }
1116+
1117+-- Useful for app server integration.
1118+-- p must not start with slashes
1119+byteStringsToPageName :: BS.ByteString -> BS.ByteString -> PageName
1120+byteStringsToPageName p q =
1121+ let pageNameEncoder' :: Encoder Identity Identity PageName (String, String)
1122+ pageNameEncoder' = bimap
1123+ (unpackTextEncoder . pathSegmentsTextEncoder . listToNonEmptyEncoder)
1124+ (unpackTextEncoder . queryParametersTextEncoder . toListMapEncoder)
1125+ in decode pageNameEncoder' (T.unpack (T.decodeUtf8 p), T.unpack (T.decodeUtf8 q))
8811126
8821127--TODO: decodeURIComponent as appropriate