can use ToQuery and FromQuery generics-based classes

Author: functora

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

@@ -101,7 +101,6 @@ data St f = St
     stTheme :: Theme
   }
   deriving stock (Generic)
-  deriving (ToQuery) via GenericType (St f)
 
 deriving stock instance (Hkt f) => Eq (St f)
 
@@ -111,6 +110,10 @@ deriving stock instance (Hkt f) => Show (St f)
 
 deriving stock instance (Hkt f) => Data (St f)
 
+deriving via (GenericType (St f)) instance (Hkt f) => ToQuery (St f)
+
+deriving via (GenericType (St Identity)) instance FromQuery (St Identity)
+
 instance FunctorB St
 
 instance TraversableB St
@@ -163,6 +166,12 @@ instance TraversableB Asset
 
 deriving via GenericType (Asset Identity) instance Binary (Asset Identity)
 
+instance ToQueryField [Asset f] where
+  toQueryField _ = pure mempty
+
+instance FromQueryField [Asset f] where
+  fromQueryField _ _ = pure mempty
+
 newAsset :: (MonadIO m, MonadThrow m) => m (Asset Unique)
 newAsset = do
   uid <- newUid
@@ -407,7 +416,10 @@ foldFieldPair acc =
   foldField acc . fieldPairValue
 
 stShortUri :: (MonadThrow m) => Model -> m URI
-stShortUri = stUri . (#modelState . #stAssets .~ mempty)
+stShortUri st = do
+  uri <- mkURI $ from @Unicode @Prelude.Text baseUri
+  let qxs = toQuery . uniqueToIdentity $ modelState st
+  pure $ uri {URI.uriQuery = qxs}
 
 stLongUri :: (MonadThrow m) => Model -> m URI
 stLongUri = stUri

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

@@ -10,10 +10,16 @@ import Data.Monoid.GCD
 import Data.Monoid.Null
 import Data.Monoid.Textual
 import Data.Semigroup.Cancellative
+import Functora.Miso.Theme (Theme)
 import Functora.Prelude
+import Functora.Uri
 import qualified Miso
 import Prelude hiding (String)
 
+deriving via (GenericEnum Theme) instance ToQueryField Theme
+
+deriving via (GenericEnum Theme) instance FromQueryField Theme
+
 deriving stock instance Generic (Miso.View action)
 
 deriving stock instance Generic (Miso.Attribute action)

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

@@ -87,6 +87,7 @@ type Typ a =
 
 type Hkt f =
   ( Typeable f,
+    Foldable1 f,
     Eq (f Unicode),
     Ord (f Unicode),
     Show (f Unicode),
@@ -155,6 +156,26 @@ deriving via
   instance
     (Typ a) => Binary (Field a Identity)
 
+instance (Foldable1 f) => ToQueryField (Field a f) where
+  toQueryField = toQueryField . fold1 . fieldInput
+
+instance FromQueryField (Field Rational Identity) where
+  fromQueryField k v = do
+    out <-
+      first (const $ FromQueryInvalidField k v)
+        . parseRatio
+        $ URI.unRText v
+    pure
+      $ newFieldId
+        FieldTypeNumber
+        inspectRatioDef
+        out
+
+instance FromQueryField (Field Unicode Identity) where
+  fromQueryField k v = do
+    out <- castFromQueryField k v
+    pure $ newFieldId FieldTypeText id out
+
 data FieldOpts = FieldOpts
   { fieldOptsAllowCopy :: Bool,
     fieldOptsTruncateLimit :: Maybe Int,
@@ -409,10 +430,25 @@ instance FunctorB Currency
 
 instance TraversableB Currency
 
-deriving via
-  GenericType (Currency Identity)
-  instance
-    Binary (Currency Identity)
+deriving via GenericType (Currency Identity) instance Binary (Currency Identity)
+
+instance ToQueryField (Currency f) where
+  toQueryField =
+    toQueryField
+      . (^. #currencyOutput . #currencyInfoCode . #unCurrencyCode)
+
+instance FromQueryField (Currency Identity) where
+  fromQueryField _ v =
+    pure
+      Currency
+        { currencyInput = newTextFieldId mempty,
+          currencyOutput =
+            CurrencyInfo
+              { currencyInfoText = mempty,
+                currencyInfoCode = CurrencyCode $ URI.unRText v
+              },
+          currencyModalState = Closed
+        }
 
 newCurrency :: (MonadIO m) => CurrencyInfo -> m (Currency Unique)
 newCurrency cur =
@@ -527,42 +563,49 @@ data TopOrBottom
   | Bottom
   deriving stock (Eq, Ord, Show, Read, Enum, Bounded, Data, Generic)
   deriving (Binary) via GenericType TopOrBottom
+  deriving (ToQueryField, FromQueryField) via GenericEnum TopOrBottom
 
 data OnlineOrOffline
   = Online
   | Offline
   deriving stock (Eq, Ord, Show, Read, Enum, Bounded, Data, Generic)
   deriving (Binary) via GenericType OnlineOrOffline
+  deriving (ToQueryField, FromQueryField) via GenericEnum OnlineOrOffline
 
 data StaticOrDynamic
   = Static
   | Dynamic
   deriving stock (Eq, Ord, Show, Read, Enum, Bounded, Data, Generic)
   deriving (Binary) via GenericType StaticOrDynamic
+  deriving (ToQueryField, FromQueryField) via GenericEnum StaticOrDynamic
 
 data LeadingOrTrailing
   = Leading
   | Trailing
   deriving stock (Eq, Ord, Show, Read, Enum, Bounded, Data, Generic)
   deriving (Binary) via GenericType LeadingOrTrailing
+  deriving (ToQueryField, FromQueryField) via GenericEnum LeadingOrTrailing
 
 data EnabledOrDisabled
   = Enabled
   | Disabled
   deriving stock (Eq, Ord, Show, Read, Enum, Bounded, Data, Generic)
   deriving (Binary) via GenericType EnabledOrDisabled
+  deriving (ToQueryField, FromQueryField) via GenericEnum EnabledOrDisabled
 
 data FocusedOrBlurred
   = Focused
   | Blurred
   deriving stock (Eq, Ord, Show, Read, Enum, Bounded, Data, Generic)
   deriving (Binary) via GenericType FocusedOrBlurred
+  deriving (ToQueryField, FromQueryField) via GenericEnum FocusedOrBlurred
 
 data OpenedOrClosed
   = Opened
   | Closed
   deriving stock (Eq, Ord, Show, Read, Enum, Bounded, Data, Generic)
   deriving (Binary) via GenericType OpenedOrClosed
+  deriving (ToQueryField, FromQueryField) via GenericEnum OpenedOrClosed
 
 data Update model
   = PureUpdate (model -> model)

pub/functora/functora.cabal

@@ -166,6 +166,7 @@ common pkg-uri
     , containers
     , modern-uri
     , tomland
+    , universum
 
   if ((impl(ghcjs) || arch(javascript)) || os(wasi))
     build-depends: jsaddle
@@ -182,7 +183,6 @@ common pkg-cfg
     , modern-uri
     , optparse-applicative
     , tomland
-    , uri
 
 common pkg-web
   import:         pkg

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

@@ -1,5 +1,3 @@
-{-# LANGUAGE UndecidableInstances #-}
-
 module Functora.Cfg
   ( module X,
 
@@ -22,11 +20,6 @@ module Functora.Cfg
     -- $binary
     decodeBinary,
     encodeBinary,
-
-    -- * DerivingVia
-    -- $derivingVia
-    GenericEnum (..),
-    GenericType (..),
   )
 where
 
@@ -43,10 +36,8 @@ import qualified Data.Binary.Get as Binary
 import Data.Binary.Instances as X ()
 import qualified Data.ByteString.Lazy as BL
 import qualified Data.List.NonEmpty as NE
-import Functora.CfgOrphan as X ()
+import Functora.CfgOrphan (genericTomlCodec)
 import Functora.Prelude
-import Functora.Uri
-import qualified GHC.Generics as Generics
 import qualified Options.Applicative as Cli
 import Toml as X
   ( HasCodec,
@@ -160,21 +151,6 @@ encodeToml ::
 encodeToml =
   Toml.encode genericTomlCodec
 
-genericTomlCodec ::
-  ( Generic a,
-    Typeable a,
-    Toml.GenericCodec (Rep a)
-  ) =>
-  TomlCodec a
-genericTomlCodec =
-  Toml.genericCodecWithOptions
-    Toml.TomlOptions
-      { Toml.tomlOptionsFieldModifier = \proxy ->
-          Toml.stripTypeNamePrefix proxy . \case
-            ('_' : xs) -> xs
-            xs -> xs
-      }
-
 -- $binary
 -- Binary
 
@@ -195,136 +171,3 @@ decodeBinary raw = do
 
 encodeBinary :: (Binary a) => a -> BL.ByteString
 encodeBinary = Binary.encode
-
--- $derivingVia
--- Newtypes to simplify deriving via.
--- We have to expose default constructors/accessors
--- to help GHC with figuring out that runtime representation does match.
-
-newtype GenericEnum a = GenericEnum
-  { unGenericEnum :: a
-  }
-  deriving newtype (Show, Enum, Bounded)
-
-instance (Show a, Enum a, Bounded a) => HasCodec (GenericEnum a) where
-  hasCodec = Toml.enumBounded
-
-instance (Show a, Enum a, Bounded a) => HasItemCodec (GenericEnum a) where
-  hasItemCodec = Left Toml._EnumBounded
-
-newtype GenericType a = GenericType
-  { unGenericType :: a
-  }
-  deriving stock (Generic)
-
-instance
-  ( Generic a,
-    Typeable a,
-    GToQuery (Rep a)
-  ) =>
-  ToQuery (GenericType a)
-  where
-  toQuery = genericToQuery . unGenericType
-
-instance
-  ( Generic a,
-    GFromQuery (Rep a)
-  ) =>
-  FromQuery (GenericType a)
-  where
-  fromQuery = fmap GenericType . genericFromQuery
-
-instance
-  ( Generic a,
-    Typeable a,
-    Toml.GenericCodec (Rep a)
-  ) =>
-  HasCodec (GenericType a)
-  where
-  hasCodec = Toml.diwrap . Toml.table (genericTomlCodec @a)
-
-instance
-  ( Generic a,
-    Typeable a,
-    Toml.GenericCodec (Rep a)
-  ) =>
-  HasItemCodec (GenericType a)
-  where
-  hasItemCodec = Right . Toml.diwrap $ genericTomlCodec @a
-
-instance
-  ( Generic a,
-    Typeable a,
-    A.GFromJSON A.Zero (Rep a)
-  ) =>
-  FromJSON (GenericType a)
-  where
-  parseJSON = fmap GenericType . A.genericParseJSON (optsAeson @a)
-
-instance
-  ( Generic a,
-    Typeable a,
-    A.GFromJSON A.Zero (Rep a),
-    A.GFromJSONKey (Rep a)
-  ) =>
-  FromJSONKey (GenericType a)
-  where
-  fromJSONKey = GenericType <$> A.genericFromJSONKey A.defaultJSONKeyOptions
-
-instance
-  ( Generic a,
-    Typeable a,
-    A.GToJSON A.Zero (Rep a),
-    A.GToEncoding A.Zero (Rep a)
-  ) =>
-  ToJSON (GenericType a)
-  where
-  toJSON = A.genericToJSON (optsAeson @a) . unGenericType
-  toEncoding = A.genericToEncoding (optsAeson @a) . unGenericType
-
-instance
-  ( Generic a,
-    Typeable a,
-    A.GToJSON A.Zero (Rep a),
-    A.GToEncoding A.Zero (Rep a),
-    A.GToJSONKey (Rep a)
-  ) =>
-  ToJSONKey (GenericType a)
-  where
-  toJSONKey = contramap unGenericType $ A.genericToJSONKey A.defaultJSONKeyOptions
-
-instance
-  ( Generic a,
-    Typeable a,
-    Binary.GBinaryPut (Rep a),
-    Binary.GBinaryGet (Rep a)
-  ) =>
-  Binary (GenericType a)
-  where
-  putList = defaultPutList
-  put = Binary.gput . Generics.from . unGenericType
-  get = GenericType . Generics.to <$> Binary.gget
-
-{-# INLINE defaultPutList #-}
-defaultPutList :: (Binary a) => [a] -> Binary.Put
-defaultPutList xs = Binary.put (length xs) <> mapM_ Binary.put xs
-
-optsAeson :: forall a. (Typeable a) => A.Options
-optsAeson =
-  A.defaultOptions
-    { A.fieldLabelModifier = \case
-        raw@('_' : inp) ->
-          case fmt inp of
-            out | out == inp -> fmt raw
-            out -> out
-        raw ->
-          fmt raw,
-      A.constructorTagModifier = id,
-      A.allNullaryToStringTag = True,
-      A.omitNothingFields = True,
-      A.sumEncoding = A.defaultTaggedObject,
-      A.unwrapUnaryRecords = False,
-      A.tagSingleConstructors = False
-    }
-  where
-    fmt = Toml.stripTypeNamePrefix $ Proxy @a