@@ -12,13 +12,16 @@
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 #-}
1921module Obelisk.Route
2022 ( R
2123 , pattern (:/)
24+ , hoistR
2225 , PageName
2326 , PathQuery
2427 , Encoder
@@ -60,10 +63,15 @@ module Obelisk.Route
6063 , shadowEncoder
6164 , prismEncoder
6265 , rPrism
66+ , _R
6367 , obeliskRouteEncoder
6468 , obeliskRouteSegment
6569 , pageNameEncoder
6670 , handleEncoder
71+ , FullRoute (..)
72+ , _FullRoute_Frontend
73+ , _FullRoute_Backend
74+ , mkFullRouteEncoder
6775 , ObeliskRoute (..)
6876 , _ObeliskRoute_App
6977 , _ObeliskRoute_Resource
@@ -78,6 +86,19 @@ module Obelisk.Route
7886 , void1Encoder
7987 , pathSegmentsTextEncoder
8088 , queryParametersTextEncoder
89+ , renderObeliskRoute
90+ , renderBackendRoute
91+ , renderFrontendRoute
92+ , readShowEncoder
93+ , integralEncoder
94+ , pathSegmentEncoder
95+ , queryOnlyEncoder
96+ , Decoder(..)
97+ , dmapEncoder
98+ , fieldMapEncoder
99+ , pathFieldEncoder
100+ , jsonEncoder
101+ , byteStringsToPageName
81102 ) where
82103
83104import Prelude hiding ((.), id)
@@ -88,8 +109,32 @@ import qualified Control.Categorical.Functor as Cat
88109import Control.Categorical.Bifunctor
89110import Control.Category.Associative
90111import Control.Category.Monoidal
91−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+ )
92132import 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
93138import Data.Dependent.Sum (DSum (..))
94139import Data.Dependent.Map (DMap)
95140import qualified Data.Dependent.Map as DMap
@@ -106,16 +151,19 @@ import Data.Maybe
106151import Data.Monoid ((<>))
107152import Data.Set (Set)
108153import qualified Data.Set as Set
109−import Data.Some (Some)
110−import qualified Data.Some as Some
111−import Data.Some.Universe.Orphans ()
154+import Data.Some (Some(Some))
112155import Data.Text (Text)
113156import qualified Data.Text as T
114−import Data.Text.Encoding
157+import qualified Data.Text.Encoding as T
115158import Data.Universe
159+import Data.Universe.Some
116160import Network.HTTP.Types.URI
161+import qualified Numeric.Lens
117162import Obelisk.Route.TH
118163import Text.Read (readMaybe)
164+import Data.Tabulation
165+import qualified Data.Aeson as Aeson
166+import Data.Aeson (FromJSON, ToJSON)
119167
120168-- Design goals:
121169-- No start-up time on the frontend (not yet met)
@@ -141,13 +189,16 @@ import Text.Read (readMaybe)
141189
142190type R f = DSum f Identity --TODO: Better name
143191
144−--TODO: COMPLETE pragma
192+{-# COMPLETE (:/) #-}
145193infixr 5 :/
146194pattern (:/) :: f a -> a -> R f
147195pattern a :/ b = a :=> Identity b
148196
149197mapSome :: (forall a. f a -> g a) -> Some f -> Some g
150−mapSome f (Some.This a) = Some.This $ f a
198+mapSome f (Some a) = Some $ f a
199+
200+hoistR :: (forall x. f x -> g x) -> R f -> R g
201+hoistR f (x :=> Identity y) = f x :/ y
151202
152203--------------------------------------------------------------------------------
153204-- Encoder fundamentals
@@ -182,7 +233,7 @@ decode e x = runIdentity (tryDecode e x)
182233tryDecode :: Encoder Identity parse decoded encoded -> encoded -> parse decoded
183234tryDecode (Encoder (Identity impl)) x = _encoderImpl_decode impl x
184235
185−-- | Similar to 'decode' above, once an encoder has been checked so that its check monad is Identity, it
236+-- | Similar to 'decode', once an encoder has been checked so that its check monad is Identity, it
186237-- can be used to actually encode by using this. Note that while there's no constraint on the parse monad here,
187238-- one should usually be applying decode and encode to the same 'Encoder'
188239encode :: Encoder Identity parse decoded encoded -> decoded -> encoded
@@ -232,6 +283,10 @@ instance Monad parse => Bifunctor (,) (EncoderImpl parse) (EncoderImpl parse) (E
232283 , _encoderImpl_decode = \(a, b) -> liftA2 (,) (_encoderImpl_decode f a) (_encoderImpl_decode g b)
233284 }
234285
286+instance (Monad parse, Applicative check) => Braided (Encoder check parse) (,) where
287+ braid = isoEncoder (iso swap swap)
288+
289+
235290instance (Applicative check, Monad parse) => PFunctor (,) (Encoder check parse) (Encoder check parse) where
236291 first f = bimap f id
237292instance (Applicative check, Monad parse) => QFunctor (,) (Encoder check parse) (Encoder check parse) where
@@ -245,6 +300,34 @@ instance (Traversable f, Monad parse) => Cat.Functor f (EncoderImpl parse) (Enco
245300 , _encoderImpl_decode = traverse $ _encoderImpl_decode ve
246301 }
247302
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+
248331instance (Traversable f, Monad check, Monad parse) => Cat.Functor f (Encoder check parse) (Encoder check parse) where
249332 fmap e = Encoder $ do
250333 ve <- unEncoder e
@@ -332,14 +415,14 @@ maybeEncoder f g = shadowEncoder f g . maybeToEitherEncoder
332415justEncoder :: (Applicative check, MonadError Text parse) => Encoder check parse a (Maybe a)
333416justEncoder = prismEncoder _Just
334417
335−-- |
418+-- | Encode () to 'Nothing'.
336419nothingEncoder :: (Applicative check, MonadError Text parse) => Encoder check parse () (Maybe a)
337420nothingEncoder = prismEncoder _Nothing
338421
339422someConstEncoder :: (Applicative check, Applicative parse) => Encoder check parse (Some (Const a)) a
340423someConstEncoder = unsafeMkEncoder $ EncoderImpl
341− { _encoderImpl_encode = \(Some.This (Const a)) -> a
342− , _encoderImpl_decode = pure . Some.This . Const
424+ { _encoderImpl_encode = \(Some (Const a)) -> a
425+ , _encoderImpl_decode = pure . Some . Const
343426 }
344427
345428-- | WARNING: This is only safe if the Show and Read instances for 'a' are
@@ -367,7 +450,7 @@ checkEnum1EncoderFunc
367450 -> check (EncoderFunc check' parse p r)
368451checkEnum1EncoderFunc f = do
369452 (encoderImpls :: DMap p (Flip (EncoderImpl parse) r)) <- DMap.fromList <$>
370− traverse (\(Some.This p) -> (p :=>) . Flip <$> unEncoder (f p)) universe
453+ traverse (\(Some p) -> (p :=>) . Flip <$> unEncoder (f p)) universe
371454 pure $ EncoderFunc $ \p -> unsafeMkEncoder . unFlip $
372455 DMap.findWithDefault (error "checkEnum1EncoderFunc: EncoderImpl not found (should be impossible)") p encoderImpls
373456
@@ -422,11 +505,12 @@ chainEncoder cons this rest = Encoder $ do
422505 pure $ EncoderImpl
423506 { _encoderImpl_decode = \v -> do
424507 (here, following) <- _encoderImpl_decode consValid v
425− Some.This r <- _encoderImpl_decode thisValid here
426− (r :/) <$> _encoderImpl_decode (runIdentity . unEncoder $ rest r) following
508+ _encoderImpl_decode thisValid here >>= \case
509+ Some r ->
510+ (r :/) <$> _encoderImpl_decode (runIdentity . unEncoder $ rest r) following
427511 , _encoderImpl_encode = \(r :/ s) ->
428512 _encoderImpl_encode consValid
429− ( _encoderImpl_encode thisValid $ Some.This r
513+ ( _encoderImpl_encode thisValid $ Some r
430514 , _encoderImpl_encode (runIdentity . unEncoder $ rest r) s)
431515 }
432516
@@ -493,7 +577,7 @@ enum1Encoder
493577 , Show r
494578 )
495579 => (forall a. p a -> r) -> Encoder check parse (Some p) r
496−enum1Encoder f = enumEncoder $ \(Some.This p) -> f p
580+enum1Encoder f = enumEncoder $ \(Some p) -> f p
497581
498582-- | Encode an enumerable, bounded type. WARNING: Don't use this on types that
499583-- have a large number of values - it will use a lot of memory.
@@ -536,13 +620,10 @@ pathOnlyEncoderIgnoringQuery = unsafeMkEncoder $ EncoderImpl
536620 }
537621
538622pathOnlyEncoder :: (Applicative check, MonadError Text parse) => Encoder check parse [Text] PageName
539−pathOnlyEncoder = unsafeMkEncoder $ EncoderImpl
540− { _encoderImpl_decode = \(path, query) ->
541− if query == mempty
542− then pure path
543− else throwError "pathOnlyEncoderImpl: query was provided"
544− , _encoderImpl_encode = \path -> (path, mempty)
545− }
623+pathOnlyEncoder = second (unitEncoder mempty) . coidr
624+
625+queryOnlyEncoder :: (Applicative check, MonadError Text parse) => Encoder check parse (Map Text (Maybe Text)) PageName
626+queryOnlyEncoder = first (unitEncoder []) . coidl
546627
547628singletonListEncoder :: (Applicative check, MonadError Text parse) => Encoder check parse a [a]
548629singletonListEncoder = unsafeMkEncoder $ EncoderImpl
@@ -585,10 +666,10 @@ queryParametersTextEncoder = Encoder $ pure $ EncoderImpl
585666 in (urlDecodeText True k, urlDecodeText True <$> mv)
586667
587668urlEncodeText :: Bool -> Text -> Text
588−urlEncodeText q = decodeUtf8 . urlEncode q . encodeUtf8
669+urlEncodeText q = T.decodeUtf8 . urlEncode q . T.encodeUtf8
589670
590671urlDecodeText :: Bool -> Text -> Text
591−urlDecodeText q = decodeUtf8 . urlDecode q . encodeUtf8
672+urlDecodeText q = T.decodeUtf8 . urlDecode q . T.encodeUtf8
592673
593674listToNonEmptyEncoder :: (Applicative check, Applicative parse, Monoid a, Eq a) => Encoder check parse [a] (NonEmpty a)
594675listToNonEmptyEncoder = Encoder $ pure $ EncoderImpl
@@ -646,10 +727,47 @@ joinPairTextEncoder = Encoder . \case
646727 _ -> return (kt, T.drop (T.length separator) vt)
647728 }
648729
649−--TODO: Rewrite this by composing the given prism with a lens on the first element of the DSum
650−-- Or, more likely, the user can compose it themselves
651−rPrism :: forall f g. (forall a. Prism' (f a) (g a)) -> Prism' (R f) (R g)
652−rPrism p = prism (\(g :/ x) -> g ^. re p :/ x) (\(f :/ x) -> bimap (:/ x) (:/ x) $ matching p f)
730+-- This slight generalization of 'rPrism' happens to be enough to write all our
731+-- prism combinators so far.
732+dSumPrism
733+ :: forall f f' g
734+ . (forall a. Prism' (f a) (f' a))
735+ -> Prism' (DSum f g) (DSum f' g)
736+dSumPrism p = prism'
737+ (\(f' :=> x) -> f' ^. re p :=> x)
738+ (\(f :=> x) -> (:=> x) <$> (f ^? p))
739+
740+-- already in obelisk
741+rPrism
742+ :: forall f f'
743+ . (forall a. Prism' (f a) (f' a))
744+ -> Prism' (R f) (R f')
745+rPrism p = dSumPrism p
746+
747+dSumPrism'
748+ :: forall f g a
749+ . (forall b. Prism' (f b) (a :~: b))
750+ -> Prism' (DSum f g) (g a)
751+dSumPrism' p = dSumPrism p . iso (\(Refl :=> b) -> b) (Refl :=>)
752+
753+dSumGEqPrism
754+ :: GEq f
755+ => f a
756+ -> Prism' (DSum f g) (g a)
757+dSumGEqPrism variant = dSumPrism' $ prism' (\Refl -> variant) (\x -> geq variant x)
758+
759+-- | Given a 'tag :: f a', make a prism for 'R f'. This generalizes the usual
760+-- prisms for a sum type (the ones that 'mkPrisms' would make), just as 'R'
761+-- generalized a usual sum type.
762+--
763+-- [This is given the '_R' name of the "cannonical" prism not because it is the
764+-- most general, but because it seems the most useful for routes, and 'R' itself
765+-- trades generality for route-specificity.]
766+_R
767+ :: GEq f
768+ => f a
769+ -> Prism' (R f) a
770+_R variant = dSumGEqPrism variant . iso runIdentity Identity
653771
654772-- | An encoder that only works on the items available via the prism. An error will be thrown in the parse monad
655773-- if the prism doesn't match.
@@ -693,6 +811,45 @@ handleEncoder recover e = Encoder $ do
693811-- Actual obelisk route info
694812--------------------------------------------------------------------------------
695813
814+-- | The typical full route type comprising all of an Obelisk application's routes.
815+-- Parameterised by the top level GADTs that define backend and frontend routes, respectively.
816+data FullRoute :: (* -> *) -> (* -> *) -> * -> * where
817+ FullRoute_Backend :: br a -> FullRoute br fr a
818+ FullRoute_Frontend :: ObeliskRoute fr a -> FullRoute br fr a
819+
820+instance (GShow br, GShow fr) => GShow (FullRoute br fr) where
821+ gshowsPrec p = \case
822+ FullRoute_Backend x -> showParen (p > 10) (showString "FullRoute_Backend " . gshowsPrec 11 x)
823+ FullRoute_Frontend x -> showParen (p > 10) (showString "FullRoute_Frontend " . gshowsPrec 11 x)
824+
825+instance (GEq br, GEq fr) => GEq (FullRoute br fr) where
826+ geq (FullRoute_Backend x) (FullRoute_Backend y) = geq x y
827+ geq (FullRoute_Frontend x) (FullRoute_Frontend y) = geq x y
828+ geq _ _ = Nothing
829+
830+instance (GCompare br, GCompare fr) => GCompare (FullRoute br fr) where
831+ gcompare (FullRoute_Backend _) (FullRoute_Frontend _) = GLT
832+ gcompare (FullRoute_Frontend _) (FullRoute_Backend _) = GGT
833+ gcompare (FullRoute_Backend x) (FullRoute_Backend y) = gcompare x y
834+ gcompare (FullRoute_Frontend x) (FullRoute_Frontend y) = gcompare x y
835+
836+instance (UniverseSome br, UniverseSome fr) => UniverseSome (FullRoute br fr) where
837+ universeSome = [Some (FullRoute_Backend x) | Some x <- universeSome]
838+ ++ [Some (FullRoute_Frontend x) | Some x <- universeSome]
839+
840+-- | Build the typical top level application route encoder from a route for handling 404's,
841+-- and segment encoders for backend and frontend routes.
842+mkFullRouteEncoder
843+ :: (GCompare br, GCompare fr, GShow br, GShow fr, UniverseSome br, UniverseSome fr)
844+ => R (FullRoute br fr) -- ^ 404 handler
845+ -> (forall a. br a -> SegmentResult (Either Text) (Either Text) a) -- ^ How to encode a single backend route segment
846+ -> (forall a. fr a -> SegmentResult (Either Text) (Either Text) a) -- ^ How to encode a single frontend route segment
847+ -> Encoder (Either Text) Identity (R (FullRoute br fr)) PageName
848+mkFullRouteEncoder missing backendSegment frontendSegment = handleEncoder (const missing) $
849+ pathComponentEncoder $ \case
850+ FullRoute_Backend backendRoute -> backendSegment backendRoute
851+ FullRoute_Frontend obeliskRoute -> obeliskRouteSegment obeliskRoute frontendSegment
852+
696853-- | A type which can represent Obelisk-specific resource routes, in addition to application specific routes which serve your
697854-- frontend.
698855data ObeliskRoute :: (* -> *) -> * -> * where
@@ -700,9 +857,11 @@ data ObeliskRoute :: (* -> *) -> * -> * where
700857 ObeliskRoute_App :: f a -> ObeliskRoute f a
701858 ObeliskRoute_Resource :: ResourceRoute a -> ObeliskRoute f a
702859
703−instance Universe (Some f) => Universe (Some (ObeliskRoute f)) where
704− universe = fmap (\(Some.This x) -> Some.This (ObeliskRoute_App x)) universe
705− ++ fmap (\(Some.This x) -> Some.This (ObeliskRoute_Resource x)) universe
860+instance UniverseSome f => UniverseSome (ObeliskRoute f) where
861+ universeSome = concat
862+ [ (\(Some x) -> Some (ObeliskRoute_App x)) <$> universe
863+ , (\(Some x) -> Some (ObeliskRoute_Resource x)) <$> universe
864+ ]
706865
707866instance GEq f => GEq (ObeliskRoute f) where
708867 geq (ObeliskRoute_App x) (ObeliskRoute_App y) = geq x y
@@ -790,12 +949,12 @@ indexOnlyRouteEncoder = pathComponentEncoder indexOnlyRouteSegment
790949
791950someSumEncoder :: (Applicative check, Applicative parse) => Encoder check parse (Some (Sum a b)) (Either (Some a) (Some b))
792951someSumEncoder = Encoder $ pure $ EncoderImpl
793− { _encoderImpl_encode = \(Some.This t) -> case t of
794− InL l -> Left $ Some.This l
795− InR r -> Right $ Some.This r
952+ { _encoderImpl_encode = \(Some t) -> case t of
953+ InL l -> Left $ Some l
954+ InR r -> Right $ Some r
796955 , _encoderImpl_decode = pure . \case
797− Left (Some.This l) -> Some.This (InL l)
798− Right (Some.This r) -> Some.This (InR r)
956+ Left (Some l) -> Some (InL l)
957+ Right (Some r) -> Some (InR r)
799958 }
800959
801960data Void1 :: * -> * where {}
@@ -806,7 +965,7 @@ instance Universe (Some Void1) where
806965void1Encoder :: (Applicative check, MonadError Text parse) => Encoder check parse (Some Void1) a
807966void1Encoder = Encoder $ pure $ EncoderImpl
808967 { _encoderImpl_encode = \case
809− Some.This f -> case f of {}
968+ Some f -> case f of {}
810969 , _encoderImpl_decode = \_ -> throwError "void1Encoder: can't decode anything"
811970 }
812971
@@ -820,8 +979,150 @@ concat <$> mapM deriveRouteComponent
820979 ]
821980
822981makePrisms ''ObeliskRoute
823−
982+makePrisms ''FullRoute
824983deriveGEq ''Void1
825984deriveGCompare ''Void1
826985
986+-- | Given a backend route and a checked route encoder, render the route (path
987+-- and query string). See 'checkEncoder' for how to produce a checked encoder.
988+renderBackendRoute
989+ :: forall br a.
990+ Encoder Identity Identity (R (FullRoute br a)) PageName
991+ -> R br
992+ -> Text
993+renderBackendRoute enc = renderObeliskRoute enc . hoistR FullRoute_Backend
994+
995+-- | Renders a frontend route with the supplied checked encoder
996+renderFrontendRoute
997+ :: forall a fr.
998+ Encoder Identity Identity (R (FullRoute a fr)) PageName
999+ -> R fr
1000+ -> Text
1001+renderFrontendRoute enc = renderObeliskRoute enc . hoistR (FullRoute_Frontend . ObeliskRoute_App)
1002+
1003+-- | Renders a route of the form typically found in an Obelisk project
1004+renderObeliskRoute
1005+ :: forall a b.
1006+ Encoder Identity Identity (R (FullRoute a b)) PageName
1007+ -> R (FullRoute a b)
1008+ -> Text
1009+renderObeliskRoute e r =
1010+ let enc :: Encoder Identity (Either Text) (R (FullRoute a b)) PathQuery
1011+ enc = (pageNameEncoder . hoistParse (pure . runIdentity) e)
1012+ in (T.pack . uncurry (<>)) $ encode enc r
1013+
1014+readShowEncoder :: (MonadError Text parse, Read a, Show a, Applicative check) => Encoder check parse a PageName
1015+readShowEncoder = singlePathSegmentEncoder . unsafeTshowEncoder
1016+
1017+integralEncoder :: (MonadError Text parse, Applicative check, Integral a) => Encoder check parse a Integer
1018+integralEncoder = prismEncoder (Numeric.Lens.integral)
1019+
1020+pathSegmentEncoder :: (MonadError Text parse, Applicative check, Cons as as a a) =>
1021+ Encoder check parse (a, (as, b)) (as, b)
1022+pathSegmentEncoder = first (prismEncoder _Cons) . disassociate
1023+
1024+newtype Decoder check parse b a = Decoder { toEncoder :: Encoder check parse a b }
1025+
1026+dmapEncoder :: forall check parse k k' v.
1027+ ( Monad check
1028+ , MonadError Text parse
1029+ , Universe (Some k')
1030+ , Ord k
1031+ , GCompare k'
1032+ , GShow k'
1033+ )
1034+ => Encoder check parse (Some k') k
1035+ -> (forall v'. k' v' -> Encoder check parse v' v)
1036+ -> Encoder check parse (DMap k' Identity) (Map k v)
1037+dmapEncoder keyEncoder' valueEncoderFor = unsafeEncoder $ do
1038+ keyEncoder :: Encoder Identity parse (Some k') k <- checkEncoder keyEncoder'
1039+ valueDecoders :: DMap k' (Decoder Identity parse v) <- fmap DMap.fromList . forM universe $ \(Some (k' :: k' t)) -> do
1040+ ve :: Encoder Identity parse t v <- checkEncoder (valueEncoderFor k')
1041+ return $ (k' :: k' t) :=> (Decoder ve :: Decoder Identity parse v t)
1042+ let keyError k = "dmapEncoder: key `" <> k <> "' was missing from the Universe instance for its type."
1043+ return $ EncoderImpl
1044+ { _encoderImpl_encode = \dm -> Map.fromList $ do
1045+ ((k' :: k' t) :=> Identity v') <- DMap.toList dm
1046+ return ( encode keyEncoder (Some k')
1047+ , encode (toEncoder (DMap.findWithDefault (error . keyError $ gshow k') k' valueDecoders)) v'
1048+ )
1049+ , _encoderImpl_decode = \m -> fmap DMap.fromList . forM (Map.toList m) $ \(k,v) -> do
1050+ tryDecode keyEncoder k >>= \case
1051+ Some (k' :: k' t) -> case DMap.lookup k' valueDecoders of
1052+ Nothing -> throwError . T.pack . keyError $ gshow k'
1053+ Just (Decoder e) -> do
1054+ v' <- tryDecode e v
1055+ return (k' :=> Identity v')
1056+ }
1057+
1058+fieldMapEncoder :: forall check parse r.
1059+ ( Applicative check
1060+ , MonadError Text parse
1061+ , HasFields r
1062+ , Universe (Some (Field r))
1063+ , GShow (Field r)
1064+ , GCompare (Field r)
1065+ )
1066+ => Encoder check parse r (DMap (Field r) Identity)
1067+fieldMapEncoder = unsafeEncoder $ do
1068+ pure $ EncoderImpl
1069+ { _encoderImpl_encode = \r -> DMap.fromList [ f :=> Identity (indexField r f) | Some f <- universe ]
1070+ , _encoderImpl_decode = \dm -> tabulateFieldsA $ \f -> do
1071+ case DMap.lookup f dm of
1072+ Nothing -> throwError $ "fieldMapEncoder: Couldn't find key for `" <> T.pack (gshow f) <> "' in DMap."
1073+ Just (Identity v) -> return v
1074+ }
1075+
1076+-- this is in base 4.12 (GHC 8.6);
1077+newtype Ap f a = Ap {getAp :: f a}
1078+
1079+instance (Applicative f, Semigroup a) => Semigroup (Ap f a) where
1080+ Ap x <> Ap y = Ap (liftA2 (<>) x y)
1081+
1082+instance (Applicative f, Monoid a) => Monoid (Ap f a) where
1083+ mappend = (<>)
1084+ mempty = Ap (pure mempty)
1085+
1086+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]
1087+pathFieldEncoder fieldEncoder = unsafeEncoder $ do
1088+ 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)
1089+ let fieldEncoderPure :: forall x. Field a x -> Encoder Identity parse x p
1090+ fieldEncoderPure f = toEncoder (DMap.findWithDefault (error "bad") f fieldEncoderPureMap)
1091+ pure $ EncoderImpl
1092+ { _encoderImpl_encode = \(x, rest) -> execWriter $ do
1093+ _ <- traverseWithField (\f x_i -> tell (pure $ encode (fieldEncoderPure f) x_i) *> pure x_i) x
1094+ tell rest
1095+ , _encoderImpl_decode = State.runStateT $ tabulateFieldsA $ \f -> State.get >>= \case
1096+ [] -> throwError $ T.pack "not enough path components"
1097+ p:ps -> do
1098+ State.put ps
1099+ lift $ tryDecode (fieldEncoderPure f) p
1100+ }
1101+
1102+-- | Use ToJSON/FromJSON to encode to Text. The correctness of this encoder is dependent on the encoding being injective and round-tripping correctly.
1103+jsonEncoder :: forall check parse r.
1104+ ( ToJSON r
1105+ , FromJSON r
1106+ , Applicative check
1107+ , MonadError Text parse
1108+ )
1109+ => Encoder check parse r Text
1110+jsonEncoder = unsafeEncoder $ do
1111+ pure $ EncoderImpl
1112+ { _encoderImpl_encode = \r -> T.decodeUtf8 . BSL.toStrict $ Aeson.encode r
1113+ , _encoderImpl_decode = \t -> case Aeson.eitherDecodeStrict $ T.encodeUtf8 t of
1114+ Left err -> throwError ("jsonEncoder: " <> T.pack err)
1115+ Right x -> return x
1116+ }
1117+
1118+-- Useful for app server integration.
1119+-- p must not start with slashes
1120+byteStringsToPageName :: BS.ByteString -> BS.ByteString -> PageName
1121+byteStringsToPageName p q =
1122+ let pageNameEncoder' :: Encoder Identity Identity PageName (String, String)
1123+ pageNameEncoder' = bimap
1124+ (unpackTextEncoder . pathSegmentsTextEncoder . listToNonEmptyEncoder)
1125+ (unpackTextEncoder . queryParametersTextEncoder . toListMapEncoder)
1126+ in decode pageNameEncoder' (T.unpack (T.decodeUtf8 p), T.unpack (T.decodeUtf8 q))
1127+
8271128--TODO: decodeURIComponent as appropriate