{-# LANGUAGE KindSignatures, DataKinds #-}
{-# LANGUAGE UndecidableInstances, FlexibleContexts #-} -- type family in instance head
{-# LANGUAGE PolyKinds #-}

-- | Allows deriving ron encoding-decoding instances with @DerivingVia@. See 'RonWith'
module Data.Ron.Class.Deriving
    ( RonWith (..)
    -- * Settings
    , UseStrict
    , EncodeWith
    , DecodeWith
    , ConvertWith
    , FieldsToSnakeCase
    , FieldsDropPrefix
    , ImplicitSome
    , NoImplicitSome
    , SkipSingleConstructor
    , NoSkipSingleConstructor
    -- * Undelying typeclasses
    , ReflectSettingsOptions (..)
    , ReflectFlagOptions (..)
    ) where

import Data.Char (isUpper, toLower, isLower)
import Data.Proxy (Proxy (..))
import GHC.Generics (Generic, Rep)

import Data.Ron.Class


-- | Helper for deriving Ron instances. Use like this:
--
-- @
--      data MyType = MyType {...}
--          deriving (Eq, Show, Generic)
--          deriving (ToRon, FromRon)
--              via RonWith '[FieldsDropPrefix, EncodeWith SkipSingleConstructor] MyType
-- @
--
-- This is identical to
--
-- @
--      data MyType = MyType {...}
--          deriving (Eq, Show, Generic)
--      instance ToRon MyType where
--          toRon =
--              let settings
--                  = (\s{encodeFlags} -> s{encodeFlags = encodeFlags{skipSingleConstructor = True}})
--                  . (\s{fieldModifier} -> s{dropPrefix . fieldModifier})
--                  $ laxRonSettings
--              in toRonGeneric settings
-- @
--
-- The options are applied left to right, and the starting options are
-- 'laxRonSettings'
--
-- All of built-in settings are documented in 'Data.Ron.Class.Deriving' module.
-- You can define your own settings by creating new datatypes and creating
-- instances for 'ReflectSettingsOptions' or 'ReflectFlagOptions'
newtype RonWith s a = RonWith a

instance (Generic a, GToRon (Rep a), ReflectSettingsList s)
    => ToRon (RonWith s a) where
    toRon :: RonWith s a -> Value
toRon (RonWith a
x) = (RonSettings -> a -> Value) -> a -> RonSettings -> Value
forall a b c. (a -> b -> c) -> b -> a -> c
flip RonSettings -> a -> Value
forall a. (Generic a, GToRon (Rep a)) => RonSettings -> a -> Value
toRonGeneric a
x (RonSettings -> Value) -> RonSettings -> Value
forall a b. (a -> b) -> a -> b
$ Proxy s -> RonSettings -> RonSettings
forall {k} (a :: k).
ReflectSettingsList a =>
Proxy a -> RonSettings -> RonSettings
reflectL (forall (t :: k). Proxy t
forall {k} (t :: k). Proxy t
Proxy @s) RonSettings
laxRonSettings

instance (Generic a, GFromRon (Rep a), ReflectSettingsList s)
    => FromRon (RonWith s a) where
    fromRon :: Value -> ParseResult (RonWith s a)
fromRon = (a -> RonWith s a) -> Either String a -> ParseResult (RonWith s a)
forall a b. (a -> b) -> Either String a -> Either String b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> RonWith s a
forall {k} (s :: k) a. a -> RonWith s a
RonWith (Either String a -> ParseResult (RonWith s a))
-> (Value -> Either String a) -> Value -> ParseResult (RonWith s a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RonSettings -> Value -> Either String a
forall a.
(Generic a, GFromRon (Rep a)) =>
RonSettings -> Value -> ParseResult a
fromRonGeneric (Proxy s -> RonSettings -> RonSettings
forall {k} (a :: k).
ReflectSettingsList a =>
Proxy a -> RonSettings -> RonSettings
reflectL (forall (t :: k). Proxy t
forall {k} (t :: k). Proxy t
Proxy @s) RonSettings
laxRonSettings)

class ReflectSettingsList a where
    reflectL :: Proxy a -> RonSettings -> RonSettings

instance ReflectSettingsList '[] where
    reflectL :: Proxy '[] -> RonSettings -> RonSettings
reflectL Proxy '[]
Proxy RonSettings
s = RonSettings
s
    {-# INLINE reflectL #-}
instance (ReflectSettingsOptions s, ReflectSettingsList ss)
    => ReflectSettingsList (s:ss) where
    reflectL :: Proxy (s : ss) -> RonSettings -> RonSettings
reflectL Proxy (s : ss)
Proxy
        = Proxy ss -> RonSettings -> RonSettings
forall {k} (a :: k).
ReflectSettingsList a =>
Proxy a -> RonSettings -> RonSettings
reflectL (forall (t :: [a]). Proxy t
forall {k} (t :: k). Proxy t
Proxy @ss)
        (RonSettings -> RonSettings)
-> (RonSettings -> RonSettings) -> RonSettings -> RonSettings
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy s -> RonSettings -> RonSettings
forall {k} (a :: k).
ReflectSettingsOptions a =>
Proxy a -> RonSettings -> RonSettings
reflectS (forall (t :: a). Proxy t
forall {k} (t :: k). Proxy t
Proxy @s)
    {-# INLINE reflectL #-}

-- | Replace the current settings with 'strictRonSettings'
data UseStrict
-- | Sets a flag in @encodeFlags@. Can set anything with 'ReflectFlagOptions'
-- instances, like 'ImplicitSome', 'SkipSingleConstructor'
data EncodeWith a
-- | Sets a flag in @decodeFlags@. Can set anything with 'ReflectFlagOptions'
-- instances
data DecodeWith a
-- | Same as setting both 'EncodeWith' and 'DecodeWith'
data ConvertWith a
-- | Convert fields to snake case. If your field also has prefix, you want to
-- have this option after 'FieldsDropPrefix', as options are applied left to
-- right
data FieldsToSnakeCase
-- | Drop the prefix that is usually used with lenses, that is an underscore
-- followed by several lowercase letters; regex for this prefix is
-- @s\/^_[[:lowercase:]]+([[:uppercase:]].*)\/\\1\/@. You probably want to use
-- this field modifier before other field modifiers, as they are applied left
-- to right
data FieldsDropPrefix

-- | Typeclass for you to implement your own options. Here's how
-- 'FieldsToSnakeCase' uses it:
--
-- @
--      instance ReflectSettingsOptions FieldsToSnakeCase where
--          reflectS Proxy s@RonSettings {fieldModifier} = s
--              { fieldModifier = toSnake . fieldModifier }
-- @
--
-- Be careful when composing functions to apply them after the already present,
-- to preserve the left-to-right semantics of adding the options
class ReflectSettingsOptions a where
    reflectS :: Proxy a -> RonSettings -> RonSettings

-- | Encode or decode flag that sets 'Data.Ron.Class.implicitSome' to @True@
data ImplicitSome
-- | Encode or decode flag that sets 'Data.Ron.Class.implicitSome' to @False@
data NoImplicitSome
-- | Encode or decode flag that sets 'Data.Ron.Class.skipSingleConstructor' to @True@
data SkipSingleConstructor
-- | Encode or decode flag that sets 'Data.Ron.Class.skipSingleConstructor' to @False@
data NoSkipSingleConstructor

-- | Typeclass for you to implement your own symmetric options. Here's how
-- 'ImplicitSome' uses it
--
-- @
--      instance ReflectFlagOptions ImplicitSome where
--          reflectF Proxy flags = flags { implicitSome = True }
-- @
class ReflectFlagOptions a where
    reflectF :: Proxy a -> RonFlags -> RonFlags

instance ReflectSettingsOptions UseStrict where
    reflectS :: Proxy UseStrict -> RonSettings -> RonSettings
reflectS Proxy UseStrict
Proxy RonSettings
_ = RonSettings
strictRonSettings
    {-# INLINE reflectS #-}

instance ReflectFlagOptions a => ReflectSettingsOptions (EncodeWith a) where
    reflectS :: Proxy (EncodeWith a) -> RonSettings -> RonSettings
reflectS Proxy (EncodeWith a)
Proxy s :: RonSettings
s@RonSettings {RonFlags
encodeFlags :: RonFlags
encodeFlags :: RonSettings -> RonFlags
encodeFlags} = RonSettings
s
        { encodeFlags = reflectF (Proxy @a) encodeFlags }
    {-# INLINE reflectS #-}
instance ReflectFlagOptions a => ReflectSettingsOptions (DecodeWith a) where
    reflectS :: Proxy (DecodeWith a) -> RonSettings -> RonSettings
reflectS Proxy (DecodeWith a)
Proxy s :: RonSettings
s@RonSettings {RonFlags
decodeFlags :: RonFlags
decodeFlags :: RonSettings -> RonFlags
decodeFlags} = RonSettings
s
        { decodeFlags = reflectF (Proxy @a) decodeFlags }
    {-# INLINE reflectS #-}
instance ReflectFlagOptions a => ReflectSettingsOptions (ConvertWith a) where
    reflectS :: Proxy (ConvertWith a) -> RonSettings -> RonSettings
reflectS Proxy (ConvertWith a)
Proxy s :: RonSettings
s@RonSettings {RonFlags
encodeFlags :: RonSettings -> RonFlags
encodeFlags :: RonFlags
encodeFlags, RonFlags
decodeFlags :: RonSettings -> RonFlags
decodeFlags :: RonFlags
decodeFlags} = RonSettings
s
        { encodeFlags = reflectF (Proxy @a) encodeFlags
        , decodeFlags = reflectF (Proxy @a) decodeFlags
        }
    {-# INLINE reflectS #-}

instance ReflectSettingsOptions FieldsDropPrefix where
    reflectS :: Proxy FieldsDropPrefix -> RonSettings -> RonSettings
reflectS Proxy FieldsDropPrefix
Proxy conf :: RonSettings
conf@RonSettings {String -> String
fieldModifier :: String -> String
fieldModifier :: RonSettings -> String -> String
fieldModifier} = RonSettings
conf
        { fieldModifier = dropPrefix . fieldModifier }
        where
            dropPrefix :: String -> String
dropPrefix (Char
'_':String
s) =
                case (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isUpper) String
s of
                    String
"" -> Char
'_'Char -> String -> String
forall a. a -> [a] -> [a]
:String
s
                    Char
c:String
s' -> Char -> Char
toLower Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: String
s'
            dropPrefix String
s = String
s
    {-# INLINE reflectS #-}

instance ReflectSettingsOptions FieldsToSnakeCase where
    reflectS :: Proxy FieldsToSnakeCase -> RonSettings -> RonSettings
reflectS Proxy FieldsToSnakeCase
Proxy s :: RonSettings
s@RonSettings {String -> String
fieldModifier :: RonSettings -> String -> String
fieldModifier :: String -> String
fieldModifier} = RonSettings
s
        { fieldModifier = toSnake . fieldModifier }
        where
         toSnake :: String -> String
toSnake = Char -> String -> String
camelTo2 Char
'_'
    {-# INLINE reflectS #-}

-- | Better version of camelTo. Example where it works better:
--
--   > camelTo '_' "CamelAPICase" == "camel_apicase"
--   > camelTo2 '_' "CamelAPICase" == "camel_api_case"
--
-- Extracted from aeson at Feb 2022
camelTo2 :: Char -> String -> String
camelTo2 :: Char -> String -> String
camelTo2 Char
c = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
go2 (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
go1
    where
        go1 :: String -> String
go1 String
"" = String
""
        go1 (Char
x:Char
u:Char
l:String
xs) | Char -> Bool
isUpper Char
u Bool -> Bool -> Bool
&& Char -> Bool
isLower Char
l = Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: Char
u Char -> String -> String
forall a. a -> [a] -> [a]
: Char
l Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
go1 String
xs
        go1 (Char
x:String
xs) = Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
go1 String
xs
        go2 :: String -> String
go2 String
"" = String
""
        go2 (Char
l:Char
u:String
xs) | Char -> Bool
isLower Char
l Bool -> Bool -> Bool
&& Char -> Bool
isUpper Char
u = Char
l Char -> String -> String
forall a. a -> [a] -> [a]
: Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: Char
u Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
go2 String
xs
        go2 (Char
x:String
xs) = Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
go2 String
xs

instance ReflectFlagOptions ImplicitSome where
    reflectF :: Proxy ImplicitSome -> RonFlags -> RonFlags
reflectF Proxy ImplicitSome
Proxy RonFlags
f =
        RonFlags
f { implicitSome = True }
    {-# INLINE reflectF #-}

instance ReflectFlagOptions NoImplicitSome where
    reflectF :: Proxy NoImplicitSome -> RonFlags -> RonFlags
reflectF Proxy NoImplicitSome
Proxy RonFlags
f =
        RonFlags
f { implicitSome = False }
    {-# INLINE reflectF #-}

instance ReflectFlagOptions SkipSingleConstructor where
    reflectF :: Proxy SkipSingleConstructor -> RonFlags -> RonFlags
reflectF Proxy SkipSingleConstructor
Proxy RonFlags
f =
        RonFlags
f { skipSingleConstructor = True }
    {-# INLINE reflectF #-}

instance ReflectFlagOptions NoSkipSingleConstructor where
    reflectF :: Proxy NoSkipSingleConstructor -> RonFlags -> RonFlags
reflectF Proxy NoSkipSingleConstructor
Proxy RonFlags
f =
        RonFlags
f { skipSingleConstructor = False }
    {-# INLINE reflectF #-}