@@ -13,6 +13,7 @@
13{-# LANGUAGE RankNTypes #-}
13{-# LANGUAGE RankNTypes #-}
14{-# LANGUAGE ScopedTypeVariables #-}
14{-# LANGUAGE ScopedTypeVariables #-}
15{-# LANGUAGE TemplateHaskell #-}
15{-# LANGUAGE TemplateHaskell #-}
16+{-# LANGUAGE TypeApplications #-}
16{-# LANGUAGE TypeFamilies #-}
17{-# LANGUAGE TypeFamilies #-}
17{-# LANGUAGE TypeOperators #-}
18{-# LANGUAGE TypeOperators #-}
18{-# LANGUAGE ViewPatterns #-}
19{-# LANGUAGE ViewPatterns #-}
@@ -85,6 +86,11 @@ module Obelisk.Route
85 , readShowEncoder
86 , readShowEncoder
86 , integralEncoder
87 , integralEncoder
87 , pathSegmentEncoder
88 , pathSegmentEncoder
90import Prelude hiding ((.), id)
96import Prelude hiding ((.), id)
@@ -97,6 +103,7 @@ import Control.Category.Associative
97import Control.Category.Monoidal
103import Control.Category.Monoidal
98import Control.Lens (Identity (..), Prism', makePrisms, itraverse, imap, prism, (^.), re, matching, (^?), _Just, _Nothing, Iso', from, view, Wrapped (..))
104import Control.Lens (Identity (..), Prism', makePrisms, itraverse, imap, prism, (^.), re, matching, (^?), _Just, _Nothing, Iso', from, view, Wrapped (..))
99import Control.Monad.Except
105import Control.Monad.Except
106+import qualified Data.ByteString.Lazy as BSL
100import Data.Dependent.Sum (DSum (..))
107import Data.Dependent.Sum (DSum (..))
101import Data.Dependent.Map (DMap)
108import Data.Dependent.Map (DMap)
102import qualified Data.Dependent.Map as DMap
109import qualified Data.Dependent.Map as DMap
@@ -113,17 +120,19 @@ import Data.Maybe
113import Data.Monoid ((<>))
120import Data.Monoid ((<>))
114import Data.Set (Set)
121import Data.Set (Set)
115import qualified Data.Set as Set
122import qualified Data.Set as Set
116−import Data.Some (Some)
123+import Data.Some (Some(Some))
117−import qualified Data.Some as Some
118−import Data.Some.Universe.Orphans ()
119import Data.Text (Text)
124import Data.Text (Text)
120import qualified Data.Text as T
125import qualified Data.Text as T
121−import Data.Text.Encoding
126+import qualified Data.Text.Encoding as T
122import Data.Universe
127import Data.Universe
128+import Data.Universe.Some
123import Network.HTTP.Types.URI
129import Network.HTTP.Types.URI
124import qualified Numeric.Lens
130import qualified Numeric.Lens
125import Obelisk.Route.TH
131import Obelisk.Route.TH
126import Text.Read (readMaybe)
132import Text.Read (readMaybe)
133+import Data.Tabulation
134+import qualified Data.Aeson as Aeson
135+import Data.Aeson (FromJSON, ToJSON)
128-- Design goals:
137-- Design goals:
129-- No start-up time on the frontend (not yet met)
138-- No start-up time on the frontend (not yet met)
@@ -149,13 +158,13 @@ import Text.Read (readMaybe)
150type R f = DSum f Identity --TODO: Better name
159type R f = DSum f Identity --TODO: Better name
152−--TODO: COMPLETE pragma
161+{-# COMPLETE (:/) #-}
153infixr 5 :/
162infixr 5 :/
154pattern (:/) :: f a -> a -> R f
163pattern (:/) :: f a -> a -> R f
155pattern a :/ b = a :=> Identity b
164pattern a :/ b = a :=> Identity b
157mapSome :: (forall a. f a -> g a) -> Some f -> Some g
166mapSome :: (forall a. f a -> g a) -> Some f -> Some g
158−mapSome f (Some.This a) = Some.This $ f a
167+mapSome f (Some a) = Some $ f a
160hoistR :: (forall x. f x -> g x) -> R f -> R g
169hoistR :: (forall x. f x -> g x) -> R f -> R g
161hoistR f (x :=> Identity y) = f x :/ y
170hoistR f (x :=> Identity y) = f x :/ y
@@ -343,14 +352,14 @@ maybeEncoder f g = shadowEncoder f g . maybeToEitherEncoder
343justEncoder :: (Applicative check, MonadError Text parse) => Encoder check parse a (Maybe a)
352justEncoder :: (Applicative check, MonadError Text parse) => Encoder check parse a (Maybe a)
344justEncoder = prismEncoder _Just
353justEncoder = prismEncoder _Just
346−-- |
355+-- | Encode () to 'Nothing'.
347nothingEncoder :: (Applicative check, MonadError Text parse) => Encoder check parse () (Maybe a)
356nothingEncoder :: (Applicative check, MonadError Text parse) => Encoder check parse () (Maybe a)
348nothingEncoder = prismEncoder _Nothing
357nothingEncoder = prismEncoder _Nothing
350someConstEncoder :: (Applicative check, Applicative parse) => Encoder check parse (Some (Const a)) a
359someConstEncoder :: (Applicative check, Applicative parse) => Encoder check parse (Some (Const a)) a
351someConstEncoder = unsafeMkEncoder $ EncoderImpl
360someConstEncoder = unsafeMkEncoder $ EncoderImpl
352− { _encoderImpl_encode = \(Some.This (Const a)) -> a
361+ { _encoderImpl_encode = \(Some (Const a)) -> a
353− , _encoderImpl_decode = pure . Some.This . Const
362+ , _encoderImpl_decode = pure . Some . Const
356-- | WARNING: This is only safe if the Show and Read instances for 'a' are
365-- | WARNING: This is only safe if the Show and Read instances for 'a' are
@@ -378,7 +387,7 @@ checkEnum1EncoderFunc
378 -> check (EncoderFunc check' parse p r)
387 -> check (EncoderFunc check' parse p r)
379checkEnum1EncoderFunc f = do
388checkEnum1EncoderFunc f = do
380 (encoderImpls :: DMap p (Flip (EncoderImpl parse) r)) <- DMap.fromList <$>
389 (encoderImpls :: DMap p (Flip (EncoderImpl parse) r)) <- DMap.fromList <$>
381− traverse (\(Some.This p) -> (p :=>) . Flip <$> unEncoder (f p)) universe
390+ traverse (\(Some p) -> (p :=>) . Flip <$> unEncoder (f p)) universe
382 pure $ EncoderFunc $ \p -> unsafeMkEncoder . unFlip $
391 pure $ EncoderFunc $ \p -> unsafeMkEncoder . unFlip $
383 DMap.findWithDefault (error "checkEnum1EncoderFunc: EncoderImpl not found (should be impossible)") p encoderImpls
392 DMap.findWithDefault (error "checkEnum1EncoderFunc: EncoderImpl not found (should be impossible)") p encoderImpls
@@ -433,11 +442,11 @@ chainEncoder cons this rest = Encoder $ do
433 pure $ EncoderImpl
442 pure $ EncoderImpl
434 { _encoderImpl_decode = \v -> do
443 { _encoderImpl_decode = \v -> do
435 (here, following) <- _encoderImpl_decode consValid v
444 (here, following) <- _encoderImpl_decode consValid v
436− Some.This r <- _encoderImpl_decode thisValid here
445+ Some r <- _encoderImpl_decode thisValid here
437 (r :/) <$> _encoderImpl_decode (runIdentity . unEncoder $ rest r) following
446 (r :/) <$> _encoderImpl_decode (runIdentity . unEncoder $ rest r) following
438 , _encoderImpl_encode = \(r :/ s) ->
447 , _encoderImpl_encode = \(r :/ s) ->
439 _encoderImpl_encode consValid
448 _encoderImpl_encode consValid
440− ( _encoderImpl_encode thisValid $ Some.This r
449+ ( _encoderImpl_encode thisValid $ Some r
441 , _encoderImpl_encode (runIdentity . unEncoder $ rest r) s)
450 , _encoderImpl_encode (runIdentity . unEncoder $ rest r) s)
@@ -504,7 +513,7 @@ enum1Encoder
506 => (forall a. p a -> r) -> Encoder check parse (Some p) r
515 => (forall a. p a -> r) -> Encoder check parse (Some p) r
507−enum1Encoder f = enumEncoder $ \(Some.This p) -> f p
516+enum1Encoder f = enumEncoder $ \(Some p) -> f p
509-- | Encode an enumerable, bounded type. WARNING: Don't use this on types that
518-- | Encode an enumerable, bounded type. WARNING: Don't use this on types that
510-- have a large number of values - it will use a lot of memory.
519-- have a large number of values - it will use a lot of memory.
@@ -547,13 +556,10 @@ pathOnlyEncoderIgnoringQuery = unsafeMkEncoder $ EncoderImpl
549pathOnlyEncoder :: (Applicative check, MonadError Text parse) => Encoder check parse [Text] PageName
558pathOnlyEncoder :: (Applicative check, MonadError Text parse) => Encoder check parse [Text] PageName
550−pathOnlyEncoder = unsafeMkEncoder $ EncoderImpl
559+pathOnlyEncoder = second (unitEncoder mempty) . coidr
551− { _encoderImpl_decode = \(path, query) ->
560+
552− if query == mempty
561+queryOnlyEncoder :: (Applicative check, MonadError Text parse) => Encoder check parse (Map Text (Maybe Text)) PageName
553− then pure path
562+queryOnlyEncoder = first (unitEncoder []) . coidl
554− else throwError "pathOnlyEncoderImpl: query was provided"
555− , _encoderImpl_encode = \path -> (path, mempty)
558singletonListEncoder :: (Applicative check, MonadError Text parse) => Encoder check parse a [a]
564singletonListEncoder :: (Applicative check, MonadError Text parse) => Encoder check parse a [a]
559singletonListEncoder = unsafeMkEncoder $ EncoderImpl
565singletonListEncoder = unsafeMkEncoder $ EncoderImpl
@@ -596,10 +602,10 @@ queryParametersTextEncoder = Encoder $ pure $ EncoderImpl
596 in (urlDecodeText True k, urlDecodeText True <$> mv)
602 in (urlDecodeText True k, urlDecodeText True <$> mv)
598urlEncodeText :: Bool -> Text -> Text
604urlEncodeText :: Bool -> Text -> Text
599−urlEncodeText q = decodeUtf8 . urlEncode q . encodeUtf8
605+urlEncodeText q = T.decodeUtf8 . urlEncode q . T.encodeUtf8
601urlDecodeText :: Bool -> Text -> Text
607urlDecodeText :: Bool -> Text -> Text
602−urlDecodeText q = decodeUtf8 . urlDecode q . encodeUtf8
608+urlDecodeText q = T.decodeUtf8 . urlDecode q . T.encodeUtf8
604listToNonEmptyEncoder :: (Applicative check, Applicative parse, Monoid a, Eq a) => Encoder check parse [a] (NonEmpty a)
610listToNonEmptyEncoder :: (Applicative check, Applicative parse, Monoid a, Eq a) => Encoder check parse [a] (NonEmpty a)
605listToNonEmptyEncoder = Encoder $ pure $ EncoderImpl
611listToNonEmptyEncoder = Encoder $ pure $ EncoderImpl
@@ -711,9 +717,11 @@ data ObeliskRoute :: (* -> *) -> * -> * where
711 ObeliskRoute_App :: f a -> ObeliskRoute f a
717 ObeliskRoute_App :: f a -> ObeliskRoute f a
712 ObeliskRoute_Resource :: ResourceRoute a -> ObeliskRoute f a
718 ObeliskRoute_Resource :: ResourceRoute a -> ObeliskRoute f a
714−instance Universe (Some f) => Universe (Some (ObeliskRoute f)) where
720+instance UniverseSome f => UniverseSome (ObeliskRoute f) where
721+ universeSome = concat
715− universe = fmap (\(Some.This x) -> Some.This (ObeliskRoute_App x)) universe
722+ [ (\(Some x) -> Some (ObeliskRoute_App x)) <$> universe
716− ++ fmap (\(Some.This x) -> Some.This (ObeliskRoute_Resource x)) universe
723+ , (\(Some x) -> Some (ObeliskRoute_Resource x)) <$> universe
718instance GEq f => GEq (ObeliskRoute f) where
726instance GEq f => GEq (ObeliskRoute f) where
719 geq (ObeliskRoute_App x) (ObeliskRoute_App y) = geq x y
727 geq (ObeliskRoute_App x) (ObeliskRoute_App y) = geq x y
@@ -801,12 +809,12 @@ indexOnlyRouteEncoder = pathComponentEncoder indexOnlyRouteSegment
802someSumEncoder :: (Applicative check, Applicative parse) => Encoder check parse (Some (Sum a b)) (Either (Some a) (Some b))
810someSumEncoder :: (Applicative check, Applicative parse) => Encoder check parse (Some (Sum a b)) (Either (Some a) (Some b))
803someSumEncoder = Encoder $ pure $ EncoderImpl
811someSumEncoder = Encoder $ pure $ EncoderImpl
804− { _encoderImpl_encode = \(Some.This t) -> case t of
812+ { _encoderImpl_encode = \(Some t) -> case t of
805− InL l -> Left $ Some.This l
813+ InL l -> Left $ Some l
806− InR r -> Right $ Some.This r
814+ InR r -> Right $ Some r
807 , _encoderImpl_decode = pure . \case
815 , _encoderImpl_decode = pure . \case
808− Left (Some.This l) -> Some.This (InL l)
816+ Left (Some l) -> Some (InL l)
809− Right (Some.This r) -> Some.This (InR r)
817+ Right (Some r) -> Some (InR r)
812data Void1 :: * -> * where {}
820data Void1 :: * -> * where {}
@@ -817,7 +825,7 @@ instance Universe (Some Void1) where
817void1Encoder :: (Applicative check, MonadError Text parse) => Encoder check parse (Some Void1) a
825void1Encoder :: (Applicative check, MonadError Text parse) => Encoder check parse (Some Void1) a
818void1Encoder = Encoder $ pure $ EncoderImpl
826void1Encoder = Encoder $ pure $ EncoderImpl
819 { _encoderImpl_encode = \case
827 { _encoderImpl_encode = \case
820− Some.This f -> case f of {}
828+ Some f -> case f of {}
821 , _encoderImpl_decode = \_ -> throwError "void1Encoder: can't decode anything"
829 , _encoderImpl_decode = \_ -> throwError "void1Encoder: can't decode anything"
@@ -866,7 +874,6 @@ renderObeliskRoute e r =
866readShowEncoder :: (MonadError Text parse, Read a, Show a, Applicative check) => Encoder check parse a PageName
874readShowEncoder :: (MonadError Text parse, Read a, Show a, Applicative check) => Encoder check parse a PageName
867readShowEncoder = singlePathSegmentEncoder . unsafeTshowEncoder
875readShowEncoder = singlePathSegmentEncoder . unsafeTshowEncoder
870integralEncoder :: (MonadError Text parse, Applicative check, Integral a) => Encoder check parse a Integer
877integralEncoder :: (MonadError Text parse, Applicative check, Integral a) => Encoder check parse a Integer
871integralEncoder = prismEncoder (Numeric.Lens.integral)
878integralEncoder = prismEncoder (Numeric.Lens.integral)
@@ -879,4 +886,72 @@ pathSegmentEncoder = unsafeMkEncoder EncoderImpl
879 (x:xs) -> pure (x, (xs, y))
886 (x:xs) -> pure (x, (xs, y))
889+newtype Decoder check parse b a = Decoder { toEncoder :: Encoder check parse a b }
891+dmapEncoder :: forall check parse k k' v.
893+ , MonadError Text parse
894+ , Universe (Some k')
899+ => Encoder check parse (Some k') k
900+ -> (forall v'. k' v' -> Encoder check parse v' v)
901+ -> Encoder check parse (DMap k' Identity) (Map k v)
902+dmapEncoder keyEncoder' valueEncoderFor = unsafeEncoder $ do
903+ keyEncoder :: Encoder Identity parse (Some k') k <- checkEncoder keyEncoder'
904+ valueDecoders :: DMap k' (Decoder Identity parse v) <- fmap DMap.fromList . forM universe $ \(Some (k' :: k' t)) -> do
905+ ve :: Encoder Identity parse t v <- checkEncoder (valueEncoderFor k')
906+ return $ (k' :: k' t) :=> (Decoder ve :: Decoder Identity parse v t)
907+ let keyError k = "dmapEncoder: key `" <> k <> "' was missing from the Universe instance for its type."
908+ return $ EncoderImpl
909+ { _encoderImpl_encode = \dm -> Map.fromList $ do
910+ ((k' :: k' t) :=> Identity v') <- DMap.toList dm
911+ return ( encode keyEncoder (Some k')
912+ , encode (toEncoder (DMap.findWithDefault (error . keyError $ gshow k') k' valueDecoders)) v'
914+ , _encoderImpl_decode = \m -> fmap DMap.fromList . forM (Map.toList m) $ \(k,v) -> do
915+ Some (k' :: k' t) <- tryDecode keyEncoder k
916+ case DMap.lookup k' valueDecoders of
917+ Nothing -> throwError . T.pack . keyError $ gshow k'
918+ Just (Decoder e) -> do
920+ return (k' :=> Identity v')
923+fieldMapEncoder :: forall check parse r.
925+ , MonadError Text parse
927+ , Universe (Some (Field r))
929+ , GCompare (Field r)
931+ => Encoder check parse r (DMap (Field r) Identity)
932+fieldMapEncoder = unsafeEncoder $ do
934+ { _encoderImpl_encode = \r -> DMap.fromList [ f :=> Identity (indexField r f) | Some f <- universe ]
935+ , _encoderImpl_decode = \dm -> tabulateFieldsA $ \f -> do
936+ case DMap.lookup f dm of
937+ Nothing -> throwError $ "fieldMapEncoder: Couldn't find key for `" <> T.pack (gshow f) <> "' in DMap."
938+ Just (Identity v) -> return v
941+-- | Use ToJSON/FromJSON to encode to Text. The correctness of this encoder is dependent on the encoding being injective and round-tripping correctly.
942+jsonEncoder :: forall check parse r.
946+ , MonadError Text parse
948+ => Encoder check parse r Text
949+jsonEncoder = unsafeEncoder $ do
951+ { _encoderImpl_encode = \r -> T.decodeUtf8 . BSL.toStrict $ Aeson.encode r
952+ , _encoderImpl_decode = \t -> case Aeson.eitherDecodeStrict $ T.encodeUtf8 t of
953+ Left err -> throwError ("jsonEncoder: " <> T.pack err)
882--TODO: decodeURIComponent as appropriate
957--TODO: decodeURIComponent as appropriate