@@ -13,6 +13,7 @@
1313{-# LANGUAGE RankNTypes #-}
1414{-# LANGUAGE ScopedTypeVariables #-}
1515{-# LANGUAGE TemplateHaskell #-}
16+{-# LANGUAGE TypeApplications #-}
1617{-# LANGUAGE TypeFamilies #-}
1718{-# LANGUAGE TypeOperators #-}
1819{-# LANGUAGE ViewPatterns #-}
@@ -85,6 +86,11 @@ module Obelisk.Route
8586 , readShowEncoder
8687 , integralEncoder
8788 , pathSegmentEncoder
89+ , queryOnlyEncoder
90+ , Decoder(..)
91+ , dmapEncoder
92+ , fieldMapEncoder
93+ , jsonEncoder
8894 ) where
8995
9096import Prelude hiding ((.), id)
@@ -97,6 +103,7 @@ import Control.Category.Associative
97103import Control.Category.Monoidal
98104import Control.Lens (Identity (..), Prism', makePrisms, itraverse, imap, prism, (^.), re, matching, (^?), _Just, _Nothing, Iso', from, view, Wrapped (..))
99105import Control.Monad.Except
106+import qualified Data.ByteString.Lazy as BSL
100107import Data.Dependent.Sum (DSum (..))
101108import Data.Dependent.Map (DMap)
102109import qualified Data.Dependent.Map as DMap
@@ -113,17 +120,19 @@ import Data.Maybe
113120import Data.Monoid ((<>))
114121import Data.Set (Set)
115122import qualified Data.Set as Set
116−import Data.Some (Some)
117−import qualified Data.Some as Some
118−import Data.Some.Universe.Orphans ()
123+import Data.Some (Some(Some))
119124import Data.Text (Text)
120125import qualified Data.Text as T
121−import Data.Text.Encoding
126+import qualified Data.Text.Encoding as T
122127import Data.Universe
128+import Data.Universe.Some
123129import Network.HTTP.Types.URI
124130import qualified Numeric.Lens
125131import Obelisk.Route.TH
126132import Text.Read (readMaybe)
133+import Data.Tabulation
134+import qualified Data.Aeson as Aeson
135+import Data.Aeson (FromJSON, ToJSON)
127136
128137-- Design goals:
129138-- No start-up time on the frontend (not yet met)
@@ -155,7 +164,7 @@ pattern (:/) :: f a -> a -> R f
155164pattern a :/ b = a :=> Identity b
156165
157166mapSome :: (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
159168
160169hoistR :: (forall x. f x -> g x) -> R f -> R g
161170hoistR f (x :=> Identity y) = f x :/ y
@@ -193,7 +202,7 @@ decode e x = runIdentity (tryDecode e x)
193202tryDecode :: Encoder Identity parse decoded encoded -> encoded -> parse decoded
194203tryDecode (Encoder (Identity impl)) x = _encoderImpl_decode impl x
195204
196−-- | Similar to 'decode' above, once an encoder has been checked so that its check monad is Identity, it
205+-- | Similar to 'decode', once an encoder has been checked so that its check monad is Identity, it
197206-- can be used to actually encode by using this. Note that while there's no constraint on the parse monad here,
198207-- one should usually be applying decode and encode to the same 'Encoder'
199208encode :: Encoder Identity parse decoded encoded -> decoded -> encoded
@@ -343,14 +352,14 @@ maybeEncoder f g = shadowEncoder f g . maybeToEitherEncoder
343352justEncoder :: (Applicative check, MonadError Text parse) => Encoder check parse a (Maybe a)
344353justEncoder = prismEncoder _Just
345354
346−-- |
355+-- | Encode () to 'Nothing'.
347356nothingEncoder :: (Applicative check, MonadError Text parse) => Encoder check parse () (Maybe a)
348357nothingEncoder = prismEncoder _Nothing
349358
350359someConstEncoder :: (Applicative check, Applicative parse) => Encoder check parse (Some (Const a)) a
351360someConstEncoder = unsafeMkEncoder $ EncoderImpl
352− { _encoderImpl_encode = \(Some.This (Const a)) -> a
353− , _encoderImpl_decode = pure . Some.This . Const
361+ { _encoderImpl_encode = \(Some (Const a)) -> a
362+ , _encoderImpl_decode = pure . Some . Const
354363 }
355364
356365-- | WARNING: This is only safe if the Show and Read instances for 'a' are
@@ -378,7 +387,7 @@ checkEnum1EncoderFunc
378387 -> check (EncoderFunc check' parse p r)
379388checkEnum1EncoderFunc f = do
380389 (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
382391 pure $ EncoderFunc $ \p -> unsafeMkEncoder . unFlip $
383392 DMap.findWithDefault (error "checkEnum1EncoderFunc: EncoderImpl not found (should be impossible)") p encoderImpls
384393
@@ -433,11 +442,11 @@ chainEncoder cons this rest = Encoder $ do
433442 pure $ EncoderImpl
434443 { _encoderImpl_decode = \v -> do
435444 (here, following) <- _encoderImpl_decode consValid v
436− Some.This r <- _encoderImpl_decode thisValid here
445+ Some r <- _encoderImpl_decode thisValid here
437446 (r :/) <$> _encoderImpl_decode (runIdentity . unEncoder $ rest r) following
438447 , _encoderImpl_encode = \(r :/ s) ->
439448 _encoderImpl_encode consValid
440− ( _encoderImpl_encode thisValid $ Some.This r
449+ ( _encoderImpl_encode thisValid $ Some r
441450 , _encoderImpl_encode (runIdentity . unEncoder $ rest r) s)
442451 }
443452
@@ -504,7 +513,7 @@ enum1Encoder
504513 , Show r
505514 )
506515 => (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
508517
509518-- | Encode an enumerable, bounded type. WARNING: Don't use this on types that
510519-- have a large number of values - it will use a lot of memory.
@@ -547,13 +556,10 @@ pathOnlyEncoderIgnoringQuery = unsafeMkEncoder $ EncoderImpl
547556 }
548557
549558pathOnlyEncoder :: (Applicative check, MonadError Text parse) => Encoder check parse [Text] PageName
550−pathOnlyEncoder = unsafeMkEncoder $ EncoderImpl
551− { _encoderImpl_decode = \(path, query) ->
552− if query == mempty
553− then pure path
554− else throwError "pathOnlyEncoderImpl: query was provided"
555− , _encoderImpl_encode = \path -> (path, mempty)
556− }
559+pathOnlyEncoder = second (unitEncoder mempty) . coidr
560+
561+queryOnlyEncoder :: (Applicative check, MonadError Text parse) => Encoder check parse (Map Text (Maybe Text)) PageName
562+queryOnlyEncoder = first (unitEncoder []) . coidl
557563
558564singletonListEncoder :: (Applicative check, MonadError Text parse) => Encoder check parse a [a]
559565singletonListEncoder = unsafeMkEncoder $ EncoderImpl
@@ -596,10 +602,10 @@ queryParametersTextEncoder = Encoder $ pure $ EncoderImpl
596602 in (urlDecodeText True k, urlDecodeText True <$> mv)
597603
598604urlEncodeText :: Bool -> Text -> Text
599−urlEncodeText q = decodeUtf8 . urlEncode q . encodeUtf8
605+urlEncodeText q = T.decodeUtf8 . urlEncode q . T.encodeUtf8
600606
601607urlDecodeText :: Bool -> Text -> Text
602−urlDecodeText q = decodeUtf8 . urlDecode q . encodeUtf8
608+urlDecodeText q = T.decodeUtf8 . urlDecode q . T.encodeUtf8
603609
604610listToNonEmptyEncoder :: (Applicative check, Applicative parse, Monoid a, Eq a) => Encoder check parse [a] (NonEmpty a)
605611listToNonEmptyEncoder = Encoder $ pure $ EncoderImpl
@@ -711,9 +717,11 @@ data ObeliskRoute :: (* -> *) -> * -> * where
711717 ObeliskRoute_App :: f a -> ObeliskRoute f a
712718 ObeliskRoute_Resource :: ResourceRoute a -> ObeliskRoute f a
713719
714−instance Universe (Some f) => Universe (Some (ObeliskRoute f)) where
715− universe = fmap (\(Some.This x) -> Some.This (ObeliskRoute_App x)) universe
716− ++ fmap (\(Some.This x) -> Some.This (ObeliskRoute_Resource x)) universe
720+instance UniverseSome f => UniverseSome (ObeliskRoute f) where
721+ universeSome = concat
722+ [ (\(Some x) -> Some (ObeliskRoute_App x)) <$> universe
723+ , (\(Some x) -> Some (ObeliskRoute_Resource x)) <$> universe
724+ ]
717725
718726instance GEq f => GEq (ObeliskRoute f) where
719727 geq (ObeliskRoute_App x) (ObeliskRoute_App y) = geq x y
@@ -801,12 +809,12 @@ indexOnlyRouteEncoder = pathComponentEncoder indexOnlyRouteSegment
801809
802810someSumEncoder :: (Applicative check, Applicative parse) => Encoder check parse (Some (Sum a b)) (Either (Some a) (Some b))
803811someSumEncoder = Encoder $ pure $ EncoderImpl
804− { _encoderImpl_encode = \(Some.This t) -> case t of
805− InL l -> Left $ Some.This l
806− InR r -> Right $ Some.This r
812+ { _encoderImpl_encode = \(Some t) -> case t of
813+ InL l -> Left $ Some l
814+ InR r -> Right $ Some r
807815 , _encoderImpl_decode = pure . \case
808− Left (Some.This l) -> Some.This (InL l)
809− Right (Some.This r) -> Some.This (InR r)
816+ Left (Some l) -> Some (InL l)
817+ Right (Some r) -> Some (InR r)
810818 }
811819
812820data Void1 :: * -> * where {}
@@ -817,7 +825,7 @@ instance Universe (Some Void1) where
817825void1Encoder :: (Applicative check, MonadError Text parse) => Encoder check parse (Some Void1) a
818826void1Encoder = Encoder $ pure $ EncoderImpl
819827 { _encoderImpl_encode = \case
820− Some.This f -> case f of {}
828+ Some f -> case f of {}
821829 , _encoderImpl_decode = \_ -> throwError "void1Encoder: can't decode anything"
822830 }
823831
@@ -866,7 +874,6 @@ renderObeliskRoute e r =
866874readShowEncoder :: (MonadError Text parse, Read a, Show a, Applicative check) => Encoder check parse a PageName
867875readShowEncoder = singlePathSegmentEncoder . unsafeTshowEncoder
868876
869−
870877integralEncoder :: (MonadError Text parse, Applicative check, Integral a) => Encoder check parse a Integer
871878integralEncoder = prismEncoder (Numeric.Lens.integral)
872879
@@ -879,4 +886,72 @@ pathSegmentEncoder = unsafeMkEncoder EncoderImpl
879886 (x:xs) -> pure (x, (xs, y))
880887 }
881888
889+newtype Decoder check parse b a = Decoder { toEncoder :: Encoder check parse a b }
890+
891+dmapEncoder :: forall check parse k k' v.
892+ ( Monad check
893+ , MonadError Text parse
894+ , Universe (Some k')
895+ , Ord k
896+ , GCompare k'
897+ , GShow k'
898+ )
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'
913+ )
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
919+ v' <- tryDecode e v
920+ return (k' :=> Identity v')
921+ }
922+
923+fieldMapEncoder :: forall check parse r.
924+ ( Applicative check
925+ , MonadError Text parse
926+ , HasFields r
927+ , Universe (Some (Field r))
928+ , GShow (Field r)
929+ , GCompare (Field r)
930+ )
931+ => Encoder check parse r (DMap (Field r) Identity)
932+fieldMapEncoder = unsafeEncoder $ do
933+ pure $ EncoderImpl
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
939+ }
940+
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.
943+ ( ToJSON r
944+ , FromJSON r
945+ , Applicative check
946+ , MonadError Text parse
947+ )
948+ => Encoder check parse r Text
949+jsonEncoder = unsafeEncoder $ do
950+ pure $ EncoderImpl
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)
954+ Right x -> return x
955+ }
956+
882957--TODO: decodeURIComponent as appropriate