Add support for aeson's fieldLabelModifier and constructorTagModifier

.gitignore

@@ -1,3 +1,4 @@
 .stack-work/
 *~
 *.swp
+dist-newstyle/

README.md

@@ -1,7 +1,5 @@
 # generic-override
 
-[![Build](https://img.shields.io/travis/estatico/generic-override.svg?logo=travis)](http://travis-ci.org/estatico/generic-override)
-
 | Library                | Version |
 | ---------------------- | ------- |
 | generic-override       | [![generic-override](https://img.shields.io/hackage/v/generic-override.svg?logo=haskell&color=blueviolet)](https://hackage.haskell.org/package/generic-override) |

generic-override-aeson/CHANGELOG.md

@@ -1,5 +1,10 @@
 # Changelog for generic-override-aeson
 
+## Unreleased changes
+
+* Add `FieldLabelModifier` and `ConstructorTagModifier`
+* Add (internal) `StringModifier` machinery
+
 ## 0.4.0.0
 
 * Add `WithAesonOptions` support

generic-override-aeson/generic-override-aeson.cabal

@@ -1,9 +1,5 @@
 cabal-version: 1.12
 
--- This file has been generated from package.yaml by hpack version 0.34.4.
---
--- see: https://github.com/sol/hpack
-
 name:           generic-override-aeson
 version:        0.4.0.0
 synopsis:       Provides orphan instances necessary for integrating generic-override and aeson
@@ -29,6 +25,8 @@ library
   exposed-modules:
       Data.Override.Aeson
       Data.Override.Aeson.Options.Internal
+      Data.Override.Aeson.Options.StringModifier
+      Data.Override.Aeson.Options.StringModifier.Internal
   other-modules:
       Paths_generic_override_aeson
   hs-source-dirs:
@@ -55,5 +53,6 @@ test-suite generic-override-aeson-test
     , generic-override
     , generic-override-aeson
     , hspec
+    , regex-compat
     , text
   default-language: Haskell2010

generic-override-aeson/src/Data/Override/Aeson/Options/Internal.hs

@@ -1,10 +1,12 @@
 -- | This is the internal generic-override-aeson API and should be considered
 -- unstable and subject to change. In general, you should prefer to use the
 -- public, stable API provided by "Data.Override.Aeson".
+{-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeOperators #-}
@@ -13,6 +15,7 @@ module Data.Override.Aeson.Options.Internal where
 
 import Data.Aeson
 import Data.Coerce (coerce)
+import Data.Override.Aeson.Options.StringModifier.Internal (StringModifiers(stringModifiers))
 import Data.Proxy (Proxy(..))
 import GHC.Generics (Generic, Rep)
 import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)
@@ -24,22 +27,22 @@ import qualified Data.Aeson as Aeson
 newtype WithAesonOptions (a :: *) (options :: [AesonOption]) = WithAesonOptions a
 
 instance
-  ( ApplyAesonOptions options
+  ( ApplyAesonOptions a options
   , Generic a
   , Aeson.GToJSON Aeson.Zero (Rep a)
   , Aeson.GToEncoding Aeson.Zero (Rep a)
   ) => ToJSON (WithAesonOptions a options)
   where
-  toJSON = coerce $ genericToJSON @a $ applyAesonOptions (Proxy @options) defaultOptions
-  toEncoding = coerce $ genericToEncoding @a $ applyAesonOptions (Proxy @options) defaultOptions
+  toJSON = coerce $ genericToJSON @a $ applyAesonOptions @a (Proxy @options) defaultOptions
+  toEncoding = coerce $ genericToEncoding @a $ applyAesonOptions @a (Proxy @options) defaultOptions
 
 instance
-  ( ApplyAesonOptions options
+  ( ApplyAesonOptions a options
   , Generic a
   , Aeson.GFromJSON Aeson.Zero (Rep a)
   ) => FromJSON (WithAesonOptions a options)
   where
-  parseJSON = coerce $ genericParseJSON @a $ applyAesonOptions (Proxy @options) defaultOptions
+  parseJSON = coerce $ genericParseJSON @a $ applyAesonOptions @a (Proxy @options) defaultOptions
 
 -- | Provides a type-level subset of fields from 'Options'
 data AesonOption =
@@ -51,49 +54,57 @@ data AesonOption =
   | SumEncodingTwoElemArray -- ^ Equivalient to @'sumEncoding' = 'TwoElemArray'@
   | UnwrapUnaryRecords -- ^ Equivalient to @'unwrapUnaryRecords' = True@
   | TagSingleConstructors -- ^ Equivalient to @'tagSingleConstructors' = True@
+  | FieldLabelModifier [*] -- ^ Equivalient to @'fieldLabelModifier'
+  | ConstructorTagModifier [*] -- ^ Equivalient to @'constructorTagModifier'
 
 -- | Updates 'Options' given a type-level list of 'AesonOption'.
-class ApplyAesonOptions (options :: [AesonOption]) where
+class ApplyAesonOptions a (options :: [AesonOption]) where
   applyAesonOptions :: Proxy options -> Options -> Options
 
-instance ApplyAesonOptions '[] where
+instance ApplyAesonOptions a '[] where
   applyAesonOptions _ = id
 
 instance
-  ( ApplyAesonOption option
-  , ApplyAesonOptions options
-  ) => ApplyAesonOptions (option ': options)
+  ( ApplyAesonOption a option
+  , ApplyAesonOptions a options
+  ) => ApplyAesonOptions a (option ': options)
   where
   applyAesonOptions _ =
-    applyAesonOption (Proxy @option) . (applyAesonOptions (Proxy @options))
+    applyAesonOption @a (Proxy @option) . (applyAesonOptions @a (Proxy @options))
 
 -- | Updates 'Options' given a single type-level 'AesonOption'.
-class ApplyAesonOption (option :: AesonOption) where
+class ApplyAesonOption a (option :: AesonOption) where
   applyAesonOption :: Proxy option -> Options -> Options
 
-instance ApplyAesonOption ('AllNullaryToStringTag 'True) where
+instance ApplyAesonOption a ('AllNullaryToStringTag 'True) where
   applyAesonOption _ o = o { allNullaryToStringTag = True }
 
-instance ApplyAesonOption ('AllNullaryToStringTag 'False) where
+instance ApplyAesonOption a ('AllNullaryToStringTag 'False) where
   applyAesonOption _ o = o { allNullaryToStringTag = False }
 
-instance ApplyAesonOption 'OmitNothingFields where
+instance ApplyAesonOption a 'OmitNothingFields where
   applyAesonOption _ o = o { omitNothingFields = True }
 
-instance (KnownSymbol k, KnownSymbol v) => ApplyAesonOption ('SumEncodingTaggedObject k v) where
+instance (KnownSymbol k, KnownSymbol v) => ApplyAesonOption a ('SumEncodingTaggedObject k v) where
   applyAesonOption _ o = o { sumEncoding = TaggedObject (symbolVal (Proxy @k)) (symbolVal (Proxy @v)) }
 
-instance ApplyAesonOption 'SumEncodingUntaggedValue where
+instance ApplyAesonOption a 'SumEncodingUntaggedValue where
   applyAesonOption _ o = o { sumEncoding = UntaggedValue }
 
-instance ApplyAesonOption 'SumEncodingObjectWithSingleField where
+instance ApplyAesonOption a 'SumEncodingObjectWithSingleField where
   applyAesonOption _ o = o { sumEncoding = ObjectWithSingleField }
 
-instance ApplyAesonOption 'SumEncodingTwoElemArray where
+instance ApplyAesonOption a 'SumEncodingTwoElemArray where
   applyAesonOption _ o = o { sumEncoding = TwoElemArray }
 
-instance ApplyAesonOption 'UnwrapUnaryRecords where
+instance ApplyAesonOption a 'UnwrapUnaryRecords where
   applyAesonOption _ o = o { unwrapUnaryRecords = True }
 
-instance ApplyAesonOption 'TagSingleConstructors where
+instance ApplyAesonOption a 'TagSingleConstructors where
   applyAesonOption _ o = o { tagSingleConstructors = True }
+
+instance (StringModifiers a fs) => ApplyAesonOption a ('FieldLabelModifier fs) where
+  applyAesonOption _ o = o { fieldLabelModifier = stringModifiers @a @fs }
+
+instance (StringModifiers a fs) => ApplyAesonOption a ('ConstructorTagModifier fs) where
+  applyAesonOption _ o = o { constructorTagModifier = stringModifiers @a @fs }

generic-override-aeson/src/Data/Override/Aeson/Options/StringModifier.hs

@@ -0,0 +1,90 @@
+-- | String modifiers at the type level. Useful in conjunction with
+-- 'Data.Override.Aeson.FieldLabelModifier' and 
+-- 'Data.Override.Aeson.ConstructorTagModifier'.
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+module Data.Override.Aeson.Options.StringModifier where
+
+import Data.Char (toLower, toUpper)
+import Data.Override.Aeson.Options.StringModifier.Internal
+  ( StringModifier(stringModifier), StringModifiers(stringModifiers)
+  )
+import Data.Proxy (Proxy(..))
+import GHC.Generics (Meta(MetaData), D1, Generic, Rep)
+import GHC.TypeLits (KnownNat, KnownSymbol, Nat, natVal, symbolVal)
+
+-- | Represents 'toUpper' as a 'StringModifier'.
+data ToUpper
+instance StringModifier a ToUpper where stringModifier = map toUpper
+
+-- | Represents 'toLower' as a 'StringModifier'.
+data ToLower
+instance StringModifier a ToLower where stringModifier = map toLower
+
+-- | Represents 'drop' as a 'StringModifier'.
+data Drop (n :: Nat)
+instance (KnownNat n) => StringModifier a (Drop n) where
+  stringModifier = drop $ fromIntegral $ natVal $ Proxy @n
+
+-- | Represents 'take' as a 'StringModifier'.
+data Take (n :: Nat)
+instance (KnownNat n) => StringModifier a (Take n) where
+  stringModifier = take $ fromIntegral $ natVal $ Proxy @n
+
+-- | Represents 'atSubstr' as a 'StringModifier'.
+data AtSubstr (i :: Nat) (n :: Nat) (fs :: [*])
+instance
+  ( KnownNat i
+  , KnownNat n
+  , StringModifiers a fs
+  ) => StringModifier a (AtSubstr i n fs)
+  where
+  stringModifier =
+    atSubstr
+      (fromIntegral $ natVal $ Proxy @i)
+      (fromIntegral $ natVal $ Proxy @n)
+      (stringModifiers @a @fs)
+
+-- | Modify only the substring at the given slice, leaving the remaining part
+-- of the string unchanged.
+atSubstr :: Int -> Int -> (String -> String) -> String -> String
+atSubstr i n f s = before <> f at <> after
+  where
+  (before, (at, after)) = splitAt n <$> splitAt i s
+
+-- | Special case of 'AtSubstr' which only modifies the head character of a
+-- string.
+type AtHead = AtSubstr 0 1
+
+-- | Automatically strip the type name (inferred from @a@) from the string.
+--
+-- Example:
+--
+-- > data Foo = Foo { fooBar :: Int, fooBaz :: Bool }
+-- >   deriving stock (Generic)
+-- >   deriving (ToJSON) via Override Foo '[ AutoStripDataPrefix ]
+--
+-- > > putStrLn $ encode $ Foo 1 True
+-- > { "bar": 1, "baz": true }
+data AutoStripDataPrefix
+instance
+  ( Generic a
+  , Rep a ~ D1 ('MetaData n m p nt) f
+  , KnownSymbol n
+  ) => StringModifier a AutoStripDataPrefix
+  where
+  stringModifier s =
+    case splitAt (length prefix) s of
+      (p, c : rest) | p == prefix -> toLower c : rest
+      _ -> s
+    where
+    prefix =
+      case symbolVal $ Proxy @n of
+        c : rest -> toLower c : rest
+        [] -> [] -- Impossible but no need to error

generic-override-aeson/src/Data/Override/Aeson/Options/StringModifier/Internal.hs

@@ -0,0 +1,32 @@
+-- | This is an internal API and should be considered
+-- unstable and subject to change. In general, you should prefer
+-- to use the public, stable API provided by
+-- "Data.Override.Aeson.Options.StringModifier".
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeOperators #-}
+module Data.Override.Aeson.Options.StringModifier.Internal where
+
+-- | Allows for specifying a type to represent a string modification.
+class StringModifier a f where
+  stringModifier :: String -> String
+
+-- | Specify a list of types in order to compose many string modifications.
+-- Evaluates each function from right-to-left.
+class StringModifiers a (fs :: [*]) where
+  stringModifiers :: String -> String
+
+instance StringModifiers a '[] where
+  stringModifiers s = s
+
+instance
+  ( StringModifier a f
+  , StringModifiers a fs
+  ) => StringModifiers a (f ': fs)
+  where
+  stringModifiers = stringModifier @a @f . stringModifiers @a @fs