Allow ignoring query parameters at route branches

lib/route/src/Obelisk/Route.hs

@@ -57,6 +57,7 @@ module Obelisk.Route
   -- * Collating Routes
   , SegmentResult (..)
   , pathComponentEncoder
+  , pathComponentEncoderIgnoringQuery
 
   , FullRoute (..)
   , _FullRoute_Frontend
@@ -80,6 +81,7 @@ module Obelisk.Route
   , enum1Encoder
   , checkEnum1EncoderFunc
   , unitEncoder
+  , unitEncoderLenient
   , pathOnlyEncoder
   , addPathSegmentEncoder
   , pathParamEncoder
@@ -119,6 +121,7 @@ module Obelisk.Route
   , queryParametersTextEncoder
   , integralEncoder
   , pathSegmentEncoder
+  , pathOnlyEncoderIgnoringQuery
   , queryOnlyEncoder
   , Decoder(..)
   , dmapEncoder
@@ -577,32 +580,56 @@ checkEnum1EncoderFunc f = do
 
 -- | This type is used by pathComponentEncoder to allow the user to indicate how to treat
 -- various cases when encoding a dependent sum of type `(R p)`.
-data SegmentResult check parse a =
-    PathEnd (Encoder check parse a (Map Text (Maybe Text)))
+data SegmentResult check parse a b =
+    PathEnd (Encoder check parse a b)
     -- ^ Indicate that the path is finished, with an Encoder that translates the
     -- corresponding value into query parameters
-  | PathSegment Text (Encoder check parse a PageName)
+  | PathSegment Text (Encoder check parse a ([Text], b))
     -- ^ Indicate that the key should be represented by an additional path segment with
     -- the given 'Text', and give an Encoder for translating the corresponding value into
     -- the remainder of the route.
 
+pathComponentEncoderIgnoringQuery
+  :: ( Universe (Some p)
+     , GShow p
+     , GCompare p
+     , MonadError Text check
+     , MonadError Text parse
+     )
+  => (forall a. p a -> SegmentResult check parse a ())
+  -> Encoder check parse (R p) PageName
+pathComponentEncoderIgnoringQuery = pathComponentEncoder' $ \case
+  PathEnd e -> first (unitEncoder []) . coidl . unitEncoderLenient mempty .  e
+  PathSegment _ e -> pathOnlyEncoderIgnoringQuery . idr . e
+
+pathComponentEncoder
+  :: ( Universe (Some p)
+     , GShow p
+     , GCompare p
+     , MonadError Text check
+     , MonadError Text parse
+     )
+  => (forall a. p a -> SegmentResult check parse a (Map Text (Maybe Text)))
+  -> Encoder check parse (R p) PageName
+pathComponentEncoder = pathComponentEncoder' $ \case
+  PathEnd e -> first (unitEncoder []) . coidl . e
+  PathSegment _ e -> e
+
 -- | Encode a dependent sum of type `(R p)` into a PageName (i.e. the path and query part of a URL) by using the
 -- supplied function to decide how to encode the constructors of p using the SegmentResult type. It is important
 -- that the number of values of type `(Some p)` be relatively small in order for checking to complete quickly.
-pathComponentEncoder
-  :: forall check parse p.
-     ( Universe (Some p)
+pathComponentEncoder'
+  :: ( Universe (Some p)
      , GShow p
      , GCompare p
      , MonadError Text check
-     , MonadError Text parse )
-  => (forall a. p a -> SegmentResult check parse a)
+     , MonadError Text parse
+     )
+  => (forall a. SegmentResult check parse a b -> Encoder check parse a PageName)
+  -> (forall a. p a -> SegmentResult check parse a b)
   -> Encoder check parse (R p) PageName
-pathComponentEncoder f = Encoder $ do
-  let extractEncoder = \case
-        PathEnd e -> first (unitEncoder []) . coidl . e
-        PathSegment _ e -> e
-      extractPathSegment = \case
+pathComponentEncoder' extractEncoder f = Encoder $ do
+  let extractPathSegment = \case
         PathEnd _ -> Nothing
         PathSegment t _ -> Just t
   EncoderFunc f' <- checkEnum1EncoderFunc (extractEncoder . f)
@@ -737,6 +764,12 @@ unitEncoder expected = unsafeMkEncoder $ EncoderImpl
   , _encoderImpl_encode = \_ -> expected
   }
 
+unitEncoderLenient :: (Applicative check, Applicative parse) => r -> Encoder check parse () r
+unitEncoderLenient expected = unsafeMkEncoder $ EncoderImpl
+  { _encoderImpl_decode = \_ -> pure ()
+  , _encoderImpl_encode = \_ -> expected
+  }
+
 singlePathSegmentEncoder :: (Applicative check, MonadError Text parse) => Encoder check parse Text PageName
 singlePathSegmentEncoder = pathOnlyEncoder . singletonListEncoder
 
@@ -976,8 +1009,8 @@ instance  (UniverseSome br, UniverseSome fr) => UniverseSome (FullRoute br fr) w
 mkFullRouteEncoder
   :: (GCompare br, GCompare fr, GShow br, GShow fr, UniverseSome br, UniverseSome fr)
   => R (FullRoute br fr) -- ^ 404 handler
-  -> (forall a. br a -> SegmentResult (Either Text) (Either Text) a) -- ^ How to encode a single backend route segment
-  -> (forall a. fr a -> SegmentResult (Either Text) (Either Text) a) -- ^ How to encode a single frontend route segment
+  -> (forall a. br a -> SegmentResult (Either Text) (Either Text) a (Map Text (Maybe Text))) -- ^ How to encode a single backend route segment
+  -> (forall a. fr a -> SegmentResult (Either Text) (Either Text) a (Map Text (Maybe Text))) -- ^ How to encode a single frontend route segment
   -> Encoder (Either Text) Identity (R (FullRoute br fr)) PageName
 mkFullRouteEncoder missing backendSegment frontendSegment = handleEncoder (const missing) $
   pathComponentEncoder $ \case
@@ -1027,7 +1060,7 @@ obeliskRouteEncoder :: forall check parse appRoute.
      , MonadError Text check
      , check ~ parse --TODO: Get rid of this
      )
-  => (forall a. appRoute a -> SegmentResult check parse a)
+  => (forall a. appRoute a -> SegmentResult check parse a (Map Text (Maybe Text)))
   -> Encoder check parse (R (ObeliskRoute appRoute)) PageName
 obeliskRouteEncoder appRouteSegment = pathComponentEncoder $ \r ->
   obeliskRouteSegment r appRouteSegment
@@ -1038,15 +1071,15 @@ obeliskRouteEncoder appRouteSegment = pathComponentEncoder $ \r ->
 obeliskRouteSegment :: forall check parse appRoute a.
      (MonadError Text check, MonadError Text parse)
   => ObeliskRoute appRoute a
-  -> (forall b. appRoute b -> SegmentResult check parse b)
-  -> SegmentResult check parse a
+  -> (forall b. appRoute b -> SegmentResult check parse b (Map Text (Maybe Text)))
+  -> SegmentResult check parse a (Map Text (Maybe Text))
 obeliskRouteSegment r appRouteSegment = case r of
   ObeliskRoute_App appRoute -> appRouteSegment appRoute
   ObeliskRoute_Resource resourceRoute -> resourceRouteSegment resourceRoute
 
 -- | A function which gives a sane default for how to encode Obelisk resource routes. It's given in this form, because it will
 -- be combined with other such segment encoders before 'pathComponentEncoder' turns it into a proper 'Encoder'.
-resourceRouteSegment :: (MonadError Text check, MonadError Text parse) => ResourceRoute a -> SegmentResult check parse a
+resourceRouteSegment :: (MonadError Text check, MonadError Text parse) => ResourceRoute a -> SegmentResult check parse a (Map Text (Maybe Text))
 resourceRouteSegment = \case
   ResourceRoute_Static -> PathSegment "static" pathOnlyEncoderIgnoringQuery
   ResourceRoute_Ghcjs -> PathSegment "ghcjs" pathOnlyEncoder
@@ -1074,7 +1107,7 @@ instance GShow appRoute => GShow (ObeliskRoute appRoute) where
 data IndexOnlyRoute :: * -> * where
   IndexOnlyRoute :: IndexOnlyRoute ()
 
-indexOnlyRouteSegment :: (Applicative check, MonadError Text parse) => IndexOnlyRoute a -> SegmentResult check parse a
+indexOnlyRouteSegment :: (Applicative check, MonadError Text parse) => IndexOnlyRoute a -> SegmentResult check parse a (Map Text (Maybe Text))
 indexOnlyRouteSegment = \case
   IndexOnlyRoute -> PathEnd $ unitEncoder mempty