@@ -62,6 +62,7 @@ module Obelisk.Route
6262 , shadowEncoder
6363 , prismEncoder
6464 , rPrism
65+ , _R
6566 , obeliskRouteEncoder
6667 , obeliskRouteSegment
6768 , pageNameEncoder
@@ -102,7 +103,24 @@ import qualified Control.Categorical.Functor as Cat
102103import Control.Categorical.Bifunctor
103104import Control.Category.Associative
104105import Control.Category.Monoidal
105−import Control.Lens (Identity (..), Prism', makePrisms, itraverse, imap, prism, (^.), re, matching, (^?), _Just, _Nothing, Iso', from, view, Wrapped (..))
106+import Control.Lens
107+ ( Identity (..)
108+ , (^.)
109+ , (^?)
110+ , Iso'
111+ , Prism'
112+ , Wrapped (..)
113+ , _Just
114+ , _Nothing
115+ , from
116+ , imap
117+ , iso
118+ , itraverse
119+ , makePrisms
120+ , prism'
121+ , re
122+ , view
123+ )
106124import Control.Monad.Except
107125import qualified Data.ByteString as BS
108126import qualified Data.ByteString.Lazy as BSL
@@ -666,10 +684,81 @@ joinPairTextEncoder = Encoder . \case
666684 _ -> return (kt, T.drop (T.length separator) vt)
667685 }
668686
669−--TODO: Rewrite this by composing the given prism with a lens on the first element of the DSum
670−-- Or, more likely, the user can compose it themselves
671−rPrism :: forall f g. (forall a. Prism' (f a) (g a)) -> Prism' (R f) (R g)
672−rPrism p = prism (\(g :/ x) -> g ^. re p :/ x) (\(f :/ x) -> bimap (:/ x) (:/ x) $ matching p f)
687+-- -- | Like '_2' but for DSum not '(,)'.
688+-- dSumFirstLensLike
689+-- :: forall f g g' h
690+-- . Functor f
691+-- => (forall a. g a -> f (g' a))
692+-- -> (DSum g h) -> f (DSum g' h)
693+-- dSumFirstLensLike f (l :=> r) = (:=> r) <$> f l
694+--
695+-- -- | Like '_2' but for DSum not '(,)'.
696+-- dSumSecondLensLike
697+-- :: forall f g h h'
698+-- . Functor f
699+-- => (forall a. h a -> f (h' a))
700+-- -> (DSum g h) -> f (DSum g h')
701+-- dSumSecondLensLike f (l :=> r) = (l :=>) <$> f r
702+
703+-- TODO: Rewrite this by composing the given prism with a lens on the first
704+-- element of the DSum Or, more likely, the user can compose it themselves
705+--
706+-- TODO I (@Ericson2314) think this previous comment is wrong. I wrote the lenses above.
707+-- It didn't help. Combining lenses and prisms yields (affine) traversals, not
708+-- prisms. Perhaps If we had "DStrong", like, 'Strong' but for 'DSum', not '(,)', we
709+-- could get something like:
710+--
711+-- > dSumFirstOptic
712+-- > :: forall f g g' h
713+-- > . DStrong p
714+-- > => (forall a. p (g a) (g' a))
715+-- > -> p (DSum g h) (DSum g' h)
716+-- > dSumFirstOptic = ???
717+--
718+-- That is certainly a science project, and I don't anticipate any additional
719+-- generality between that and what is written.
720+
721+-- This slight generalization of 'rPrism' happens to be enough to write all our
722+-- prism combinators so far.
723+dSumPrism
724+ :: forall f f' g
725+ . (forall a. Prism' (f a) (f' a))
726+ -> Prism' (DSum f g) (DSum f' g)
727+dSumPrism p = prism'
728+ (\(f' :=> x) -> f' ^. re p :=> x)
729+ (\(f :=> x) -> (:=> x) <$> (f ^? p))
730+
731+-- already in obelisk
732+rPrism
733+ :: forall f f'
734+ . (forall a. Prism' (f a) (f' a))
735+ -> Prism' (R f) (R f')
736+rPrism p = dSumPrism p
737+
738+dSumPrism'
739+ :: forall f g a
740+ . (forall b. Prism' (f b) (a :~: b))
741+ -> Prism' (DSum f g) (g a)
742+dSumPrism' p = dSumPrism p . iso (\(Refl :=> b) -> b) (Refl :=>)
743+
744+dSumGEqPrism
745+ :: GEq f
746+ => f a
747+ -> Prism' (DSum f g) (g a)
748+dSumGEqPrism variant = dSumPrism' $ prism' (\Refl -> variant) (\x -> geq variant x)
749+
750+-- | Given a 'tag :: f a', make a prism for 'R f'. This generalizes the usual
751+-- prisms for a sum type (the ones that 'mkPrisms' would make), just as 'R'
752+-- generalized a usual sum type.
753+--
754+-- [This is given the '_R' name of the "cannonical" prism not because it is the
755+-- most general, but because it seems the most useful for routes, and 'R' itself
756+-- trades generality for route-specificity.]
757+_R
758+ :: GEq f
759+ => f a
760+ -> Prism' (R f) a
761+_R variant = dSumGEqPrism variant . iso runIdentity Identity
673762
674763-- | An encoder that only works on the items available via the prism. An error will be thrown in the parse monad
675764-- if the prism doesn't match.