{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
module ProjectM36.Tupleable.Deriving
(
Codec(..)
, ModifyOptions(..)
, Field
, ModifyText(..)
, AddPrefix
, DropPrefix
, AddSuffix
, DropSuffix
, UpperCase
, LowerCase
, TitleCase
, CamelCase
, PascalCase
, SnakeCase
, SpinalCase
, TrainCase
, AsIs
, type (<<<)
, type (>>>)
, 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
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
class ModifyOptions a where
modifyOptions :: proxy a -> TupleableOptions -> TupleableOptions
data Field a
instance ModifyText a => ModifyOptions (Field a) where
modifyOptions _ opts = opts { fieldModifier = newFieldModifier }
where
newFieldModifier = modifyText (Proxy :: Proxy a) . fieldModifier opts
class ModifyText a where
modifyText :: proxy a -> T.Text -> T.Text
data AddPrefix (prefix :: Symbol)
instance KnownSymbol prefix => ModifyText (AddPrefix prefix) where
modifyText _ oldText = prefixText <> oldText
where
prefixText = T.pack (symbolVal (Proxy :: Proxy prefix))
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))
data AddSuffix (suffix :: Symbol)
instance KnownSymbol suffix => ModifyText (AddSuffix suffix) where
modifyText _ oldText = oldText <> suffixText
where
suffixText = T.pack (symbolVal (Proxy :: Proxy suffix))
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))
data UpperCase
instance ModifyText UpperCase where
modifyText _ = T.toUpper
data LowerCase
instance ModifyText LowerCase where
modifyText _ = T.toLower
data TitleCase
instance ModifyText TitleCase where
modifyText _ = toTitle
data CamelCase
instance ModifyText CamelCase where
modifyText _ = toCamel
data PascalCase
instance ModifyText PascalCase where
modifyText _ = toPascal
data SnakeCase
instance ModifyText SnakeCase where
modifyText _ = toSnake
data SpinalCase
instance ModifyText SpinalCase where
modifyText _ = toSpinal
data TrainCase
instance ModifyText TrainCase where
modifyText _ = toTrain
type AsIs = ()
instance ModifyOptions () where
modifyOptions _ = id
instance ModifyText () where
modifyText _ = id
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)
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)