{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE UndecidableInstances #-} {- | This module contains implementation of the 'Generic' TOML codec. If your data types are big and nested, and you want to have codecs for them without writing a lot of boilerplate code, you can find this module helpful. Below you can find the detailed explanation on how the 'Generic' codecs work. Consider the following Haskell data types: @ __data__ User = User { age :: Int , address :: Address , socials :: [Social] } __deriving__ ('Generic') __data__ Address = Address { street :: Text , house :: Int } __deriving__ ('Generic') __data__ Social = Social { name :: Text , link :: Text } __deriving__ ('Generic') @ Value of the @User@ type represents the following TOML: @ age = 27 [address] street = "Miami Beach" house = 42 [[socials]] name = \"Twitter\" link = "https://twitter.com/foo" [[socials]] name = \"GitHub\" link = "https://github.com/bar" @ Normally you would write 'TomlCodec' for this data type like this: @ userCodec :: 'TomlCodec' User userCodec = User \<$\> Toml.int "age" .= age \<*\> Toml.table addressCodec "address" .= address \<*\> Toml.list socialCodec "socials" .= socials addressCodec :: 'TomlCodec' Address addressCodec = Address \<$\> Toml.text "street" .= street \<*\> Toml.int "house" .= house socialCodec :: 'TomlCodec' Social socialCodec = Social \<$\> Toml.text "name" .= name \<*\> Toml.text "link" .= link @ However, if you derive 'Generic' instance for your data types (as we do in the example), you can write your codecs in a simpler way. @ userCodec :: 'TomlCodec' User userCodec = 'genericCodec' __instance__ 'HasCodec' Address __where__ hasCodec = Toml.table 'genericCodec' __instance__ 'HasItemCodec' Social __where__ hasItemCodec = Right 'genericCodec' @ Several notes about the interface: 1. Your top-level data types are always implemented as 'genericCodec' (or other generic codecs). 2. If you have a custom data type as a field of another type, you need to implement the instance of the 'HasCodec' typeclass. 3. If the data type appears as an element of a list, you need to implement the instance of the 'HasItemCodec' typeclass. @since 1.1.1.0 -} module Toml.Generic ( genericCodec , genericCodecWithOptions , stripTypeNameCodec -- * Options , TomlOptions (..) , GenericOptions (..) , stripTypeNameOptions , stripTypeNamePrefix -- * Core generic typeclass , 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 {- | Generic codec for arbitrary data types. Uses field names as keys. -} genericCodec :: (Generic a, GenericCodec (Rep a)) => TomlCodec a genericCodec = Toml.dimap from to $ genericTomlCodec (GenericOptions id) {-# INLINE genericCodec #-} {- | Generic codec with options for arbitrary data types. -} genericCodecWithOptions :: forall a . (Generic a, GenericCodec (Rep a), Typeable a) => TomlOptions a -> TomlCodec a genericCodecWithOptions = Toml.dimap from to . genericTomlCodec . toGenericOptions @a {-# INLINE genericCodecWithOptions #-} {- | Generic codec that uses 'stripTypeNameOptions'. -} stripTypeNameCodec :: forall a . (Generic a, GenericCodec (Rep a), Typeable a) => TomlCodec a stripTypeNameCodec = genericCodecWithOptions $ stripTypeNameOptions @a {-# INLINE stripTypeNameCodec #-} ---------------------------------------------------------------------------- -- Generic typeclasses ---------------------------------------------------------------------------- {- | Options to configure various parameters of generic encoding. Specifically: * __'tomlOptionsFieldModifier'__: how to translate field names to TOML keys? -} data TomlOptions a = TomlOptions { tomlOptionsFieldModifier :: Typeable a => Proxy a -> String -> String } {- | Same as 'TomlOptions' but with all data type information erased. This data type is used internally. Define your options using 'TomlOptions' data type. -} newtype GenericOptions = GenericOptions { genericOptionsFieldModifier :: String -> String } toGenericOptions :: forall a . Typeable a => TomlOptions a -> GenericOptions toGenericOptions TomlOptions{..} = GenericOptions { genericOptionsFieldModifier = tomlOptionsFieldModifier (Proxy @a) } -- | Options that use 'stripTypeNamePrefix' as 'tomlOptionsFieldModifier'. stripTypeNameOptions :: Typeable a => TomlOptions a stripTypeNameOptions = TomlOptions { tomlOptionsFieldModifier = stripTypeNamePrefix } {- | Strips name of the type name from field name prefix. >>> data UserData = UserData { userDataId :: Int, userDataShortInfo :: Text } >>> stripTypeNamePrefix (Proxy @UserData) "userDataId" "id" >>> stripTypeNamePrefix (Proxy @UserData) "userDataShortInfo" "shortInfo" >>> stripTypeNamePrefix (Proxy @UserData) "udStats" "stats" >>> stripTypeNamePrefix (Proxy @UserData) "fooBar" "bar" >>> stripTypeNamePrefix (Proxy @UserData) "name" "name" -} 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 -- if all lower case then leave field as it is leaveIfEmpty :: String -> String leaveIfEmpty rest = if null rest then fieldName else headToLower rest typeName :: forall a . Typeable a => String typeName = show $ typeRep (Proxy @a) ---------------------------------------------------------------------------- -- Generic typeclasses ---------------------------------------------------------------------------- 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 #-} ---------------------------------------------------------------------------- -- Helper typeclasses ---------------------------------------------------------------------------- {- | This typeclass tells how the data type should be coded as an item of a list. Lists in TOML can have two types: __primitive__ and __table of arrays__. * If 'hasItemCodec' returns 'Left': __primitive__ arrays codec is used. * If 'hasItemCodec' returns 'Right:' __table of arrays__ codec is used. -} 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 {- | If data type @a@ is not primitive then this instance returns codec for list under key equal to @a@ type name. -} 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) {- | Helper typeclass for generic deriving. This instance tells how the data type should be coded if it's a field of another data type. __NOTE:__ If you implement TOML codecs for your data types manually, prefer more explicit @Toml.int@ or @Toml.text@ instead of implicit @Toml.hasCodec@. Implement instances of this typeclass only when using 'genericCodec' and when your custom data types are not covered here. -} 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 {- TODO: uncomment when higher-kinded roles will be implemented * https://github.com/ghc-proposals/ghc-proposals/pull/233 {- | @newtype@ for generic deriving of 'HasCodec' typeclass for custom data types that should we wrapped into separate table. Use it only for data types that are fields of another data types. @ data Person = Person { personName :: Text , personAddress :: Address } deriving (Generic) data Address = Address { addressStreet :: Text , addressHouse :: Int } deriving (Generic) deriving HasCodec via TomlTable Address personCodec :: TomlCodec Person personCodec = genericCodec @ @personCodec@ corresponds to the TOML of the following structure: @ name = "foo" [address] street = \"Bar\" house = 42 @ -} newtype TomlTable a = TomlTable { unTomlTable :: a } instance (Generic a, GenericCodec (Rep a)) => HasCodec (TomlTable a) where hasCodec :: Key -> TomlCodec (TomlTable a) hasCodec = Toml.diwrap . Toml.table (genericCodec @a) instance (Generic a, GenericCodec (Rep a)) => HasItemCodec (TomlTable a) where hasItemCodec = Right $ Toml.diwrap $ genericCodec @a -}