@@ -63,6 +63,7 @@ module Obelisk.Route
6363 , shadowEncoder
6464 , prismEncoder
6565 , rPrism
66+ , _R
6667 , obeliskRouteEncoder
6768 , obeliskRouteSegment
6869 , pageNameEncoder
@@ -95,6 +96,7 @@ module Obelisk.Route
9596 , Decoder(..)
9697 , dmapEncoder
9798 , fieldMapEncoder
99+ , pathFieldEncoder
98100 , jsonEncoder
99101 ) where
100102
@@ -106,8 +108,30 @@ import qualified Control.Categorical.Functor as Cat
106108import Control.Categorical.Bifunctor
107109import Control.Category.Associative
108110import Control.Category.Monoidal
109−import Control.Lens (Identity (..), Prism', makePrisms, itraverse, imap, prism, (^.), re, matching, (^?), _Just, _Nothing, Iso', from, view, Wrapped (..))
111+import Control.Category.Braided
112+import Control.Lens
113+ ( Identity (..)
114+ , (^.)
115+ , (^?)
116+ , _Just
117+ , _Nothing
118+ , Cons(..)
119+ , from
120+ , imap
121+ , iso
122+ , Iso'
123+ , itraverse
124+ , makePrisms
125+ , Prism'
126+ , prism'
127+ , re
128+ , view
129+ , Wrapped (..)
130+ )
110131import Control.Monad.Except
132+import Control.Monad.Writer (execWriter, tell)
133+import qualified Control.Monad.State.Strict as State
134+import Control.Monad.Trans (lift)
111135import qualified Data.ByteString.Lazy as BSL
112136import Data.Dependent.Sum (DSum (..))
113137import Data.Dependent.Map (DMap)
@@ -257,6 +281,10 @@ instance Monad parse => Bifunctor (,) (EncoderImpl parse) (EncoderImpl parse) (E
257281 , _encoderImpl_decode = \(a, b) -> liftA2 (,) (_encoderImpl_decode f a) (_encoderImpl_decode g b)
258282 }
259283
284+instance (Monad parse, Applicative check) => Braided (Encoder check parse) (,) where
285+ braid = isoEncoder (iso swap swap)
286+
287+
260288instance (Applicative check, Monad parse) => PFunctor (,) (Encoder check parse) (Encoder check parse) where
261289 first f = bimap f id
262290instance (Applicative check, Monad parse) => QFunctor (,) (Encoder check parse) (Encoder check parse) where
@@ -270,6 +298,34 @@ instance (Traversable f, Monad parse) => Cat.Functor f (EncoderImpl parse) (Enco
270298 , _encoderImpl_decode = traverse $ _encoderImpl_decode ve
271299 }
272300
301+instance Monad parse => PFunctor Either (EncoderImpl parse) (EncoderImpl parse) where
302+ first f = bimap f id
303+instance Monad parse => QFunctor Either (EncoderImpl parse) (EncoderImpl parse) where
304+ second g = bimap id g
305+instance Monad parse => Bifunctor Either (EncoderImpl parse) (EncoderImpl parse) (EncoderImpl parse) where
306+ bimap f g = EncoderImpl
307+ { _encoderImpl_encode = bimap (_encoderImpl_encode f) (_encoderImpl_encode g)
308+ , _encoderImpl_decode = \case
309+ Left a -> Left <$> _encoderImpl_decode f a
310+ Right b -> Right <$> _encoderImpl_decode g b
311+ }
312+
313+instance (Monad parse, Applicative check) => QFunctor Either (Encoder check parse) (Encoder check parse) where
314+ second g = bimap id g
315+instance (Monad parse, Applicative check) => PFunctor Either (Encoder check parse) (Encoder check parse) where
316+ first f = bimap f id
317+instance (Monad parse, Applicative check) => Bifunctor Either (Encoder check parse) (Encoder check parse) (Encoder check parse) where
318+ bimap f g = Encoder $ liftA2 bimap (unEncoder f) (unEncoder g)
319+
320+instance (Applicative check, Monad parse) => Associative (Encoder check parse) Either where
321+ associate = isoEncoder (iso (associate @(->) @Either) disassociate)
322+ disassociate = isoEncoder (iso disassociate associate)
323+
324+instance (Monad parse, Applicative check) => Braided (Encoder check parse) Either where
325+ braid = isoEncoder (iso swap swap)
326+
327+
328+
273329instance (Traversable f, Monad check, Monad parse) => Cat.Functor f (Encoder check parse) (Encoder check parse) where
274330 fmap e = Encoder $ do
275331 ve <- unEncoder e
@@ -668,10 +724,47 @@ joinPairTextEncoder = Encoder . \case
668724 _ -> return (kt, T.drop (T.length separator) vt)
669725 }
670726
671−--TODO: Rewrite this by composing the given prism with a lens on the first element of the DSum
672−-- Or, more likely, the user can compose it themselves
673−rPrism :: forall f g. (forall a. Prism' (f a) (g a)) -> Prism' (R f) (R g)
674−rPrism p = prism (\(g :/ x) -> g ^. re p :/ x) (\(f :/ x) -> bimap (:/ x) (:/ x) $ matching p f)
727+-- This slight generalization of 'rPrism' happens to be enough to write all our
728+-- prism combinators so far.
729+dSumPrism
730+ :: forall f f' g
731+ . (forall a. Prism' (f a) (f' a))
732+ -> Prism' (DSum f g) (DSum f' g)
733+dSumPrism p = prism'
734+ (\(f' :=> x) -> f' ^. re p :=> x)
735+ (\(f :=> x) -> (:=> x) <$> (f ^? p))
736+
737+-- already in obelisk
738+rPrism
739+ :: forall f f'
740+ . (forall a. Prism' (f a) (f' a))
741+ -> Prism' (R f) (R f')
742+rPrism p = dSumPrism p
743+
744+dSumPrism'
745+ :: forall f g a
746+ . (forall b. Prism' (f b) (a :~: b))
747+ -> Prism' (DSum f g) (g a)
748+dSumPrism' p = dSumPrism p . iso (\(Refl :=> b) -> b) (Refl :=>)
749+
750+dSumGEqPrism
751+ :: GEq f
752+ => f a
753+ -> Prism' (DSum f g) (g a)
754+dSumGEqPrism variant = dSumPrism' $ prism' (\Refl -> variant) (\x -> geq variant x)
755+
756+-- | Given a 'tag :: f a', make a prism for 'R f'. This generalizes the usual
757+-- prisms for a sum type (the ones that 'mkPrisms' would make), just as 'R'
758+-- generalized a usual sum type.
759+--
760+-- [This is given the '_R' name of the "cannonical" prism not because it is the
761+-- most general, but because it seems the most useful for routes, and 'R' itself
762+-- trades generality for route-specificity.]
763+_R
764+ :: GEq f
765+ => f a
766+ -> Prism' (R f) a
767+_R variant = dSumGEqPrism variant . iso runIdentity Identity
675768
676769-- | An encoder that only works on the items available via the prism. An error will be thrown in the parse monad
677770-- if the prism doesn't match.
@@ -921,14 +1014,9 @@ readShowEncoder = singlePathSegmentEncoder . unsafeTshowEncoder
9211014integralEncoder :: (MonadError Text parse, Applicative check, Integral a) => Encoder check parse a Integer
9221015integralEncoder = prismEncoder (Numeric.Lens.integral)
9231016
924−pathSegmentEncoder :: (MonadError Text parse, Applicative check) =>
925− Encoder check parse (Text, PageName) PageName
926−pathSegmentEncoder = unsafeMkEncoder EncoderImpl
927− { _encoderImpl_encode = \(x, (y, z)) -> (x:y, z)
928− , _encoderImpl_decode = \(xss, y) -> case xss of
929− [] -> throwError "not enough path segments"
930− (x:xs) -> pure (x, (xs, y))
931− }
1017+pathSegmentEncoder :: (MonadError Text parse, Applicative check, Cons as as a a) =>
1018+ Encoder check parse (a, (as, b)) (as, b)
1019+pathSegmentEncoder = first (prismEncoder _Cons) . disassociate
9321020
9331021newtype Decoder check parse b a = Decoder { toEncoder :: Encoder check parse a b }
9341022
@@ -982,6 +1070,32 @@ fieldMapEncoder = unsafeEncoder $ do
9821070 Just (Identity v) -> return v
9831071 }
9841072
1073+-- this is in base 4.12 (GHC 8.6);
1074+newtype Ap f a = Ap {getAp :: f a}
1075+
1076+instance (Applicative f, Semigroup a) => Semigroup (Ap f a) where
1077+ Ap x <> Ap y = Ap (liftA2 (<>) x y)
1078+
1079+instance (Applicative f, Monoid a) => Monoid (Ap f a) where
1080+ mappend = (<>)
1081+ mempty = Ap (pure mempty)
1082+
1083+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]
1084+pathFieldEncoder fieldEncoder = unsafeEncoder $ do
1085+ 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)
1086+ let fieldEncoderPure :: forall x. Field a x -> Encoder Identity parse x p
1087+ fieldEncoderPure f = toEncoder (DMap.findWithDefault (error "bad") f fieldEncoderPureMap)
1088+ pure $ EncoderImpl
1089+ { _encoderImpl_encode = \(x, rest) -> execWriter $ do
1090+ _ <- traverseWithField (\f x_i -> tell (pure $ encode (fieldEncoderPure f) x_i) *> pure x_i) x
1091+ tell rest
1092+ , _encoderImpl_decode = State.runStateT $ tabulateFieldsA $ \f -> State.get >>= \case
1093+ [] -> throwError $ T.pack "not enough path components"
1094+ p:ps -> do
1095+ State.put ps
1096+ lift $ tryDecode (fieldEncoderPure f) p
1097+ }
1098+
9851099-- | Use ToJSON/FromJSON to encode to Text. The correctness of this encoder is dependent on the encoding being injective and round-tripping correctly.
9861100jsonEncoder :: forall check parse r.
9871101 ( ToJSON r