{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}

-- | Newtypes for deriving Tupleable instances with customization using
-- @DerivingVia@.
--
-- Inspired by
-- [Dhall.Deriving](https://hackage.haskell.org/package/dhall-1.33.1/docs/Dhall-Deriving.html)
-- which in turn was inspired by Matt Parson's blog post
-- [Mirror Mirror: Reflection and Encoding Via](https://www.parsonsmatt.org/2020/02/04/mirror_mirror.html).
--
-- required extensions:
--
--   * DerivingVia
--   * DeriveGenerics
--   * TypeOperators (for @('<<<')@ and @('>>>')@)
--   * DataKinds (for types that take a string argument)

module ProjectM36.Tupleable.Deriving
  ( -- * DerivingVia Newtype
    Codec(..)

    -- * Type-level Options
  , ModifyOptions(..)
  , Field

    -- * Type-level 'T.Text' -> 'T.Text' Functions
  , ModifyText(..)
  , AddPrefix
  , DropPrefix
  , AddSuffix
  , DropSuffix
  , UpperCase
  , LowerCase
  , TitleCase
  , CamelCase
  , PascalCase
  , SnakeCase
  , SpinalCase
  , TrainCase

    -- * Composition
  , AsIs
  , type (<<<)
  , type (>>>)

    -- * Re-Exports
  , Generic
  , module ProjectM36.Tupleable
  ) where
import           Data.Maybe           (fromMaybe)
import           Data.Proxy
import qualified Data.Text            as T
import           Data.Text.Manipulate
import           GHC.TypeLits
import           GHC.Generics         (Generic, Rep)
import           ProjectM36.Tupleable


-- | A newtype wrapper to allow for easier deriving of 'Tupleable' instances
-- with customization.
--
-- The @tag@ type variable can be used to specify options for converting the
-- datatype to and from a 'RelationTuple'. For example,
--
-- > data Example = Example
-- >     { exampleFoo :: Int
-- >     , exampleBar :: Int
-- >     }
-- >     deriving stock (Generic)
-- >     deriving (Tupleable)
-- >         via Codec (Field (DropPrefix "example" >>> CamelCase)) Example
--
-- will derive an instance of 'Tupleable' where field names are translated into
-- attribute names by dropping the prefix @"example"@ and then converting the
-- result to camelCase. So @"exampleFoo"@ becomes @"foo"@ and @"exampleBar"@
-- becomes @"bar"@.
--
-- Requires the @DerivingGeneric@ and @DerivingVia@ extensions to be enabled.
newtype Codec tag a = Codec { Codec tag a -> a
unCodec :: a }

instance (ModifyOptions tag, Generic a, TupleableG (Rep a)) => Tupleable (Codec tag a) where
  toTuple :: Codec tag a -> RelationTuple
toTuple Codec tag a
v = TupleableOptions -> a -> RelationTuple
forall a.
(Generic a, TupleableG (Rep a)) =>
TupleableOptions -> a -> RelationTuple
genericToTuple TupleableOptions
opts (Codec tag a -> a
forall tag a. Codec tag a -> a
unCodec Codec tag a
v)
    where
      opts :: TupleableOptions
opts = Proxy tag -> TupleableOptions -> TupleableOptions
forall a (proxy :: * -> *).
ModifyOptions a =>
proxy a -> TupleableOptions -> TupleableOptions
modifyOptions (Proxy tag
forall k (t :: k). Proxy t
Proxy :: Proxy tag) TupleableOptions
defaultTupleableOptions

  fromTuple :: RelationTuple -> Either RelationalError (Codec tag a)
fromTuple RelationTuple
tup = a -> Codec tag a
forall tag a. a -> Codec tag a
Codec (a -> Codec tag a)
-> Either RelationalError a -> Either RelationalError (Codec tag a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TupleableOptions -> RelationTuple -> Either RelationalError a
forall a.
(Generic a, TupleableG (Rep a)) =>
TupleableOptions -> RelationTuple -> Either RelationalError a
genericFromTuple TupleableOptions
opts RelationTuple
tup
    where
      opts :: TupleableOptions
opts = Proxy tag -> TupleableOptions -> TupleableOptions
forall a (proxy :: * -> *).
ModifyOptions a =>
proxy a -> TupleableOptions -> TupleableOptions
modifyOptions (Proxy tag
forall k (t :: k). Proxy t
Proxy :: Proxy tag) TupleableOptions
defaultTupleableOptions

  toAttributes :: Proxy (Codec tag a) -> Attributes
toAttributes Proxy (Codec tag a)
_ = TupleableOptions -> Proxy a -> Attributes
forall a.
(Generic a, TupleableG (Rep a)) =>
TupleableOptions -> Proxy a -> Attributes
genericToAttributes TupleableOptions
opts (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a)
    where
      opts :: TupleableOptions
opts = Proxy tag -> TupleableOptions -> TupleableOptions
forall a (proxy :: * -> *).
ModifyOptions a =>
proxy a -> TupleableOptions -> TupleableOptions
modifyOptions (Proxy tag
forall k (t :: k). Proxy t
Proxy :: Proxy tag) TupleableOptions
defaultTupleableOptions

-- | Types that can be used as tags for 'Codec'.
class ModifyOptions a where
  modifyOptions :: proxy a -> TupleableOptions -> TupleableOptions

-- | Change how record field names are translated into attribute names. For
-- example,
--
-- > Field SnakeCase
--
-- will translate the field name @fooBar@ into the attribute name @foo_bar@.
data Field a

instance ModifyText a => ModifyOptions (Field a) where
  modifyOptions :: proxy (Field a) -> TupleableOptions -> TupleableOptions
modifyOptions proxy (Field a)
_ TupleableOptions
opts = TupleableOptions
opts { fieldModifier :: Text -> Text
fieldModifier = Text -> Text
newFieldModifier }
    where
      newFieldModifier :: Text -> Text
newFieldModifier = Proxy a -> Text -> Text
forall a (proxy :: * -> *). ModifyText a => proxy a -> Text -> Text
modifyText (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a) (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TupleableOptions -> Text -> Text
fieldModifier TupleableOptions
opts

-- | Types that can be used in options that modify 'T.Text' such as in 'Field'.
class ModifyText a where
  modifyText :: proxy a -> T.Text -> T.Text

-- | Add a prefix. @AddPrefix "foo"@ will transform @"bar"@ into @"foobar"@.
data AddPrefix (prefix :: Symbol)

instance KnownSymbol prefix => ModifyText (AddPrefix prefix) where
  modifyText :: proxy (AddPrefix prefix) -> Text -> Text
modifyText proxy (AddPrefix prefix)
_ Text
oldText = Text
prefixText Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
oldText
    where
      prefixText :: Text
prefixText = String -> Text
T.pack (Proxy prefix -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy prefix
forall k (t :: k). Proxy t
Proxy :: Proxy prefix))

-- | Drop a prefix. @DropPrefix "bar"@ will transform @"foobar"@ into @"foo"@.
data DropPrefix (prefix :: Symbol)

instance KnownSymbol prefix => ModifyText (DropPrefix prefix) where
  modifyText :: proxy (DropPrefix prefix) -> Text -> Text
modifyText proxy (DropPrefix prefix)
_ Text
oldText = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
oldText (Text -> Text -> Maybe Text
T.stripPrefix Text
prefixText Text
oldText)
    where
      prefixText :: Text
prefixText = String -> Text
T.pack (Proxy prefix -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy prefix
forall k (t :: k). Proxy t
Proxy :: Proxy prefix))

-- | Add a suffix. @AddSuffix "bar"@ will transform @"foo"@ into @"foobar"@.
data AddSuffix (suffix :: Symbol)

instance KnownSymbol suffix => ModifyText (AddSuffix suffix) where
  modifyText :: proxy (AddSuffix suffix) -> Text -> Text
modifyText proxy (AddSuffix suffix)
_ Text
oldText = Text
oldText Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
suffixText
    where
      suffixText :: Text
suffixText = String -> Text
T.pack (Proxy suffix -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy suffix
forall k (t :: k). Proxy t
Proxy :: Proxy suffix))

-- | Drop a suffix. @DropSuffix "bar"@ will transform @"foobar"@ into @"foo"@.
data DropSuffix (suffix :: Symbol)

instance KnownSymbol suffix => ModifyText (DropSuffix suffix) where
  modifyText :: proxy (DropSuffix suffix) -> Text -> Text
modifyText proxy (DropSuffix suffix)
_ Text
oldText = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
oldText (Text -> Text -> Maybe Text
T.stripSuffix Text
suffixText Text
oldText)
    where
      suffixText :: Text
suffixText = String -> Text
T.pack (Proxy suffix -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy suffix
forall k (t :: k). Proxy t
Proxy :: Proxy suffix))

-- | Convert to UPPERCASE. Will transform @"foobar"@ into @\"FOOBAR\"@.
data UpperCase

instance ModifyText UpperCase where
  modifyText :: proxy UpperCase -> Text -> Text
modifyText proxy UpperCase
_ = Text -> Text
T.toUpper

-- | Convert to lowercase. Will transform @\"FOOBAR\"@ into @"foobar"@.
data LowerCase

instance ModifyText LowerCase where
  modifyText :: proxy LowerCase -> Text -> Text
modifyText proxy LowerCase
_ = Text -> Text
T.toLower

-- | Convert to Title Case. Will transform @"fooBar"@ into @\"Foo Bar\"@.
data TitleCase

instance ModifyText TitleCase where
  modifyText :: proxy TitleCase -> Text -> Text
modifyText proxy TitleCase
_ = Text -> Text
toTitle

-- | Convert to camelCase. Will transform @"foo_bar"@ into @"fooBar"@.
data CamelCase

instance ModifyText CamelCase where
  modifyText :: proxy CamelCase -> Text -> Text
modifyText proxy CamelCase
_ = Text -> Text
toCamel

-- | Convert to PascalCase. Will transform @"foo_bar"@ into @\"FooBar\"@.
data PascalCase

instance ModifyText PascalCase where
  modifyText :: proxy PascalCase -> Text -> Text
modifyText proxy PascalCase
_ = Text -> Text
toPascal

-- | Convert to snake_case. Will transform @"fooBar"@ into @"foo_bar"@.
data SnakeCase

instance ModifyText SnakeCase where
  modifyText :: proxy SnakeCase -> Text -> Text
modifyText proxy SnakeCase
_ = Text -> Text
toSnake

-- | Convert to spinal-case. will transform @"fooBar"@ into @"foo-bar"@.
data SpinalCase

instance ModifyText SpinalCase where
  modifyText :: proxy SpinalCase -> Text -> Text
modifyText proxy SpinalCase
_ = Text -> Text
toSpinal

-- | Convert to Train-Case. Will transform @"fooBar"@ into @\"Foo-Bar\"@.
data TrainCase

instance ModifyText TrainCase where
  modifyText :: proxy TrainCase -> Text -> Text
modifyText proxy TrainCase
_ = Text -> Text
toTrain

-- | Identity option.
type AsIs = ()

instance ModifyOptions () where
  modifyOptions :: proxy () -> TupleableOptions -> TupleableOptions
modifyOptions proxy ()
_ = TupleableOptions -> TupleableOptions
forall a. a -> a
id

instance ModifyText () where
  modifyText :: proxy () -> Text -> Text
modifyText proxy ()
_ = Text -> Text
forall a. a -> a
id

-- | Right to left composition.
--
-- Requires the @TypeOperators@ extension to be enabled.
data a <<< b

instance (ModifyOptions a, ModifyOptions b) => ModifyOptions (a <<< b) where
  modifyOptions :: proxy (a <<< b) -> TupleableOptions -> TupleableOptions
modifyOptions proxy (a <<< b)
_ = Proxy a -> TupleableOptions -> TupleableOptions
forall a (proxy :: * -> *).
ModifyOptions a =>
proxy a -> TupleableOptions -> TupleableOptions
modifyOptions (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a) (TupleableOptions -> TupleableOptions)
-> (TupleableOptions -> TupleableOptions)
-> TupleableOptions
-> TupleableOptions
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy b -> TupleableOptions -> TupleableOptions
forall a (proxy :: * -> *).
ModifyOptions a =>
proxy a -> TupleableOptions -> TupleableOptions
modifyOptions (Proxy b
forall k (t :: k). Proxy t
Proxy :: Proxy b)

instance (ModifyText a, ModifyText b) => ModifyText (a <<< b) where
  modifyText :: proxy (a <<< b) -> Text -> Text
modifyText proxy (a <<< b)
_ = Proxy a -> Text -> Text
forall a (proxy :: * -> *). ModifyText a => proxy a -> Text -> Text
modifyText (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a) (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy b -> Text -> Text
forall a (proxy :: * -> *). ModifyText a => proxy a -> Text -> Text
modifyText (Proxy b
forall k (t :: k). Proxy t
Proxy :: Proxy b)

-- | Left to right composition.
--
-- Requires the @TypeOperators@ extension to be enabled.
data a >>> b

instance (ModifyOptions a, ModifyOptions b) => ModifyOptions (a >>> b) where
  modifyOptions :: proxy (a >>> b) -> TupleableOptions -> TupleableOptions
modifyOptions proxy (a >>> b)
_ = Proxy b -> TupleableOptions -> TupleableOptions
forall a (proxy :: * -> *).
ModifyOptions a =>
proxy a -> TupleableOptions -> TupleableOptions
modifyOptions (Proxy b
forall k (t :: k). Proxy t
Proxy :: Proxy b) (TupleableOptions -> TupleableOptions)
-> (TupleableOptions -> TupleableOptions)
-> TupleableOptions
-> TupleableOptions
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy a -> TupleableOptions -> TupleableOptions
forall a (proxy :: * -> *).
ModifyOptions a =>
proxy a -> TupleableOptions -> TupleableOptions
modifyOptions (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a)

instance (ModifyText a, ModifyText b) => ModifyText (a >>> b) where
  modifyText :: proxy (a >>> b) -> Text -> Text
modifyText proxy (a >>> b)
_ = Proxy b -> Text -> Text
forall a (proxy :: * -> *). ModifyText a => proxy a -> Text -> Text
modifyText (Proxy b
forall k (t :: k). Proxy t
Proxy :: Proxy b) (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy a -> Text -> Text
forall a (proxy :: * -> *). ModifyText a => proxy a -> Text -> Text
modifyText (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a)