Deriving.hs

{-# 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 { unCodec :: a }

instance (ModifyOptions tag, Generic a, TupleableG (Rep a)) => Tupleable (Codec tag a) where
  toTuple v = genericToTuple opts (unCodec v)
    where
      opts = modifyOptions (Proxy :: Proxy tag) defaultTupleableOptions

  fromTuple tup = Codec <$> genericFromTuple opts tup
    where
      opts = modifyOptions (Proxy :: Proxy tag) defaultTupleableOptions

  toAttributes _ = genericToAttributes opts (Proxy :: Proxy a)
    where
      opts = modifyOptions (Proxy :: Proxy tag) 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 _ opts = opts { fieldModifier = newFieldModifier }
    where
      newFieldModifier = modifyText (Proxy :: Proxy a) . fieldModifier 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 _ oldText = prefixText <> oldText
    where
      prefixText = T.pack (symbolVal (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 _ oldText = fromMaybe oldText (T.stripPrefix prefixText oldText)
    where
      prefixText = T.pack (symbolVal (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 _ oldText = oldText <> suffixText
    where
      suffixText = T.pack (symbolVal (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 _ oldText = fromMaybe oldText (T.stripSuffix suffixText oldText)
    where
      suffixText = T.pack (symbolVal (Proxy :: Proxy suffix))

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

instance ModifyText UpperCase where
  modifyText _ = T.toUpper

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

instance ModifyText LowerCase where
  modifyText _ = T.toLower

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

instance ModifyText TitleCase where
  modifyText _ = toTitle

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

instance ModifyText CamelCase where
  modifyText _ = toCamel

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

instance ModifyText PascalCase where
  modifyText _ = toPascal

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

instance ModifyText SnakeCase where
  modifyText _ = toSnake

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

instance ModifyText SpinalCase where
  modifyText _ = toSpinal

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

instance ModifyText TrainCase where
  modifyText _ = toTrain

-- | Identity option.
type AsIs = ()

instance ModifyOptions () where
  modifyOptions _ = id

instance ModifyText () where
  modifyText _ = 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 _ = modifyOptions (Proxy :: Proxy a) . modifyOptions (Proxy :: Proxy b)

instance (ModifyText a, ModifyText b) => ModifyText (a <<< b) where
  modifyText _ = modifyText (Proxy :: Proxy a) . modifyText (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 _ = modifyOptions (Proxy :: Proxy b) . modifyOptions (Proxy :: Proxy a)

instance (ModifyText a, ModifyText b) => ModifyText (a >>> b) where
  modifyText _ = modifyText (Proxy :: Proxy b) . modifyText (Proxy :: Proxy a)