wip

Author: functora

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

@@ -226,6 +226,14 @@ instance
   where
   toQuery = genericToQuery . unGenericType
 
+instance
+  ( Generic a,
+    GFromQuery (Rep a)
+  ) =>
+  FromQuery (GenericType a)
+  where
+  fromQuery = fmap GenericType . genericFromQuery
+
 instance
   ( Generic a,
     Typeable a,

pub/functora/src/functora-ghcjs.cabal

@@ -189,6 +189,7 @@ library
     Functora.Tags
     Functora.Unicode
     Functora.Uri
+    Functora.Uri.FromQuery
     Functora.Uri.ToQuery
     Functora.Web
     Functora.WebOrphan
@@ -258,6 +259,7 @@ test-suite functora-ghcjs-test
     Functora.TagsOrphan
     Functora.Unicode
     Functora.Uri
+    Functora.Uri.FromQuery
     Functora.Uri.ToQuery
     Functora.Web
     Functora.WebOrphan

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

@@ -7,6 +7,7 @@ module Functora.Uri.FromQuery
     FromQueryField (..),
     textFromQueryField,
     readFromQueryField,
+    FromQueryException (..),
   )
 where
 
@@ -20,26 +21,6 @@ import qualified Toml
 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
@@ -52,7 +33,6 @@ class GFromQuery f where
   gFromQuery :: (MonadThrow m) => QueryMap -> m (f p)
 
 genericFromQuery ::
-  forall a m.
   ( Generic a,
     GFromQuery (Rep a),
     MonadThrow m
@@ -82,10 +62,10 @@ instance
         . 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
+      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
@@ -136,3 +116,27 @@ instance FromQueryField Integer where
 instance ToQueryField JSString where
   fromQueryField = textFromQueryField
 #endif
+
+--
+-- Extra stuff
+--
+
+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

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

@@ -22,37 +22,35 @@ class (Typeable a) => ToQuery a where
   toQuery = genericToQuery
 
 class GToQuery f where
-  gToQuery :: (String -> String) -> f p -> [QueryParam]
+  gToQuery :: f p -> [QueryParam]
 
-genericToQuery ::
-  forall a.
-  ( Generic a,
-    Typeable a,
-    GToQuery (Rep a)
-  ) =>
-  a ->
-  [QueryParam]
-genericToQuery =
-  gToQuery (Toml.stripTypeNamePrefix $ Proxy @a) . G.from
+genericToQuery :: (Generic a, GToQuery (Rep a)) => a -> [QueryParam]
+genericToQuery = gToQuery . G.from
 
 instance (GToQuery a) => GToQuery (M1 D c a) where
-  gToQuery fmt (M1 x) = gToQuery fmt x
+  gToQuery (M1 x) = gToQuery x
 
 instance (GToQuery a) => GToQuery (M1 C c a) where
-  gToQuery fmt (M1 x) = gToQuery fmt x
+  gToQuery (M1 x) = gToQuery 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
+instance
+  ( Typeable a,
+    Selector s,
+    ToQueryField a
+  ) =>
+  GToQuery (M1 S s (K1 i a))
+  where
+  gToQuery m1@(M1 (K1 a)) = do
+    let name = Toml.stripTypeNamePrefix (Proxy @a) $ selName m1
     if null name
       then mempty
       else do
-        k <- mkQueryKey . pack $ fmt name
+        k <- mkQueryKey $ pack name
         v <- mkQueryValue $ toQueryField a
         pure $ QueryParam k v
 
 instance (GToQuery a, GToQuery b) => GToQuery (a :*: b) where
-  gToQuery fmt (a :*: b) = gToQuery fmt a ++ gToQuery fmt b
+  gToQuery (a :*: b) = gToQuery a <> gToQuery b
 
 class ToQueryField a where
   toQueryField :: a -> Text