@@ -1,3 +1,4 @@
1+{-# LANGUAGE CPP #-}
12{-# LANGUAGE ApplicativeDo #-}
23{-# LANGUAGE ConstraintKinds #-}
34{-# LANGUAGE EmptyCase #-}
@@ -5,7 +6,6 @@
56{-# LANGUAGE FlexibleContexts #-}
67{-# LANGUAGE FlexibleInstances #-}
78{-# LANGUAGE GADTs #-}
8−{-# LANGUAGE KindSignatures #-}
99{-# LANGUAGE LambdaCase #-}
1010{-# LANGUAGE MultiParamTypeClasses #-}
1111{-# LANGUAGE OverloadedStrings #-}
@@ -61,6 +61,7 @@ module Obelisk.Route
6161 , justEncoder
6262 , nothingEncoder
6363 , isoEncoder
64+ , viewEncoder
6465 , wrappedEncoder
6566 , unwrappedEncoder
6667 , listToNonEmptyEncoder
@@ -69,6 +70,7 @@ module Obelisk.Route
6970 , toListMapEncoder
7071 , shadowEncoder
7172 , prismEncoder
73+ , reviewEncoder
7274 , rPrism
7375 , _R
7476 , obeliskRouteEncoder
@@ -133,20 +135,24 @@ import Control.Lens
133135 , Prism'
134136 , prism'
135137 , re
138+ , review
136139 , view
137140 , Wrapped (..)
138141 )
139142import Control.Monad.Except
140−import Control.Monad.Writer (execWriter, tell)
141143import qualified Control.Monad.State.Strict as State
142144import Control.Monad.Trans (lift)
145+import Control.Monad.Writer (execWriter, tell)
146+import Data.Aeson (FromJSON, ToJSON)
147+import qualified Data.Aeson as Aeson
143148import qualified Data.ByteString as BS
144149import qualified Data.ByteString.Lazy as BSL
145−import Data.Dependent.Sum (DSum (..))
146150import Data.Dependent.Map (DMap)
147151import qualified Data.Dependent.Map as DMap
152+import Data.Dependent.Sum (DSum (..))
148153import Data.Either.Validation (Validation (..))
149154import Data.Foldable
155+import Data.Functor (($>))
150156import Data.Functor.Sum
151157import Data.GADT.Compare
152158import Data.GADT.Compare.TH
@@ -159,19 +165,18 @@ import Data.Monoid ((<>))
159165import Data.Set (Set)
160166import qualified Data.Set as Set
161167import Data.Some (Some(Some))
168+import Data.Tabulation
162169import Data.Text (Text)
163−import Data.Text.Lens (IsText, packed, unpacked)
164170import qualified Data.Text as T
165171import qualified Data.Text.Encoding as T
172+import Data.Text.Lens (IsText, packed, unpacked)
173+import Data.Type.Equality
166174import Data.Universe
167175import Data.Universe.Some
168176import Network.HTTP.Types.URI
169177import qualified Numeric.Lens
170178import Obelisk.Route.TH
171179import Text.Read (readMaybe)
172−import Data.Tabulation
173−import qualified Data.Aeson as Aeson
174−import Data.Aeson (FromJSON, ToJSON)
175180
176181-- Design goals:
177182-- No start-up time on the frontend (not yet met)
@@ -221,7 +226,19 @@ hoistR f (x :=> Identity y) = f x :/ y
221226infixr 5 :.
222227type (:.) = (,)
223228
229+#ifdef __GLASGOW_HASKELL__
230+#if __GLASGOW_HASKELL__ >= 810
224231{-# COMPLETE (:.) #-}
232+#else
233+{-# WARNING (:.)
234+ [ "Use of this pattern in GHC < 8.10 will result in spurious non-exhaustive warnings at every use site."
235+ , "We cannot provide a COMPLETE pragma to silence these due to a GHC bug: https://gitlab.haskell.org/ghc/ghc/issues/17729."
236+ , "The bug hides incompleteness warnings for all two tuples when the COMPLETE pattern is in scope."
237+ , "Instead, you should use (,) directly until you can switch to GHC >= 8.10, where the COMPLETE pragma is reinstated."
238+ ]
239+ #-}
240+#endif
241+#endif
225242pattern (:.) :: a -> b -> a :. b
226243pattern a :. b = (a, b)
227244
@@ -287,13 +304,13 @@ decode e x = runIdentity (tryDecode e x)
287304-- | Once an 'Encoder' has been checked, so that its check monad has become 'Identity', even if the same is not true of the
288305-- parse monad, we may still attempt to decode with it in its parse monad.
289306tryDecode :: Encoder Identity parse decoded encoded -> encoded -> parse decoded
290−tryDecode (Encoder (Identity impl)) x = _encoderImpl_decode impl x
307+tryDecode (Encoder (Identity impl)) = _encoderImpl_decode impl
291308
292309-- | Similar to 'decode', once an encoder has been checked so that its check monad is Identity, it
293310-- can be used to actually encode by using this. Note that while there's no constraint on the parse monad here,
294311-- one should usually be applying decode and encode to the same 'Encoder'
295312encode :: Encoder Identity parse decoded encoded -> decoded -> encoded
296−encode (Encoder (Identity impl)) x = _encoderImpl_encode impl x
313+encode (Encoder (Identity impl)) = _encoderImpl_encode impl
297314
298315-- | This is a primitive used to build encoders which can't fail to check. It should not be used unless one is
299316-- reasonably certain that the law given for 'EncoderImpl' above holds.
@@ -340,7 +357,7 @@ instance Monad parse => Bifunctor (,) (EncoderImpl parse) (EncoderImpl parse) (E
340357 }
341358
342359instance (Monad parse, Applicative check) => Braided (Encoder check parse) (,) where
343− braid = isoEncoder (iso swap swap)
360+ braid = viewEncoder (iso swap swap)
344361
345362
346363instance (Applicative check, Monad parse) => PFunctor (,) (Encoder check parse) (Encoder check parse) where
@@ -376,11 +393,11 @@ instance (Monad parse, Applicative check) => Bifunctor Either (Encoder check par
376393 bimap f g = Encoder $ liftA2 bimap (unEncoder f) (unEncoder g)
377394
378395instance (Applicative check, Monad parse) => Associative (Encoder check parse) Either where
379− associate = isoEncoder (iso (associate @(->) @Either) disassociate)
380− disassociate = isoEncoder (iso disassociate associate)
396+ associate = viewEncoder (iso (associate @(->) @Either) disassociate)
397+ disassociate = viewEncoder (iso disassociate associate)
381398
382399instance (Monad parse, Applicative check) => Braided (Encoder check parse) Either where
383− braid = isoEncoder (iso swap swap)
400+ braid = viewEncoder (iso swap swap)
384401
385402
386403
@@ -434,17 +451,17 @@ instance (Applicative check, Monad parse) => Monoidal (Encoder check parse) (,)
434451--------------------------------------------------------------------------------
435452
436453-- | Given a valid 'Iso' from lens, construct an 'Encoder'
437−isoEncoder :: (Applicative check, Applicative parse) => Iso' a b -> Encoder check parse a b
438−isoEncoder f = unsafeMkEncoder $ EncoderImpl
454+viewEncoder :: (Applicative check, Applicative parse) => Iso' a b -> Encoder check parse a b
455+viewEncoder f = unsafeMkEncoder $ EncoderImpl
439456 { _encoderImpl_encode = view f
440457 , _encoderImpl_decode = pure . view (from f)
441458 }
442459
443460wrappedEncoder :: (Wrapped a, Applicative check, Applicative parse) => Encoder check parse (Unwrapped a) a
444−wrappedEncoder = isoEncoder $ from _Wrapped'
461+wrappedEncoder = viewEncoder $ from _Wrapped'
445462
446463unwrappedEncoder :: (Wrapped a, Applicative check, Applicative parse) => Encoder check parse a (Unwrapped a)
447−unwrappedEncoder = isoEncoder _Wrapped'
464+unwrappedEncoder = viewEncoder $ _Wrapped'
448465
449466maybeToEitherEncoder :: (Applicative check, Applicative parse) => Encoder check parse (Maybe a) (Either () a)
450467maybeToEitherEncoder = unsafeMkEncoder $ EncoderImpl
@@ -469,11 +486,11 @@ maybeEncoder f g = shadowEncoder f g . maybeToEitherEncoder
469486
470487-- | Encode a value by simply applying 'Just'
471488justEncoder :: (Applicative check, MonadError Text parse) => Encoder check parse a (Maybe a)
472−justEncoder = prismEncoder _Just
489+justEncoder = reviewEncoder _Just
473490
474491-- | Encode () to 'Nothing'.
475492nothingEncoder :: (Applicative check, MonadError Text parse) => Encoder check parse () (Maybe a)
476−nothingEncoder = prismEncoder _Nothing
493+nothingEncoder = reviewEncoder _Nothing
477494
478495someConstEncoder :: (Applicative check, Applicative parse) => Encoder check parse (Some (Const a)) a
479496someConstEncoder = unsafeMkEncoder $ EncoderImpl
@@ -538,11 +555,11 @@ pathComponentEncoder f = Encoder $ do
538555 unEncoder (pathComponentEncoderImpl (enum1Encoder (extractPathSegment . f)) f')
539556
540557pathComponentEncoderImpl :: forall check parse p. (Monad check, Monad parse)
541− => (Encoder check parse (Some p) (Maybe Text))
558+ => Encoder check parse (Some p) (Maybe Text)
542559 -> (forall a. p a -> Encoder Identity parse a PageName)
543560 -> Encoder check parse (R p) PageName
544−pathComponentEncoderImpl this rest =
545− chainEncoder (lensEncoder (\(_, b) a -> (a, b)) Prelude.fst consEncoder) this rest
561+pathComponentEncoderImpl =
562+ chainEncoder (lensEncoder (\(_, b) a -> (a, b)) Prelude.fst consEncoder)
546563
547564--NOTE: Naming convention in this module is to always talk about things in the *encoding* direction, never in the *decoding* direction
548565
@@ -798,7 +815,7 @@ rPrism
798815 :: forall f f'
799816 . (forall a. Prism' (f a) (f' a))
800817 -> Prism' (R f) (R f')
801−rPrism p = dSumPrism p
818+rPrism = dSumPrism
802819
803820dSumPrism'
804821 :: forall f g a
@@ -810,7 +827,7 @@ dSumGEqPrism
810827 :: GEq f
811828 => f a
812829 -> Prism' (DSum f g) (g a)
813−dSumGEqPrism variant = dSumPrism' $ prism' (\Refl -> variant) (\x -> geq variant x)
830+dSumGEqPrism variant = dSumPrism' $ prism' (\Refl -> variant) (geq variant)
814831
815832-- | Given a 'tag :: f a', make a prism for 'R f'. This generalizes the usual
816833-- prisms for a sum type (the ones that 'mkPrisms' would make), just as 'R'
@@ -827,12 +844,19 @@ _R variant = dSumGEqPrism variant . iso runIdentity Identity
827844
828845-- | An encoder that only works on the items available via the prism. An error will be thrown in the parse monad
829846-- if the prism doesn't match.
830−prismEncoder :: (Applicative check, MonadError Text parse) => Prism' b a -> Encoder check parse a b
831−prismEncoder p = unsafeMkEncoder $ EncoderImpl
832− { _encoderImpl_encode = (^. re p)
847+--
848+-- Note that a 'Prism' from @a@ to @b@ will produce an 'Encoder' from @b@ to @a@
849+-- (i.e. 'reviewEncoder' is a contravariant functor from the category of prisms to the category of encoders),
850+-- just like 'review' produces a function @b -> a@. This is because 'Prism's extract values, in a way that might
851+-- fail, in their forward direction and inject values, in a way that cannot fail, in their reverse direction;
852+-- whereas 'Encoder's encode, which cannot fail, in their forward direction, and decode, which can fail, in their
853+-- reverse direction. In short @reviewEncoder (f . g) = reviewEncoder g . reviewEncoder f@.
854+reviewEncoder :: (Applicative check, MonadError Text parse) => Prism' b a -> Encoder check parse a b
855+reviewEncoder p = unsafeMkEncoder $ EncoderImpl
856+ { _encoderImpl_encode = review p
833857 , _encoderImpl_decode = \r -> case r ^? p of
834858 Just a -> pure a
835− Nothing -> throwError "prismEncoder: value is not present in the prism"
859+ Nothing -> throwError "reviewEncoder: value is not present in the prism"
836860 }
837861
838862-- | A URL path and query string, in which trailing slashes don't matter in the path
@@ -970,9 +994,9 @@ obeliskRouteSegment r appRouteSegment = case r of
970994-- be combined with other such segment encoders before 'pathComponentEncoder' turns it into a proper 'Encoder'.
971995resourceRouteSegment :: (MonadError Text check, MonadError Text parse) => ResourceRoute a -> SegmentResult check parse a
972996resourceRouteSegment = \case
973− ResourceRoute_Static -> PathSegment "static" $ pathOnlyEncoderIgnoringQuery
974− ResourceRoute_Ghcjs -> PathSegment "ghcjs" $ pathOnlyEncoder
975− ResourceRoute_JSaddleWarp -> PathSegment "jsaddle" $ jsaddleWarpRouteEncoder
997+ ResourceRoute_Static -> PathSegment "static" pathOnlyEncoderIgnoringQuery
998+ ResourceRoute_Ghcjs -> PathSegment "ghcjs" pathOnlyEncoder
999+ ResourceRoute_JSaddleWarp -> PathSegment "jsaddle" jsaddleWarpRouteEncoder
9761000 ResourceRoute_Version -> PathSegment "version" $ unitEncoder mempty
9771001
9781002data JSaddleWarpRoute :: * -> * where
@@ -984,7 +1008,7 @@ jsaddleWarpRouteEncoder :: (MonadError Text check, MonadError Text parse) => Enc
9841008jsaddleWarpRouteEncoder = pathComponentEncoder $ \case
9851009 JSaddleWarpRoute_JavaScript -> PathSegment "jsaddle.js" $ unitEncoder mempty
9861010 JSaddleWarpRoute_WebSocket -> PathEnd $ unitEncoder mempty
987− JSaddleWarpRoute_Sync -> PathSegment "sync" $ pathOnlyEncoder
1011+ JSaddleWarpRoute_Sync -> PathSegment "sync" pathOnlyEncoder
9881012
9891013instance GShow appRoute => GShow (ObeliskRoute appRoute) where
9901014 gshowsPrec prec = \case
@@ -1015,8 +1039,8 @@ someSumEncoder = Encoder $ pure $ EncoderImpl
10151039
10161040data Void1 :: * -> * where {}
10171041
1018−instance Universe (Some Void1) where
1019− universe = []
1042+instance UniverseSome Void1 where
1043+ universeSome = []
10201044
10211045void1Encoder :: (Applicative check, MonadError Text parse) => Encoder check parse (Some Void1) a
10221046void1Encoder = Encoder $ pure $ EncoderImpl
@@ -1028,17 +1052,6 @@ void1Encoder = Encoder $ pure $ EncoderImpl
10281052instance GShow Void1 where
10291053 gshowsPrec _ = \case {}
10301054
1031−concat <$> mapM deriveRouteComponent
1032− [ ''ResourceRoute
1033− , ''JSaddleWarpRoute
1034− , ''IndexOnlyRoute
1035− ]
1036−
1037−makePrisms ''ObeliskRoute
1038−makePrisms ''FullRoute
1039−deriveGEq ''Void1
1040−deriveGCompare ''Void1
1041−
10421055-- | Given a backend route and a checked route encoder, render the route (path
10431056-- and query string). See 'checkEncoder' for how to produce a checked encoder.
10441057renderBackendRoute
@@ -1071,11 +1084,11 @@ readShowEncoder :: (MonadError Text parse, Read a, Show a, Applicative check) =>
10711084readShowEncoder = singlePathSegmentEncoder . unsafeTshowEncoder
10721085
10731086integralEncoder :: (MonadError Text parse, Applicative check, Integral a) => Encoder check parse a Integer
1074−integralEncoder = prismEncoder (Numeric.Lens.integral)
1087+integralEncoder = reviewEncoder Numeric.Lens.integral
10751088
10761089pathSegmentEncoder :: (MonadError Text parse, Applicative check, Cons as as a a) =>
10771090 Encoder check parse (a, (as, b)) (as, b)
1078−pathSegmentEncoder = first (prismEncoder _Cons) . disassociate
1091+pathSegmentEncoder = first (reviewEncoder _Cons) . disassociate
10791092
10801093newtype Decoder check parse b a = Decoder { toEncoder :: Encoder check parse a b }
10811094
@@ -1146,7 +1159,7 @@ pathFieldEncoder fieldEncoder = unsafeEncoder $ do
11461159 fieldEncoderPure f = toEncoder (DMap.findWithDefault (error "bad") f fieldEncoderPureMap)
11471160 pure $ EncoderImpl
11481161 { _encoderImpl_encode = \(x, rest) -> execWriter $ do
1149− _ <- traverseWithField (\f x_i -> tell (pure $ encode (fieldEncoderPure f) x_i) *> pure x_i) x
1162+ _ <- traverseWithField (\f x_i -> tell (pure $ encode (fieldEncoderPure f) x_i) $> x_i) x
11501163 tell rest
11511164 , _encoderImpl_decode = State.runStateT $ tabulateFieldsA $ \f -> State.get >>= \case
11521165 [] -> throwError $ T.pack "not enough path components"
@@ -1182,3 +1195,34 @@ byteStringsToPageName p q =
11821195 in decode pageNameEncoder' (T.unpack (T.decodeUtf8 p), T.unpack (T.decodeUtf8 q))
11831196
11841197--TODO: decodeURIComponent as appropriate
1198+
1199+
1200+{-# DEPRECATED isoEncoder "Instead of 'isoEncoder f', use 'viewEncoder f'" #-}
1201+-- | Given a valid 'Iso' from lens, construct an 'Encoder'
1202+isoEncoder :: (Applicative check, Applicative parse) => Iso' a b -> Encoder check parse a b
1203+isoEncoder = viewEncoder
1204+
1205+{-# DEPRECATED prismEncoder "Instead of 'prismEncoder f', use 'reviewEncoder f'" #-}
1206+-- | An encoder that only works on the items available via the prism. An error will be thrown in the parse monad
1207+-- if the prism doesn't match.
1208+--
1209+-- Note that a 'Prism' from @a@ to @b@ will produce an 'Encoder' from @b@ to @a@
1210+-- (i.e. 'prismEncoder' is a contravariant functor from the category of prisms to the category of encoders),
1211+-- just like 'review' produces a function @b -> a@. This is because 'Prism's extract values, in a way that might
1212+-- fail, in their forward direction and inject values, in a way that cannot fail, in their reverse direction;
1213+-- whereas 'Encoder's encode, which cannot fail, in their forward direction, and decode, which can fail, in their
1214+-- reverse direction. In short @prismEncoder (f . g) = prismEncoder g . prismEncoder f@.
1215+prismEncoder :: (Applicative check, MonadError Text parse) => Prism' b a -> Encoder check parse a b
1216+prismEncoder = reviewEncoder
1217+
1218+
1219+concat <$> mapM deriveRouteComponent
1220+ [ ''ResourceRoute
1221+ , ''JSaddleWarpRoute
1222+ , ''IndexOnlyRoute
1223+ ]
1224+
1225+makePrisms ''ObeliskRoute
1226+makePrisms ''FullRoute
1227+deriveGEq ''Void1
1228+deriveGCompare ''Void1