@@ -91,6 +91,7 @@ module Obelisk.Route
9191 , Decoder(..)
9292 , dmapEncoder
9393 , fieldMapEncoder
94+ , pathFieldEncoder
9495 , jsonEncoder
9596 , byteStringsToPageName
9697 ) where
@@ -103,6 +104,7 @@ import qualified Control.Categorical.Functor as Cat
103104import Control.Categorical.Bifunctor
104105import Control.Category.Associative
105106import Control.Category.Monoidal
107+import Control.Category.Braided
106108import Control.Lens
107109 ( Identity (..)
108110 , (^.)
@@ -120,8 +122,12 @@ import Control.Lens
120122 , prism'
121123 , re
122124 , view
125+ , Cons(..)
123126 )
124127import Control.Monad.Except
128+import Control.Monad.Writer.CPS (execWriter, tell)
129+import qualified Control.Monad.State.Strict as State
130+import Control.Monad.Trans (lift)
125131import qualified Data.ByteString as BS
126132import qualified Data.ByteString.Lazy as BSL
127133import Data.Dependent.Sum (DSum (..))
@@ -273,6 +279,10 @@ instance Monad parse => Bifunctor (,) (EncoderImpl parse) (EncoderImpl parse) (E
273279 , _encoderImpl_decode = \(a, b) -> liftA2 (,) (_encoderImpl_decode f a) (_encoderImpl_decode g b)
274280 }
275281
282+instance (Monad parse, Applicative check) => Braided (Encoder check parse) (,) where
283+ braid = isoEncoder (iso swap swap)
284+
285+
276286instance (Applicative check, Monad parse) => PFunctor (,) (Encoder check parse) (Encoder check parse) where
277287 first f = bimap f id
278288instance (Applicative check, Monad parse) => QFunctor (,) (Encoder check parse) (Encoder check parse) where
@@ -286,6 +296,34 @@ instance (Traversable f, Monad parse) => Cat.Functor f (EncoderImpl parse) (Enco
286296 , _encoderImpl_decode = traverse $ _encoderImpl_decode ve
287297 }
288298
299+instance Monad parse => PFunctor Either (EncoderImpl parse) (EncoderImpl parse) where
300+ first f = bimap f id
301+instance Monad parse => QFunctor Either (EncoderImpl parse) (EncoderImpl parse) where
302+ second g = bimap id g
303+instance Monad parse => Bifunctor Either (EncoderImpl parse) (EncoderImpl parse) (EncoderImpl parse) where
304+ bimap f g = EncoderImpl
305+ { _encoderImpl_encode = bimap (_encoderImpl_encode f) (_encoderImpl_encode g)
306+ , _encoderImpl_decode = \case
307+ Left a -> Left <$> _encoderImpl_decode f a
308+ Right b -> Right <$> _encoderImpl_decode g b
309+ }
310+
311+instance (Monad parse, Applicative check) => QFunctor Either (Encoder check parse) (Encoder check parse) where
312+ second g = bimap id g
313+instance (Monad parse, Applicative check) => PFunctor Either (Encoder check parse) (Encoder check parse) where
314+ first f = bimap f id
315+instance (Monad parse, Applicative check) => Bifunctor Either (Encoder check parse) (Encoder check parse) (Encoder check parse) where
316+ bimap f g = Encoder $ liftA2 bimap (unEncoder f) (unEncoder g)
317+
318+instance (Applicative check, Monad parse) => Associative (Encoder check parse) Either where
319+ associate = isoEncoder (iso (associate @(->) @Either) disassociate)
320+ disassociate = isoEncoder (iso disassociate associate)
321+
322+instance (Monad parse, Applicative check) => Braided (Encoder check parse) Either where
323+ braid = isoEncoder (iso swap swap)
324+
325+
326+
289327instance (Traversable f, Monad check, Monad parse) => Cat.Functor f (Encoder check parse) (Encoder check parse) where
290328 fmap e = Encoder $ do
291329 ve <- unEncoder e
@@ -967,14 +1005,9 @@ readShowEncoder = singlePathSegmentEncoder . unsafeTshowEncoder
9671005integralEncoder :: (MonadError Text parse, Applicative check, Integral a) => Encoder check parse a Integer
9681006integralEncoder = prismEncoder (Numeric.Lens.integral)
9691007
970−pathSegmentEncoder :: (MonadError Text parse, Applicative check) =>
971− Encoder check parse (Text, PageName) PageName
972−pathSegmentEncoder = unsafeMkEncoder EncoderImpl
973− { _encoderImpl_encode = \(x, (y, z)) -> (x:y, z)
974− , _encoderImpl_decode = \(xss, y) -> case xss of
975− [] -> throwError "not enough path segments"
976− (x:xs) -> pure (x, (xs, y))
977− }
1008+pathSegmentEncoder :: (MonadError Text parse, Applicative check, Cons as as a a) =>
1009+ Encoder check parse (a, (as, b)) (as, b)
1010+pathSegmentEncoder = first (prismEncoder _Cons) . disassociate
9781011
9791012newtype Decoder check parse b a = Decoder { toEncoder :: Encoder check parse a b }
9801013
@@ -1028,6 +1061,32 @@ fieldMapEncoder = unsafeEncoder $ do
10281061 Just (Identity v) -> return v
10291062 }
10301063
1064+-- this is in base 4.12 (GHC 8.6);
1065+newtype Ap f a = Ap {getAp :: f a}
1066+
1067+instance (Applicative f, Semigroup a) => Semigroup (Ap f a) where
1068+ Ap x <> Ap y = Ap (liftA2 (<>) x y)
1069+
1070+instance (Applicative f, Monoid a) => Monoid (Ap f a) where
1071+ mappend = (<>)
1072+ mempty = Ap (pure mempty)
1073+
1074+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]
1075+pathFieldEncoder fieldEncoder = unsafeEncoder $ do
1076+ 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)
1077+ let fieldEncoderPure :: forall x. Field a x -> Encoder Identity parse x p
1078+ fieldEncoderPure f = toEncoder (DMap.findWithDefault (error "bad") f fieldEncoderPureMap)
1079+ pure $ EncoderImpl
1080+ { _encoderImpl_encode = \(x, rest) -> execWriter $ do
1081+ _ <- traverseWithField (\f x_i -> tell (pure $ encode (fieldEncoderPure f) x_i) *> pure x_i) x
1082+ tell rest
1083+ , _encoderImpl_decode = State.runStateT $ tabulateFieldsA $ \f -> State.get >>= \case
1084+ [] -> throwError $ T.pack "not enough path components"
1085+ p:ps -> do
1086+ State.put ps
1087+ lift $ tryDecode (fieldEncoderPure f) p
1088+ }
1089+
10311090-- | Use ToJSON/FromJSON to encode to Text. The correctness of this encoder is dependent on the encoding being injective and round-tripping correctly.
10321091jsonEncoder :: forall check parse r.
10331092 ( ToJSON r