@@ -6,6 +6,7 @@
6{-# LANGUAGE FlexibleContexts #-}
6{-# LANGUAGE FlexibleContexts #-}
7{-# LANGUAGE FlexibleInstances #-}
7{-# LANGUAGE FlexibleInstances #-}
8{-# LANGUAGE GADTs #-}
8{-# LANGUAGE GADTs #-}
9+{-# LANGUAGE KindSignatures #-}
9{-# LANGUAGE LambdaCase #-}
10{-# LANGUAGE LambdaCase #-}
10{-# LANGUAGE MultiParamTypeClasses #-}
11{-# LANGUAGE MultiParamTypeClasses #-}
11{-# LANGUAGE OverloadedStrings #-}
12{-# LANGUAGE OverloadedStrings #-}
@@ -140,19 +141,16 @@ import Control.Lens
140 , Wrapped (..)
141 , Wrapped (..)
142import Control.Monad.Except
143import Control.Monad.Except
144+import Control.Monad.Writer (execWriter, tell)
143import qualified Control.Monad.State.Strict as State
145import qualified Control.Monad.State.Strict as State
144import Control.Monad.Trans (lift)
146import Control.Monad.Trans (lift)
145−import Control.Monad.Writer (execWriter, tell)
146−import Data.Aeson (FromJSON, ToJSON)
147−import qualified Data.Aeson as Aeson
148import qualified Data.ByteString as BS
147import qualified Data.ByteString as BS
149import qualified Data.ByteString.Lazy as BSL
148import qualified Data.ByteString.Lazy as BSL
149+import Data.Dependent.Sum (DSum (..))
150import Data.Dependent.Map (DMap)
150import Data.Dependent.Map (DMap)
151import qualified Data.Dependent.Map as DMap
151import qualified Data.Dependent.Map as DMap
152−import Data.Dependent.Sum (DSum (..))
153import Data.Either.Validation (Validation (..))
152import Data.Either.Validation (Validation (..))
154import Data.Foldable
153import Data.Foldable
155−import Data.Functor (($>))
156import Data.Functor.Sum
154import Data.Functor.Sum
157import Data.GADT.Compare
155import Data.GADT.Compare
158import Data.GADT.Compare.TH
156import Data.GADT.Compare.TH
@@ -165,18 +163,19 @@ import Data.Monoid ((<>))
165import Data.Set (Set)
163import Data.Set (Set)
166import qualified Data.Set as Set
164import qualified Data.Set as Set
167import Data.Some (Some(Some))
165import Data.Some (Some(Some))
168−import Data.Tabulation
169import Data.Text (Text)
166import Data.Text (Text)
167+import Data.Text.Lens (IsText, packed, unpacked)
170import qualified Data.Text as T
168import qualified Data.Text as T
171import qualified Data.Text.Encoding as T
169import qualified Data.Text.Encoding as T
172−import Data.Text.Lens (IsText, packed, unpacked)
173−import Data.Type.Equality
174import Data.Universe
170import Data.Universe
175import Data.Universe.Some
171import Data.Universe.Some
176import Network.HTTP.Types.URI
172import Network.HTTP.Types.URI
177import qualified Numeric.Lens
173import qualified Numeric.Lens
178import Obelisk.Route.TH
174import Obelisk.Route.TH
179import Text.Read (readMaybe)
175import Text.Read (readMaybe)
176+import Data.Tabulation
177+import qualified Data.Aeson as Aeson
178+import Data.Aeson (FromJSON, ToJSON)
181-- Design goals:
180-- Design goals:
182-- No start-up time on the frontend (not yet met)
181-- No start-up time on the frontend (not yet met)
@@ -304,13 +303,13 @@ decode e x = runIdentity (tryDecode e x)
304-- | Once an 'Encoder' has been checked, so that its check monad has become 'Identity', even if the same is not true of the
303-- | Once an 'Encoder' has been checked, so that its check monad has become 'Identity', even if the same is not true of the
305-- parse monad, we may still attempt to decode with it in its parse monad.
304-- parse monad, we may still attempt to decode with it in its parse monad.
306tryDecode :: Encoder Identity parse decoded encoded -> encoded -> parse decoded
305tryDecode :: Encoder Identity parse decoded encoded -> encoded -> parse decoded
307−tryDecode (Encoder (Identity impl)) = _encoderImpl_decode impl
306+tryDecode (Encoder (Identity impl)) x = _encoderImpl_decode impl x
309-- | Similar to 'decode', once an encoder has been checked so that its check monad is Identity, it
308-- | Similar to 'decode', once an encoder has been checked so that its check monad is Identity, it
310-- can be used to actually encode by using this. Note that while there's no constraint on the parse monad here,
309-- can be used to actually encode by using this. Note that while there's no constraint on the parse monad here,
311-- one should usually be applying decode and encode to the same 'Encoder'
310-- one should usually be applying decode and encode to the same 'Encoder'
312encode :: Encoder Identity parse decoded encoded -> decoded -> encoded
311encode :: Encoder Identity parse decoded encoded -> decoded -> encoded
313−encode (Encoder (Identity impl)) = _encoderImpl_encode impl
312+encode (Encoder (Identity impl)) x = _encoderImpl_encode impl x
315-- | This is a primitive used to build encoders which can't fail to check. It should not be used unless one is
314-- | This is a primitive used to build encoders which can't fail to check. It should not be used unless one is
316-- reasonably certain that the law given for 'EncoderImpl' above holds.
315-- reasonably certain that the law given for 'EncoderImpl' above holds.
@@ -555,11 +554,11 @@ pathComponentEncoder f = Encoder $ do
555 unEncoder (pathComponentEncoderImpl (enum1Encoder (extractPathSegment . f)) f')
554 unEncoder (pathComponentEncoderImpl (enum1Encoder (extractPathSegment . f)) f')
557pathComponentEncoderImpl :: forall check parse p. (Monad check, Monad parse)
556pathComponentEncoderImpl :: forall check parse p. (Monad check, Monad parse)
558− => Encoder check parse (Some p) (Maybe Text)
557+ => (Encoder check parse (Some p) (Maybe Text))
559 -> (forall a. p a -> Encoder Identity parse a PageName)
558 -> (forall a. p a -> Encoder Identity parse a PageName)
560 -> Encoder check parse (R p) PageName
559 -> Encoder check parse (R p) PageName
561−pathComponentEncoderImpl =
560+pathComponentEncoderImpl this rest =
562− chainEncoder (lensEncoder (\(_, b) a -> (a, b)) Prelude.fst consEncoder)
561+ chainEncoder (lensEncoder (\(_, b) a -> (a, b)) Prelude.fst consEncoder) this rest
564--NOTE: Naming convention in this module is to always talk about things in the *encoding* direction, never in the *decoding* direction
563--NOTE: Naming convention in this module is to always talk about things in the *encoding* direction, never in the *decoding* direction
@@ -815,7 +814,7 @@ rPrism
815 :: forall f f'
814 :: forall f f'
816 . (forall a. Prism' (f a) (f' a))
815 . (forall a. Prism' (f a) (f' a))
817 -> Prism' (R f) (R f')
816 -> Prism' (R f) (R f')
818−rPrism = dSumPrism
817+rPrism p = dSumPrism p
820dSumPrism'
819dSumPrism'
821 :: forall f g a
820 :: forall f g a
@@ -827,7 +826,7 @@ dSumGEqPrism
829 -> Prism' (DSum f g) (g a)
828 -> Prism' (DSum f g) (g a)
830−dSumGEqPrism variant = dSumPrism' $ prism' (\Refl -> variant) (geq variant)
829+dSumGEqPrism variant = dSumPrism' $ prism' (\Refl -> variant) (\x -> geq variant x)
832-- | Given a 'tag :: f a', make a prism for 'R f'. This generalizes the usual
831-- | Given a 'tag :: f a', make a prism for 'R f'. This generalizes the usual
833-- prisms for a sum type (the ones that 'mkPrisms' would make), just as 'R'
832-- prisms for a sum type (the ones that 'mkPrisms' would make), just as 'R'
@@ -994,9 +993,9 @@ obeliskRouteSegment r appRouteSegment = case r of
994-- be combined with other such segment encoders before 'pathComponentEncoder' turns it into a proper 'Encoder'.
993-- be combined with other such segment encoders before 'pathComponentEncoder' turns it into a proper 'Encoder'.
995resourceRouteSegment :: (MonadError Text check, MonadError Text parse) => ResourceRoute a -> SegmentResult check parse a
994resourceRouteSegment :: (MonadError Text check, MonadError Text parse) => ResourceRoute a -> SegmentResult check parse a
996resourceRouteSegment = \case
995resourceRouteSegment = \case
997− ResourceRoute_Static -> PathSegment "static" pathOnlyEncoderIgnoringQuery
996+ ResourceRoute_Static -> PathSegment "static" $ pathOnlyEncoderIgnoringQuery
998− ResourceRoute_Ghcjs -> PathSegment "ghcjs" pathOnlyEncoder
997+ ResourceRoute_Ghcjs -> PathSegment "ghcjs" $ pathOnlyEncoder
999− ResourceRoute_JSaddleWarp -> PathSegment "jsaddle" jsaddleWarpRouteEncoder
998+ ResourceRoute_JSaddleWarp -> PathSegment "jsaddle" $ jsaddleWarpRouteEncoder
1000 ResourceRoute_Version -> PathSegment "version" $ unitEncoder mempty
999 ResourceRoute_Version -> PathSegment "version" $ unitEncoder mempty
1002data JSaddleWarpRoute :: * -> * where
1001data JSaddleWarpRoute :: * -> * where
@@ -1008,7 +1007,7 @@ jsaddleWarpRouteEncoder :: (MonadError Text check, MonadError Text parse) => Enc
1008jsaddleWarpRouteEncoder = pathComponentEncoder $ \case
1007jsaddleWarpRouteEncoder = pathComponentEncoder $ \case
1009 JSaddleWarpRoute_JavaScript -> PathSegment "jsaddle.js" $ unitEncoder mempty
1008 JSaddleWarpRoute_JavaScript -> PathSegment "jsaddle.js" $ unitEncoder mempty
1010 JSaddleWarpRoute_WebSocket -> PathEnd $ unitEncoder mempty
1009 JSaddleWarpRoute_WebSocket -> PathEnd $ unitEncoder mempty
1011− JSaddleWarpRoute_Sync -> PathSegment "sync" pathOnlyEncoder
1010+ JSaddleWarpRoute_Sync -> PathSegment "sync" $ pathOnlyEncoder
1013instance GShow appRoute => GShow (ObeliskRoute appRoute) where
1012instance GShow appRoute => GShow (ObeliskRoute appRoute) where
1014 gshowsPrec prec = \case
1013 gshowsPrec prec = \case
@@ -1039,8 +1038,8 @@ someSumEncoder = Encoder $ pure $ EncoderImpl
1040data Void1 :: * -> * where {}
1039data Void1 :: * -> * where {}
1042−instance UniverseSome Void1 where
1041+instance Universe (Some Void1) where
1043− universeSome = []
1042+ universe = []
1045void1Encoder :: (Applicative check, MonadError Text parse) => Encoder check parse (Some Void1) a
1044void1Encoder :: (Applicative check, MonadError Text parse) => Encoder check parse (Some Void1) a
1046void1Encoder = Encoder $ pure $ EncoderImpl
1045void1Encoder = Encoder $ pure $ EncoderImpl
@@ -1084,7 +1083,7 @@ readShowEncoder :: (MonadError Text parse, Read a, Show a, Applicative check) =>
1084readShowEncoder = singlePathSegmentEncoder . unsafeTshowEncoder
1083readShowEncoder = singlePathSegmentEncoder . unsafeTshowEncoder
1086integralEncoder :: (MonadError Text parse, Applicative check, Integral a) => Encoder check parse a Integer
1085integralEncoder :: (MonadError Text parse, Applicative check, Integral a) => Encoder check parse a Integer
1087−integralEncoder = reviewEncoder Numeric.Lens.integral
1086+integralEncoder = reviewEncoder (Numeric.Lens.integral)
1089pathSegmentEncoder :: (MonadError Text parse, Applicative check, Cons as as a a) =>
1088pathSegmentEncoder :: (MonadError Text parse, Applicative check, Cons as as a a) =>
1090 Encoder check parse (a, (as, b)) (as, b)
1089 Encoder check parse (a, (as, b)) (as, b)
@@ -1159,7 +1158,7 @@ pathFieldEncoder fieldEncoder = unsafeEncoder $ do
1159 fieldEncoderPure f = toEncoder (DMap.findWithDefault (error "bad") f fieldEncoderPureMap)
1158 fieldEncoderPure f = toEncoder (DMap.findWithDefault (error "bad") f fieldEncoderPureMap)
1160 pure $ EncoderImpl
1159 pure $ EncoderImpl
1161 { _encoderImpl_encode = \(x, rest) -> execWriter $ do
1160 { _encoderImpl_encode = \(x, rest) -> execWriter $ do
1162− _ <- traverseWithField (\f x_i -> tell (pure $ encode (fieldEncoderPure f) x_i) $> x_i) x
1161+ _ <- traverseWithField (\f x_i -> tell (pure $ encode (fieldEncoderPure f) x_i) *> pure x_i) x
1163 tell rest
1162 tell rest
1164 , _encoderImpl_decode = State.runStateT $ tabulateFieldsA $ \f -> State.get >>= \case
1163 , _encoderImpl_decode = State.runStateT $ tabulateFieldsA $ \f -> State.get >>= \case
1165 [] -> throwError $ T.pack "not enough path components"
1164 [] -> throwError $ T.pack "not enough path components"