@@ -1,4 +1,3 @@
1−{-# LANGUAGE CPP #-}
21{-# LANGUAGE ApplicativeDo #-}
32{-# LANGUAGE ConstraintKinds #-}
43{-# LANGUAGE EmptyCase #-}
@@ -6,6 +5,7 @@
65{-# LANGUAGE FlexibleContexts #-}
76{-# LANGUAGE FlexibleInstances #-}
87{-# LANGUAGE GADTs #-}
8+{-# LANGUAGE KindSignatures #-}
99{-# LANGUAGE LambdaCase #-}
1010{-# LANGUAGE MultiParamTypeClasses #-}
1111{-# LANGUAGE OverloadedStrings #-}
@@ -61,7 +61,6 @@ module Obelisk.Route
6161 , justEncoder
6262 , nothingEncoder
6363 , isoEncoder
64− , viewEncoder
6564 , wrappedEncoder
6665 , unwrappedEncoder
6766 , listToNonEmptyEncoder
@@ -70,7 +69,6 @@ module Obelisk.Route
7069 , toListMapEncoder
7170 , shadowEncoder
7271 , prismEncoder
73− , reviewEncoder
7472 , rPrism
7573 , _R
7674 , obeliskRouteEncoder
@@ -135,24 +133,20 @@ import Control.Lens
135133 , Prism'
136134 , prism'
137135 , re
138− , review
139136 , view
140137 , Wrapped (..)
141138 )
142139import Control.Monad.Except
140+import Control.Monad.Writer (execWriter, tell)
143141import qualified Control.Monad.State.Strict as State
144142import Control.Monad.Trans (lift)
145−import Control.Monad.Writer (execWriter, tell)
146−import Data.Aeson (FromJSON, ToJSON)
147−import qualified Data.Aeson as Aeson
148143import qualified Data.ByteString as BS
149144import qualified Data.ByteString.Lazy as BSL
145+import Data.Dependent.Sum (DSum (..))
150146import Data.Dependent.Map (DMap)
151147import qualified Data.Dependent.Map as DMap
152−import Data.Dependent.Sum (DSum (..))
153148import Data.Either.Validation (Validation (..))
154149import Data.Foldable
155−import Data.Functor (($>))
156150import Data.Functor.Sum
157151import Data.GADT.Compare
158152import Data.GADT.Compare.TH
@@ -165,18 +159,19 @@ import Data.Monoid ((<>))
165159import Data.Set (Set)
166160import qualified Data.Set as Set
167161import Data.Some (Some(Some))
168−import Data.Tabulation
169162import Data.Text (Text)
163+import Data.Text.Lens (IsText, packed, unpacked)
170164import qualified Data.Text as T
171165import qualified Data.Text.Encoding as T
172−import Data.Text.Lens (IsText, packed, unpacked)
173−import Data.Type.Equality
174166import Data.Universe
175167import Data.Universe.Some
176168import Network.HTTP.Types.URI
177169import qualified Numeric.Lens
178170import Obelisk.Route.TH
179171import Text.Read (readMaybe)
172+import Data.Tabulation
173+import qualified Data.Aeson as Aeson
174+import Data.Aeson (FromJSON, ToJSON)
180175
181176-- Design goals:
182177-- No start-up time on the frontend (not yet met)
@@ -226,19 +221,7 @@ hoistR f (x :=> Identity y) = f x :/ y
226221infixr 5 :.
227222type (:.) = (,)
228223
229−#ifdef __GLASGOW_HASKELL__
230−#if __GLASGOW_HASKELL__ >= 810
231224{-# 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
242225pattern (:.) :: a -> b -> a :. b
243226pattern a :. b = (a, b)
244227
@@ -304,13 +287,13 @@ decode e x = runIdentity (tryDecode e x)
304287-- | Once an 'Encoder' has been checked, so that its check monad has become 'Identity', even if the same is not true of the
305288-- parse monad, we may still attempt to decode with it in its parse monad.
306289tryDecode :: Encoder Identity parse decoded encoded -> encoded -> parse decoded
307−tryDecode (Encoder (Identity impl)) = _encoderImpl_decode impl
290+tryDecode (Encoder (Identity impl)) x = _encoderImpl_decode impl x
308291
309292-- | Similar to 'decode', once an encoder has been checked so that its check monad is Identity, it
310293-- can be used to actually encode by using this. Note that while there's no constraint on the parse monad here,
311294-- one should usually be applying decode and encode to the same 'Encoder'
312295encode :: Encoder Identity parse decoded encoded -> decoded -> encoded
313−encode (Encoder (Identity impl)) = _encoderImpl_encode impl
296+encode (Encoder (Identity impl)) x = _encoderImpl_encode impl x
314297
315298-- | This is a primitive used to build encoders which can't fail to check. It should not be used unless one is
316299-- reasonably certain that the law given for 'EncoderImpl' above holds.
@@ -357,7 +340,7 @@ instance Monad parse => Bifunctor (,) (EncoderImpl parse) (EncoderImpl parse) (E
357340 }
358341
359342instance (Monad parse, Applicative check) => Braided (Encoder check parse) (,) where
360− braid = viewEncoder (iso swap swap)
343+ braid = isoEncoder (iso swap swap)
361344
362345
363346instance (Applicative check, Monad parse) => PFunctor (,) (Encoder check parse) (Encoder check parse) where
@@ -393,11 +376,11 @@ instance (Monad parse, Applicative check) => Bifunctor Either (Encoder check par
393376 bimap f g = Encoder $ liftA2 bimap (unEncoder f) (unEncoder g)
394377
395378instance (Applicative check, Monad parse) => Associative (Encoder check parse) Either where
396− associate = viewEncoder (iso (associate @(->) @Either) disassociate)
397− disassociate = viewEncoder (iso disassociate associate)
379+ associate = isoEncoder (iso (associate @(->) @Either) disassociate)
380+ disassociate = isoEncoder (iso disassociate associate)
398381
399382instance (Monad parse, Applicative check) => Braided (Encoder check parse) Either where
400− braid = viewEncoder (iso swap swap)
383+ braid = isoEncoder (iso swap swap)
401384
402385
403386
@@ -451,17 +434,17 @@ instance (Applicative check, Monad parse) => Monoidal (Encoder check parse) (,)
451434--------------------------------------------------------------------------------
452435
453436-- | Given a valid 'Iso' from lens, construct an 'Encoder'
454−viewEncoder :: (Applicative check, Applicative parse) => Iso' a b -> Encoder check parse a b
455−viewEncoder f = unsafeMkEncoder $ EncoderImpl
437+isoEncoder :: (Applicative check, Applicative parse) => Iso' a b -> Encoder check parse a b
438+isoEncoder f = unsafeMkEncoder $ EncoderImpl
456439 { _encoderImpl_encode = view f
457440 , _encoderImpl_decode = pure . view (from f)
458441 }
459442
460443wrappedEncoder :: (Wrapped a, Applicative check, Applicative parse) => Encoder check parse (Unwrapped a) a
461−wrappedEncoder = viewEncoder $ from _Wrapped'
444+wrappedEncoder = isoEncoder $ from _Wrapped'
462445
463446unwrappedEncoder :: (Wrapped a, Applicative check, Applicative parse) => Encoder check parse a (Unwrapped a)
464−unwrappedEncoder = viewEncoder $ _Wrapped'
447+unwrappedEncoder = isoEncoder _Wrapped'
465448
466449maybeToEitherEncoder :: (Applicative check, Applicative parse) => Encoder check parse (Maybe a) (Either () a)
467450maybeToEitherEncoder = unsafeMkEncoder $ EncoderImpl
@@ -486,11 +469,11 @@ maybeEncoder f g = shadowEncoder f g . maybeToEitherEncoder
486469
487470-- | Encode a value by simply applying 'Just'
488471justEncoder :: (Applicative check, MonadError Text parse) => Encoder check parse a (Maybe a)
489−justEncoder = reviewEncoder _Just
472+justEncoder = prismEncoder _Just
490473
491474-- | Encode () to 'Nothing'.
492475nothingEncoder :: (Applicative check, MonadError Text parse) => Encoder check parse () (Maybe a)
493−nothingEncoder = reviewEncoder _Nothing
476+nothingEncoder = prismEncoder _Nothing
494477
495478someConstEncoder :: (Applicative check, Applicative parse) => Encoder check parse (Some (Const a)) a
496479someConstEncoder = unsafeMkEncoder $ EncoderImpl
@@ -555,11 +538,11 @@ pathComponentEncoder f = Encoder $ do
555538 unEncoder (pathComponentEncoderImpl (enum1Encoder (extractPathSegment . f)) f')
556539
557540pathComponentEncoderImpl :: forall check parse p. (Monad check, Monad parse)
558− => Encoder check parse (Some p) (Maybe Text)
541+ => (Encoder check parse (Some p) (Maybe Text))
559542 -> (forall a. p a -> Encoder Identity parse a PageName)
560543 -> Encoder check parse (R p) PageName
561−pathComponentEncoderImpl =
562− chainEncoder (lensEncoder (\(_, b) a -> (a, b)) Prelude.fst consEncoder)
544+pathComponentEncoderImpl this rest =
545+ chainEncoder (lensEncoder (\(_, b) a -> (a, b)) Prelude.fst consEncoder) this rest
563546
564547--NOTE: Naming convention in this module is to always talk about things in the *encoding* direction, never in the *decoding* direction
565548
@@ -815,7 +798,7 @@ rPrism
815798 :: forall f f'
816799 . (forall a. Prism' (f a) (f' a))
817800 -> Prism' (R f) (R f')
818−rPrism = dSumPrism
801+rPrism p = dSumPrism p
819802
820803dSumPrism'
821804 :: forall f g a
@@ -827,7 +810,7 @@ dSumGEqPrism
827810 :: GEq f
828811 => f a
829812 -> Prism' (DSum f g) (g a)
830−dSumGEqPrism variant = dSumPrism' $ prism' (\Refl -> variant) (geq variant)
813+dSumGEqPrism variant = dSumPrism' $ prism' (\Refl -> variant) (\x -> geq variant x)
831814
832815-- | Given a 'tag :: f a', make a prism for 'R f'. This generalizes the usual
833816-- prisms for a sum type (the ones that 'mkPrisms' would make), just as 'R'
@@ -844,19 +827,12 @@ _R variant = dSumGEqPrism variant . iso runIdentity Identity
844827
845828-- | An encoder that only works on the items available via the prism. An error will be thrown in the parse monad
846829-- if the prism doesn't match.
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
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)
857833 , _encoderImpl_decode = \r -> case r ^? p of
858834 Just a -> pure a
859− Nothing -> throwError "reviewEncoder: value is not present in the prism"
835+ Nothing -> throwError "prismEncoder: value is not present in the prism"
860836 }
861837
862838-- | A URL path and query string, in which trailing slashes don't matter in the path
@@ -994,9 +970,9 @@ obeliskRouteSegment r appRouteSegment = case r of
994970-- be combined with other such segment encoders before 'pathComponentEncoder' turns it into a proper 'Encoder'.
995971resourceRouteSegment :: (MonadError Text check, MonadError Text parse) => ResourceRoute a -> SegmentResult check parse a
996972resourceRouteSegment = \case
997− ResourceRoute_Static -> PathSegment "static" pathOnlyEncoderIgnoringQuery
998− ResourceRoute_Ghcjs -> PathSegment "ghcjs" pathOnlyEncoder
999− ResourceRoute_JSaddleWarp -> PathSegment "jsaddle" jsaddleWarpRouteEncoder
973+ ResourceRoute_Static -> PathSegment "static" $ pathOnlyEncoderIgnoringQuery
974+ ResourceRoute_Ghcjs -> PathSegment "ghcjs" $ pathOnlyEncoder
975+ ResourceRoute_JSaddleWarp -> PathSegment "jsaddle" $ jsaddleWarpRouteEncoder
1000976 ResourceRoute_Version -> PathSegment "version" $ unitEncoder mempty
1001977
1002978data JSaddleWarpRoute :: * -> * where
@@ -1008,7 +984,7 @@ jsaddleWarpRouteEncoder :: (MonadError Text check, MonadError Text parse) => Enc
1008984jsaddleWarpRouteEncoder = pathComponentEncoder $ \case
1009985 JSaddleWarpRoute_JavaScript -> PathSegment "jsaddle.js" $ unitEncoder mempty
1010986 JSaddleWarpRoute_WebSocket -> PathEnd $ unitEncoder mempty
1011− JSaddleWarpRoute_Sync -> PathSegment "sync" pathOnlyEncoder
987+ JSaddleWarpRoute_Sync -> PathSegment "sync" $ pathOnlyEncoder
1012988
1013989instance GShow appRoute => GShow (ObeliskRoute appRoute) where
1014990 gshowsPrec prec = \case
@@ -1039,8 +1015,8 @@ someSumEncoder = Encoder $ pure $ EncoderImpl
10391015
10401016data Void1 :: * -> * where {}
10411017
1042−instance UniverseSome Void1 where
1043− universeSome = []
1018+instance Universe (Some Void1) where
1019+ universe = []
10441020
10451021void1Encoder :: (Applicative check, MonadError Text parse) => Encoder check parse (Some Void1) a
10461022void1Encoder = Encoder $ pure $ EncoderImpl
@@ -1052,6 +1028,17 @@ void1Encoder = Encoder $ pure $ EncoderImpl
10521028instance GShow Void1 where
10531029 gshowsPrec _ = \case {}
10541030
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+
10551042-- | Given a backend route and a checked route encoder, render the route (path
10561043-- and query string). See 'checkEncoder' for how to produce a checked encoder.
10571044renderBackendRoute
@@ -1084,11 +1071,11 @@ readShowEncoder :: (MonadError Text parse, Read a, Show a, Applicative check) =>
10841071readShowEncoder = singlePathSegmentEncoder . unsafeTshowEncoder
10851072
10861073integralEncoder :: (MonadError Text parse, Applicative check, Integral a) => Encoder check parse a Integer
1087−integralEncoder = reviewEncoder Numeric.Lens.integral
1074+integralEncoder = prismEncoder (Numeric.Lens.integral)
10881075
10891076pathSegmentEncoder :: (MonadError Text parse, Applicative check, Cons as as a a) =>
10901077 Encoder check parse (a, (as, b)) (as, b)
1091−pathSegmentEncoder = first (reviewEncoder _Cons) . disassociate
1078+pathSegmentEncoder = first (prismEncoder _Cons) . disassociate
10921079
10931080newtype Decoder check parse b a = Decoder { toEncoder :: Encoder check parse a b }
10941081
@@ -1159,7 +1146,7 @@ pathFieldEncoder fieldEncoder = unsafeEncoder $ do
11591146 fieldEncoderPure f = toEncoder (DMap.findWithDefault (error "bad") f fieldEncoderPureMap)
11601147 pure $ EncoderImpl
11611148 { _encoderImpl_encode = \(x, rest) -> execWriter $ do
1162− _ <- traverseWithField (\f x_i -> tell (pure $ encode (fieldEncoderPure f) x_i) $> x_i) x
1149+ _ <- traverseWithField (\f x_i -> tell (pure $ encode (fieldEncoderPure f) x_i) *> pure x_i) x
11631150 tell rest
11641151 , _encoderImpl_decode = State.runStateT $ tabulateFieldsA $ \f -> State.get >>= \case
11651152 [] -> throwError $ T.pack "not enough path components"
@@ -1195,34 +1182,3 @@ byteStringsToPageName p q =
11951182 in decode pageNameEncoder' (T.unpack (T.decodeUtf8 p), T.unpack (T.decodeUtf8 q))
11961183
11971184--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