-- | Provides kebab-case instances for @aeson@.
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
module Data.Yaml.Config.Kebab where

import Data.Aeson (FromJSON, ToJSON)
import GHC.Generics (Generic, Rep)

import qualified Data.Aeson as Aeson
import qualified Data.Char as Char
import qualified Language.Haskell.TH.Syntax as TH

-- | A DerivingVia wrapper that only turns all fields into kebab-case.
-- No other field processing occurs, which also means no field prefix stripping.
newtype AesonKebab a = AesonKebab a

-- | Default 'Aeson.Options' which sets 'Aeson.fieldLabelModifier' to use 'kebab'.
aesonKebabOptions :: Aeson.Options
aesonKebabOptions :: Options
aesonKebabOptions =
  Options
Aeson.defaultOptions
    { fieldLabelModifier :: String -> String
Aeson.fieldLabelModifier = String -> String
kebab
    }

-- | Convert a @camelCase@ string to @kebab-case@.
kebab :: String -> String
kebab :: String -> String
kebab String
s = do
  Char
c <- String
s
  if Char -> Bool
Char.isUpper Char
c then [Char
'-', Char -> Char
Char.toLower Char
c] else [Char
c]

-- | Gets the given identifier name as a 'String' but converts it
-- to @kebab-case@. Useful for
--
-- > fooBar = True
-- > kebabName 'fooBar == "foo-bar"
kebabName :: TH.Name -> String
kebabName :: Name -> String
kebabName = String -> String
kebab (String -> String) -> (Name -> String) -> Name -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
getName

-- | Gets the given identifier name as a 'String'.
--
-- If @DuplicateRecordFields@ is enabled, detects the names in the form of
-- @$sel:name:Type@ and extracts the @name@.
getName :: TH.Name -> String
getName :: Name -> String
getName (TH.Name (TH.OccName String
s) NameFlavour
_) =
  case String
s of
    Char
'$' : String
_ -> (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
':') (Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
5 String
s)
    String
_ -> String
s

instance
  ( Generic a
  , Aeson.GToJSON Aeson.Zero (Rep a)
  , Aeson.GToEncoding Aeson.Zero (Rep a)
  ) => ToJSON (AesonKebab a)
  where
  toJSON :: AesonKebab a -> Value
toJSON (AesonKebab a
a) = Options -> a -> Value
forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
Aeson.genericToJSON Options
aesonKebabOptions a
a
  toEncoding :: AesonKebab a -> Encoding
toEncoding (AesonKebab a
a) = Options -> a -> Encoding
forall a.
(Generic a, GToJSON' Encoding Zero (Rep a)) =>
Options -> a -> Encoding
Aeson.genericToEncoding Options
aesonKebabOptions a
a

instance
  ( Generic a
  , Aeson.GFromJSON Aeson.Zero (Rep a)
  ) => FromJSON (AesonKebab a)
  where
  parseJSON :: Value -> Parser (AesonKebab a)
parseJSON Value
v = a -> AesonKebab a
forall a. a -> AesonKebab a
AesonKebab (a -> AesonKebab a) -> Parser a -> Parser (AesonKebab a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Options -> Value -> Parser a
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
Aeson.genericParseJSON Options
aesonKebabOptions Value
v