{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE UndecidableInstances #-}
module Toml.Generic
( genericCodec
, genericCodecWithOptions
, stripTypeNameCodec
, TomlOptions (..)
, GenericOptions (..)
, stripTypeNameOptions
, stripTypeNamePrefix
, HasCodec (..)
, HasItemCodec (..)
, GenericCodec (..)
) where
import Data.Char (isLower, toLower)
import Data.IntSet (IntSet)
import Data.Kind (Type)
import Data.List (stripPrefix)
import Data.List.NonEmpty (NonEmpty)
import Data.Proxy (Proxy (..))
import Data.String (IsString (..))
import Data.Text (Text)
import Data.Time (Day, LocalTime, TimeOfDay, ZonedTime)
import Data.Typeable (Typeable, typeRep)
import Data.Word (Word)
import GHC.Generics ((:*:) (..), (:+:), C1, D1, Generic (..), K1 (..), M1 (..), Rec0, S1,
Selector (..))
import GHC.TypeLits (ErrorMessage (..), TypeError)
import Numeric.Natural (Natural)
import Toml.Bi (TomlBiMap, TomlCodec, (.=))
import Toml.PrefixTree (Key)
import Toml.Type (AnyValue)
import qualified Data.Text.Lazy as L
import qualified Toml.Bi as Toml
genericCodec :: (Generic a, GenericCodec (Rep a)) => TomlCodec a
genericCodec = Toml.dimap from to $ genericTomlCodec (GenericOptions id)
{-# INLINE genericCodec #-}
genericCodecWithOptions
:: forall a
. (Generic a, GenericCodec (Rep a), Typeable a)
=> TomlOptions a
-> TomlCodec a
genericCodecWithOptions = Toml.dimap from to . genericTomlCodec . toGenericOptions @a
{-# INLINE genericCodecWithOptions #-}
stripTypeNameCodec
:: forall a
. (Generic a, GenericCodec (Rep a), Typeable a)
=> TomlCodec a
stripTypeNameCodec = genericCodecWithOptions $ stripTypeNameOptions @a
{-# INLINE stripTypeNameCodec #-}
data TomlOptions a = TomlOptions
{ tomlOptionsFieldModifier :: Typeable a => Proxy a -> String -> String
}
newtype GenericOptions = GenericOptions
{ genericOptionsFieldModifier :: String -> String
}
toGenericOptions :: forall a . Typeable a => TomlOptions a -> GenericOptions
toGenericOptions TomlOptions{..} = GenericOptions
{ genericOptionsFieldModifier = tomlOptionsFieldModifier (Proxy @a)
}
stripTypeNameOptions :: Typeable a => TomlOptions a
stripTypeNameOptions = TomlOptions
{ tomlOptionsFieldModifier = stripTypeNamePrefix
}
stripTypeNamePrefix :: forall a . Typeable a => Proxy a -> String -> String
stripTypeNamePrefix _ fieldName =
case stripPrefix (headToLower $ typeName @a) fieldName of
Just rest -> leaveIfEmpty rest
Nothing -> leaveIfEmpty (dropWhile isLower fieldName)
where
headToLower :: String -> String
headToLower = \case
[] -> error "Cannot use 'headToLower' on empty Text"
x:xs -> toLower x : xs
leaveIfEmpty :: String -> String
leaveIfEmpty rest = if null rest then fieldName else headToLower rest
typeName :: forall a . Typeable a => String
typeName = show $ typeRep (Proxy @a)
class GenericCodec (f :: k -> Type) where
genericTomlCodec :: GenericOptions -> TomlCodec (f p)
instance GenericCodec f => GenericCodec (D1 d f) where
genericTomlCodec = Toml.dimap unM1 M1 . genericTomlCodec
{-# INLINE genericTomlCodec #-}
type GenericSumTomlNotSupported =
'Text "Generic TOML deriving for arbitrary sum types is not supported currently."
instance (TypeError GenericSumTomlNotSupported) => GenericCodec (f :+: g) where
genericTomlCodec = error "Not supported"
instance GenericCodec f => GenericCodec (C1 c f) where
genericTomlCodec = Toml.dimap unM1 M1 . genericTomlCodec
{-# INLINE genericTomlCodec #-}
instance (GenericCodec f, GenericCodec g) => GenericCodec (f :*: g) where
genericTomlCodec options = (:*:)
<$> genericTomlCodec options .= fstG
<*> genericTomlCodec options .= sndG
where
fstG :: (f :*: g) p -> f p
fstG (f :*: _) = f
sndG :: (f :*: g) p -> g p
sndG (_ :*: g) = g
{-# INLINE genericTomlCodec #-}
instance (Selector s, HasCodec a) => GenericCodec (S1 s (Rec0 a)) where
genericTomlCodec GenericOptions{..} = genericWrap $ hasCodec @a fieldName
where
genericWrap :: TomlCodec a -> TomlCodec (S1 s (Rec0 a) p)
genericWrap = Toml.dimap (unK1 . unM1) (M1 . K1)
fieldName :: Key
fieldName =
fromString
$ genericOptionsFieldModifier
$ selName (error "S1" :: S1 s Proxy ())
{-# INLINE genericTomlCodec #-}
class HasItemCodec a where
hasItemCodec :: Either (TomlBiMap a AnyValue) (TomlCodec a)
instance HasItemCodec Bool where hasItemCodec = Left Toml._Bool
instance HasItemCodec Int where hasItemCodec = Left Toml._Int
instance HasItemCodec Word where hasItemCodec = Left Toml._Word
instance HasItemCodec Integer where hasItemCodec = Left Toml._Integer
instance HasItemCodec Natural where hasItemCodec = Left Toml._Natural
instance HasItemCodec Double where hasItemCodec = Left Toml._Double
instance HasItemCodec Float where hasItemCodec = Left Toml._Float
instance HasItemCodec Text where hasItemCodec = Left Toml._Text
instance HasItemCodec L.Text where hasItemCodec = Left Toml._LText
instance HasItemCodec ZonedTime where hasItemCodec = Left Toml._ZonedTime
instance HasItemCodec LocalTime where hasItemCodec = Left Toml._LocalTime
instance HasItemCodec Day where hasItemCodec = Left Toml._Day
instance HasItemCodec TimeOfDay where hasItemCodec = Left Toml._TimeOfDay
instance HasItemCodec IntSet where hasItemCodec = Left Toml._IntSet
instance (HasItemCodec a, Typeable a) => HasItemCodec [a] where
hasItemCodec = case hasItemCodec @a of
Left prim -> Left $ Toml._Array prim
Right codec -> Right $ Toml.list codec (fromString $ typeName @a)
class HasCodec a where
hasCodec :: Key -> TomlCodec a
instance HasCodec Bool where hasCodec = Toml.bool
instance HasCodec Int where hasCodec = Toml.int
instance HasCodec Word where hasCodec = Toml.word
instance HasCodec Integer where hasCodec = Toml.integer
instance HasCodec Natural where hasCodec = Toml.natural
instance HasCodec Double where hasCodec = Toml.double
instance HasCodec Float where hasCodec = Toml.float
instance HasCodec Text where hasCodec = Toml.text
instance HasCodec L.Text where hasCodec = Toml.lazyText
instance HasCodec ZonedTime where hasCodec = Toml.zonedTime
instance HasCodec LocalTime where hasCodec = Toml.localTime
instance HasCodec Day where hasCodec = Toml.day
instance HasCodec TimeOfDay where hasCodec = Toml.timeOfDay
instance HasCodec IntSet where hasCodec = Toml.arrayIntSet
instance HasCodec a => HasCodec (Maybe a) where
hasCodec = Toml.dioptional . hasCodec @a
instance HasItemCodec a => HasCodec [a] where
hasCodec = case hasItemCodec @a of
Left prim -> Toml.arrayOf prim
Right codec -> Toml.list codec
instance HasItemCodec a => HasCodec (NonEmpty a) where
hasCodec = case hasItemCodec @a of
Left prim -> Toml.arrayNonEmptyOf prim
Right codec -> Toml.nonEmpty codec