Functora.Uri.FromQuery implemented using GHC.Generics

Author: functora

ghcjs/delivery-calculator/src/App/Types.hs

@@ -101,6 +101,7 @@ data St f = St
     stTheme :: Theme
   }
   deriving stock (Generic)
+  deriving (ToQuery) via GenericType (St f)
 
 deriving stock instance (Hkt f) => Eq (St f)
 

ghcjs/miso-functora/src/Functora/Miso/Prelude.hs

@@ -14,6 +14,7 @@ import Functora.Prelude as X hiding
     field,
   )
 import Functora.Rfc2397 as X
+import Functora.Uri as X
 import Miso as X hiding
   ( Key,
     Text,

pub/functora/functora.cabal

@@ -163,6 +163,7 @@ common pkg-uri
   hs-source-dirs: src/uri
   build-depends:
     , base
+    , containers
     , modern-uri
     , tomland
 
@@ -181,6 +182,7 @@ common pkg-cfg
     , modern-uri
     , optparse-applicative
     , tomland
+    , uri
 
 common pkg-web
   import:         pkg
@@ -316,6 +318,7 @@ library uri
   visibility:      public
   exposed-modules:
     Functora.Uri
+    Functora.Uri.FromQuery
     Functora.Uri.ToQuery
 
 library cfg
@@ -465,6 +468,7 @@ test-suite functora-test
       Functora.TagsOrphan
       Functora.Unicode
       Functora.Uri
+      Functora.Uri.FromQuery
       Functora.Uri.ToQuery
       Functora.Web
       Functora.WebOrphan

pub/functora/src/cfg/Functora/Cfg.hs

@@ -45,6 +45,7 @@ import qualified Data.ByteString.Lazy as BL
 import qualified Data.List.NonEmpty as NE
 import Functora.CfgOrphan as X ()
 import Functora.Prelude
+import Functora.Uri
 import qualified GHC.Generics as Generics
 import qualified Options.Applicative as Cli
 import Toml as X
@@ -216,6 +217,15 @@ newtype GenericType a = GenericType
   }
   deriving stock (Generic)
 
+instance
+  ( Generic a,
+    Typeable a,
+    GToQuery (Rep a)
+  ) =>
+  ToQuery (GenericType a)
+  where
+  toQuery = genericToQuery . unGenericType
+
 instance
   ( Generic a,
     Typeable a,

pub/functora/src/test/Functora/UriSpec.hs

@@ -14,6 +14,8 @@ data Foo = Foo
 
 instance ToQuery Foo
 
+instance FromQuery Foo
+
 mkSample :: (MonadThrow m) => m (Foo, [QueryParam])
 mkSample = do
   let bar = 123 :: Int
@@ -35,6 +37,7 @@ mkSample = do
 
 spec :: Spec
 spec = do
-  focus . it "ToQuery" $ do
+  it "ToQuery/FromQuery" $ do
     sample <- mkSample
     toQuery (fst sample) `shouldBe` snd sample
+    fromQuery (snd sample) `shouldBe` Just (fst sample)

pub/functora/src/uri/Functora/Uri.hs

@@ -1,3 +1,4 @@
 module Functora.Uri (module X) where
 
+import Functora.Uri.FromQuery as X
 import Functora.Uri.ToQuery as X

pub/functora/src/uri/Functora/Uri/FromQuery.hs

@@ -0,0 +1,138 @@
+{-# LANGUAGE CPP #-}
+
+module Functora.Uri.FromQuery
+  ( FromQuery (..),
+    GFromQuery (..),
+    genericFromQuery,
+    FromQueryField (..),
+    textFromQueryField,
+    readFromQueryField,
+  )
+where
+
+import qualified Data.Map as Map
+import Functora.Prelude
+import GHC.Generics hiding (from)
+import qualified GHC.Generics as G
+import Text.URI
+import qualified Toml
+#if defined(__GHCJS__) && defined(ghcjs_HOST_OS) && defined(wasi_HOST_OS)
+import Data.JSString (JSString)
+#endif
+
+data FromQueryException
+  = FromQueryMissingField (RText 'QueryKey)
+  | FromQueryInvalidField (RText 'QueryKey) (RText 'QueryValue)
+  deriving stock (Eq, Ord, Show, Data, Generic)
+
+instance Exception FromQueryException
+
+type QueryMap = Map (RText 'QueryKey) (RText 'QueryValue)
+
+toQueryMap :: [QueryParam] -> QueryMap
+toQueryMap =
+  foldl
+    ( \acc -> \case
+        QueryFlag k ->
+          Map.insert k (either impureThrow id $ mkQueryValue "True") acc
+        QueryParam k v ->
+          Map.insert k v acc
+    )
+    mempty
+
+class FromQuery a where
+  fromQuery ::
+    (MonadThrow m) => [QueryParam] -> m a
+  default fromQuery ::
+    (Generic a, GFromQuery (Rep a), MonadThrow m) => [QueryParam] -> m a
+  fromQuery =
+    genericFromQuery
+
+class GFromQuery f where
+  gFromQuery :: (MonadThrow m) => QueryMap -> m (f p)
+
+genericFromQuery ::
+  forall a m.
+  ( Generic a,
+    GFromQuery (Rep a),
+    MonadThrow m
+  ) =>
+  [QueryParam] ->
+  m a
+genericFromQuery =
+  fmap G.to . gFromQuery . toQueryMap
+
+instance (GFromQuery a) => GFromQuery (M1 D c a) where
+  gFromQuery params = M1 <$> gFromQuery params
+
+instance (GFromQuery a) => GFromQuery (M1 C c a) where
+  gFromQuery params = M1 <$> gFromQuery params
+
+instance
+  ( Typeable a,
+    Selector s,
+    FromQueryField a
+  ) =>
+  GFromQuery (M1 S s (K1 i a))
+  where
+  gFromQuery params = do
+    k <-
+      mkQueryKey
+        . pack
+        . Toml.stripTypeNamePrefix (Proxy @a)
+        $ selName (error "selName" :: M1 S s (K1 i a) ())
+    v <-
+      maybe (throw $ FromQueryMissingField k) pure $
+        Map.lookup k params
+    fmap (M1 . K1) $
+      fromQueryField k v
+
+instance (GFromQuery a, GFromQuery b) => GFromQuery (a :*: b) where
+  gFromQuery params = (:*:) <$> gFromQuery params <*> gFromQuery params
+
+class FromQueryField a where
+  fromQueryField ::
+    ( MonadThrow m
+    ) =>
+    RText 'QueryKey ->
+    RText 'QueryValue ->
+    m a
+
+textFromQueryField ::
+  forall a m.
+  ( From Text a,
+    Applicative m
+  ) =>
+  RText 'QueryKey ->
+  RText 'QueryValue ->
+  m a
+textFromQueryField _ = pure . from @Text @a . unRText
+
+readFromQueryField ::
+  ( Read a,
+    MonadThrow m
+  ) =>
+  RText 'QueryKey ->
+  RText 'QueryValue ->
+  m a
+readFromQueryField k v =
+  maybe (throw $ FromQueryInvalidField k v) pure
+    . readMaybe
+    $ unRText v
+
+instance FromQueryField Text where
+  fromQueryField = textFromQueryField
+
+instance FromQueryField String where
+  fromQueryField = textFromQueryField
+
+instance FromQueryField Int where
+  fromQueryField = readFromQueryField
+
+instance FromQueryField Integer where
+  fromQueryField = readFromQueryField
+
+#if defined(__GHCJS__) && defined(ghcjs_HOST_OS) && defined(wasi_HOST_OS)
+instance ToQueryField JSString where
+  fromQueryField = textFromQueryField
+#endif

pub/functora/src/uri/Functora/Uri/ToQuery.hs

@@ -1,7 +1,11 @@
 {-# LANGUAGE CPP #-}
-{-# LANGUAGE UndecidableInstances #-}
 
-module Functora.Uri.ToQuery (ToQuery (..)) where
+module Functora.Uri.ToQuery
+  ( ToQuery (..),
+    GToQuery (..),
+    genericToQuery,
+  )
+where
 
 import Functora.Prelude
 import GHC.Generics hiding (from)
@@ -15,30 +19,38 @@ import Data.JSString (JSString)
 class (Typeable a) => ToQuery a where
   toQuery :: a -> [QueryParam]
   default toQuery :: (Generic a, GToQuery (Rep a)) => a -> [QueryParam]
-  toQuery = gToQuery (Toml.stripTypeNamePrefix $ Proxy @a) . G.from
+  toQuery = genericToQuery
 
 class GToQuery f where
   gToQuery :: (String -> String) -> f p -> [QueryParam]
 
--- Handle datatype metadata
+genericToQuery ::
+  forall a.
+  ( Generic a,
+    Typeable a,
+    GToQuery (Rep a)
+  ) =>
+  a ->
+  [QueryParam]
+genericToQuery =
+  gToQuery (Toml.stripTypeNamePrefix $ Proxy @a) . G.from
+
 instance (GToQuery a) => GToQuery (M1 D c a) where
   gToQuery fmt (M1 x) = gToQuery fmt x
 
--- Handle constructor metadata
 instance (GToQuery a) => GToQuery (M1 C c a) where
   gToQuery fmt (M1 x) = gToQuery fmt x
 
 instance (Selector s, ToQueryField a) => GToQuery (M1 S s (K1 i a)) where
   gToQuery fmt m1@(M1 (K1 a)) = do
     let name = selName m1
     if null name
-      then mempty -- Skip if there is no field name (like unnamed tuples)
+      then mempty
       else do
         k <- mkQueryKey . pack $ fmt name
         v <- mkQueryValue $ toQueryField a
         pure $ QueryParam k v
 
--- Handle product type
 instance (GToQuery a, GToQuery b) => GToQuery (a :*: b) where
   gToQuery fmt (a :*: b) = gToQuery fmt a ++ gToQuery fmt b