@@ -34,6 +34,14 @@ module Obelisk.Route
3434 , singletonListValidEncoder
3535 , unpackTextEncoder
3636 , prefixTextEncoder
37+ , unsafeTshowValidEncoder
38+ , someConstValidEncoder
39+ , singlePathSegmentValidEncoder
40+ , justValidEncoder
41+ , nothingValidEncoder
42+ , isoValidEncoder
43+ , wrappedValidEncoder
44+ , unwrappedValidEncoder
3745 , listToNonEmptyEncoder
3846 , prefixNonemptyTextEncoder
3947 , joinPairTextEncoder
@@ -68,7 +76,7 @@ import qualified Control.Categorical.Functor as Cat
6876import Control.Categorical.Bifunctor
6977import Control.Category.Associative
7078import Control.Category.Monoidal
71−import Control.Lens (Identity (..), Prism', makePrisms, itraverse, imap, prism, (^.), re, matching, (^?))
79+import Control.Lens (Identity (..), Prism', makePrisms, itraverse, imap, prism, (^.), re, matching, (^?), _Just, _Nothing, Iso', from, view, Wrapped (..))
7280import Control.Monad.Except
7381import Data.Dependent.Sum (DSum (..))
7482import Data.Dependent.Map (DMap)
@@ -93,6 +101,7 @@ import Data.Text.Encoding
93101import Data.Universe
94102import Network.HTTP.Types.URI
95103import Obelisk.Route.TH
104+import Text.Read (readMaybe)
96105
97106-- Design goals:
98107-- No start-up time on the frontend (not yet met)
@@ -236,6 +245,40 @@ type PageName = ([Text], Map Text (Maybe Text))
236245
237246newtype Flip f a b = Flip { unFlip :: f b a }
238247
248+someConstValidEncoder :: Applicative parse => ValidEncoder parse (Some (Const a)) a
249+someConstValidEncoder = ValidEncoder
250+ { _validEncoder_encode = \(Some.This (Const a)) -> a
251+ , _validEncoder_decode = pure . Some.This . Const
252+ }
253+
254+-- | WARNING: This is only safe if the Show and Read instances for 'a' are
255+-- inverses of each other
256+unsafeTshowValidEncoder :: (Show a, Read a, MonadError Text parse) => ValidEncoder parse a Text
257+unsafeTshowValidEncoder = ValidEncoder
258+ { _validEncoder_encode = tshow
259+ , _validEncoder_decode = \raw -> case readMaybe $ T.unpack raw of
260+ Nothing -> throwError $ "unsafeTshowValidEncoder: couldn't decode " <> tshow raw
261+ Just parsed -> pure parsed
262+ }
263+
264+justValidEncoder :: MonadError Text parse => ValidEncoder parse a (Maybe a)
265+justValidEncoder = prismValidEncoder _Just
266+
267+nothingValidEncoder :: MonadError Text parse => ValidEncoder parse () (Maybe a)
268+nothingValidEncoder = prismValidEncoder _Nothing
269+
270+isoValidEncoder :: Applicative parse => Iso' a b -> ValidEncoder parse a b
271+isoValidEncoder f = ValidEncoder
272+ { _validEncoder_encode = view f
273+ , _validEncoder_decode = pure . view (from f)
274+ }
275+
276+wrappedValidEncoder :: (Wrapped a, Applicative parse) => ValidEncoder parse (Unwrapped a) a
277+wrappedValidEncoder = isoValidEncoder $ from _Wrapped'
278+
279+unwrappedValidEncoder :: (Wrapped a, Applicative parse) => ValidEncoder parse a (Unwrapped a)
280+unwrappedValidEncoder = isoValidEncoder _Wrapped'
281+
239282pathComponentEncoder :: forall check parse p. (Monad check, Monad parse) => (Encoder check parse (Some p) (Maybe Text)) -> (forall a. p a -> ValidEncoder parse a PageName) -> Encoder check parse (R p) PageName
240283pathComponentEncoder this rest = chainEncoder (lensEncoder (\(_, b) a -> (a, b)) Prelude.fst consValidEncoder) this rest
241284
@@ -354,6 +397,9 @@ endValidEncoder expected = ValidEncoder
354397 , _validEncoder_encode = \_ -> expected
355398 }
356399
400+singlePathSegmentValidEncoder :: MonadError Text parse => ValidEncoder parse Text PageName
401+singlePathSegmentValidEncoder = pathOnlyValidEncoder . singletonListValidEncoder
402+
357403pathOnlyValidEncoder :: (MonadError Text parse) => ValidEncoder parse [Text] PageName
358404pathOnlyValidEncoder = ValidEncoder
359405 { _validEncoder_decode = \(path, query) ->