-- | Create more idiomatic JSON/YAML representations of lens-enabled or plain
-- record types using 'deriveJSON'.
--
-- @
-- data Foobar =
--     Foobar
--         { _foobarSnickerSnack :: Int
--         , _foobarTumTumTree :: String
--         }
--
-- $(deriveLensJSON ''Foobar)
--
-- foobar = Foobar 23 \"Hello, world!\"
-- @
--
-- ...encodes to:
--
-- @
-- {\"snicker-snack\":23,\"tum-tum-tree\":\"Hello, world!\"}
-- @
module Data.Aeson.DeriveUtils
where

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

-- | A drop-in replacement for 'deriveJSON' with options suitable for
-- record fields designed for 'makeLenses'.
-- Constructor names are converted to @lowercase-with-dashes@; for field names,
-- a leading underscore and the record prefix is stripped off, and then the
-- same conversion to @lowercase-with-dashes@ is performed.
deriveLensJSON :: Name -> Q [Dec]
deriveLensJSON = deriveJSON lensJSONOptions

-- | Same as 'deriveLensJSON', but allows for different separator characters
-- than @-@ (the typical alternative choice being @_@).
deriveLensJSON' :: Char -> Name -> Q [Dec]
deriveLensJSON' sep = deriveJSON (lensJSONOptions' sep)

-- | Options for 'deriveJSON' as used by 'deriveLensJSON'. Use this with
-- 'deriveJSON' to get more control over deriving.
lensJSONOptions :: Options
lensJSONOptions = lensJSONOptions' '-'

-- | Options for 'deriveJSON' as used by 'deriveLensJSON''. Use this with
-- 'deriveJSON' to get more control over deriving.
lensJSONOptions' :: Char -> Options
lensJSONOptions' sep =
    defaultOptions
        { fieldLabelModifier = recordToDashedIdentifier sep
        , constructorTagModifier = ctorToDashedIdentifier sep
        }

-- | Build a dashed name from a record constructor name, e.g. @FoobarBaz@ ->
-- @foobar-baz@.
ctorToDashedIdentifier = camelToDashed

-- | Build a dashed name from a record field name, e.g. @_foobarBazQuux@ ->
-- @baz-quux@.
recordToDashedIdentifier sep = camelToDashed sep . stripRecordPrefix

-- | Helper that converts a camel-cased (@somethingLikeThis@) or pascal-cased
-- (@SomethingLikeThis@) into all-lowercase with separators, e.g.
-- @something-like-this@.
camelToDashed _ ""  = ""
camelToDashed sep (x:y:xs)
    | isLower x && isUpper y = toLower x:sep:camelToDashed sep (y:xs)
    | otherwise = toLower x:camelToDashed sep (y:xs)
camelToDashed sep (x:xs) = toLower x:camelToDashed sep xs

-- | Strip record prefixes off a typical record field identifier.
-- The prefix is assumed to be everything up to the first uppercase character
-- in the identifier.
stripRecordPrefix = dropWhile (not . isUpper)