@@ -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,10 @@ module Obelisk.Route
8586 , readShowEncoder
8687 , integralEncoder
8788 , pathSegmentEncoder
89+ , queryOnlyEncoder
90+ , Decoder(..)
91+ , dmapEncoder
92+ , fieldMapEncoder
8893 ) where
8994
9095import Prelude hiding ((.), id)
@@ -124,6 +129,7 @@ import Network.HTTP.Types.URI
124129import qualified Numeric.Lens
125130import Obelisk.Route.TH
126131import Text.Read (readMaybe)
132+import Data.Tabulation
127133
128134-- Design goals:
129135-- No start-up time on the frontend (not yet met)
@@ -547,13 +553,10 @@ pathOnlyEncoderIgnoringQuery = unsafeMkEncoder $ EncoderImpl
547553 }
548554
549555pathOnlyEncoder :: (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− }
556+pathOnlyEncoder = second (unitEncoder mempty) . coidr
557+
558+queryOnlyEncoder :: (Applicative check, MonadError Text parse) => Encoder check parse (Map Text (Maybe Text)) PageName
559+queryOnlyEncoder = first (unitEncoder []) . coidl
557560
558561singletonListEncoder :: (Applicative check, MonadError Text parse) => Encoder check parse a [a]
559562singletonListEncoder = unsafeMkEncoder $ EncoderImpl
@@ -866,7 +869,6 @@ renderObeliskRoute e r =
866869readShowEncoder :: (MonadError Text parse, Read a, Show a, Applicative check) => Encoder check parse a PageName
867870readShowEncoder = singlePathSegmentEncoder . unsafeTshowEncoder
868871
869−
870872integralEncoder :: (MonadError Text parse, Applicative check, Integral a) => Encoder check parse a Integer
871873integralEncoder = prismEncoder (Numeric.Lens.integral)
872874
@@ -879,4 +881,56 @@ pathSegmentEncoder = unsafeMkEncoder EncoderImpl
879881 (x:xs) -> pure (x, (xs, y))
880882 }
881883
884+newtype Decoder check parse b a = Decoder { toEncoder :: Encoder check parse a b }
885+
886+dmapEncoder :: forall check parse k k' v.
887+ ( Monad check
888+ , MonadError Text parse
889+ , Universe (Some k')
890+ , Ord k
891+ , GCompare k'
892+ , GShow k'
893+ )
894+ => Encoder check parse (Some k') k
895+ -> (forall v'. k' v' -> Encoder check parse v' v)
896+ -> Encoder check parse (DMap k' Identity) (Map k v)
897+dmapEncoder keyEncoder' valueEncoderFor = unsafeEncoder $ do
898+ keyEncoder :: Encoder Identity parse (Some k') k <- checkEncoder keyEncoder'
899+ valueDecoders :: DMap k' (Decoder Identity parse v) <- fmap DMap.fromList . forM universe $ \(Some.This (k' :: k' t)) -> do
900+ ve :: Encoder Identity parse t v <- checkEncoder (valueEncoderFor k')
901+ return $ (k' :: k' t) :=> (Decoder ve :: Decoder Identity parse v t)
902+ let keyError k = "dmapEncoder: key `" <> k <> "' was missing from the Universe instance for its type."
903+ return $ EncoderImpl
904+ { _encoderImpl_encode = \dm -> Map.fromList $ do
905+ ((k' :: k' t) :=> Identity v') <- DMap.toList dm
906+ return ( encode keyEncoder (Some.This k')
907+ , encode (toEncoder (DMap.findWithDefault (error . keyError $ gshow k') k' valueDecoders)) v'
908+ )
909+ , _encoderImpl_decode = \m -> fmap DMap.fromList . forM (Map.toList m) $ \(k,v) -> do
910+ Some.This (k' :: k' t) <- tryDecode keyEncoder k
911+ case DMap.lookup k' valueDecoders of
912+ Nothing -> throwError . T.pack . keyError $ gshow k'
913+ Just (Decoder e) -> do
914+ v' <- tryDecode e v
915+ return (k' :=> Identity v')
916+ }
917+
918+fieldMapEncoder :: forall check parse r.
919+ ( Applicative check
920+ , MonadError Text parse
921+ , HasFields r
922+ , Universe (Some (Field r))
923+ , GShow (Field r)
924+ , GCompare (Field r)
925+ )
926+ => Encoder check parse r (DMap (Field r) Identity)
927+fieldMapEncoder = unsafeEncoder $ do
928+ pure $ EncoderImpl
929+ { _encoderImpl_encode = \r -> DMap.fromList [ f :=> Identity (indexField r f) | Some.This f <- universe ]
930+ , _encoderImpl_decode = \dm -> tabulateFieldsA $ \f -> do
931+ case DMap.lookup f dm of
932+ Nothing -> throwError $ "fieldMapEncoder: Couldn't find key for `" <> T.pack (gshow f) <> "' in DMap."
933+ Just (Identity v) -> return v
934+ }
935+
882936--TODO: decodeURIComponent as appropriate