{-# Language DataKinds, InstanceSigs, ScopedTypeVariables, TypeOperators #-} {-| Module : Toml.Schema.Generic.FromValue Description : GHC.Generics derived table parsing Copyright : (c) Eric Mertens, 2023 License : ISC Maintainer : emertens@gmail.com Generic implementations of matching tables and arrays. -} module Toml.Schema.Generic.FromValue ( -- * Record from table GParseTable(..), genericParseTable, genericFromTable, -- * Product type from array GFromArray(..), genericFromArray, ) where import Control.Monad.Trans.State (StateT(..)) import Data.Coerce (coerce) import Data.Text qualified as Text import GHC.Generics import Toml.Schema.FromValue (FromValue, fromValue, optKey, reqKey, parseTableFromValue, typeError) import Toml.Schema.Matcher (Matcher, failAt) import Toml.Schema.ParseTable (ParseTable) import Toml.Semantics (Value'(List')) -- | Match a 'Toml.Semantics.Table'' using the field names in a record. genericParseTable :: (Generic a, GParseTable (Rep a)) => ParseTable l a genericParseTable = to <$> gParseTable {-# INLINE genericParseTable #-} -- | Implementation of 'fromValue' using 'genericParseTable' to derive -- a match from the record field names of the target type. genericFromTable :: (Generic a, GParseTable (Rep a)) => Value' l -> Matcher l a genericFromTable = parseTableFromValue genericParseTable {-# INLINE genericFromTable #-} -- | Match a 'Toml.Semantics.Value'' as an array positionally matching field fields -- of a constructor to the elements of the array. genericFromArray :: (Generic a, GFromArray (Rep a)) => Value' l -> Matcher l a genericFromArray (List' a xs) = do (gen, xs') <- runStateT gFromArray xs if null xs' then pure (to gen) else failAt a ("array " ++ show (length xs') ++ " elements too long") genericFromArray v = typeError "array" v {-# INLINE genericFromArray #-} -- 'gParseTable' is written in continuation passing style because -- it allows all the "GHC.Generics" constructors to inline into -- a single location which allows the optimizer to optimize them -- complete away. -- | Supports conversion of TOML tables into record values using -- field selector names as TOML keys. class GParseTable f where -- | Convert a value and apply the continuation to the result. gParseTable :: ParseTable l (f a) -- | Ignores type constructor name instance GParseTable f => GParseTable (D1 c f) where gParseTable = M1 <$> gParseTable {-# INLINE gParseTable #-} -- | Ignores value constructor name - only supports record constructors instance GParseTable f => GParseTable (C1 ('MetaCons sym fix 'True) f) where gParseTable = M1 <$> gParseTable {-# INLINE gParseTable #-} -- | Matches left then right component instance (GParseTable f, GParseTable g) => GParseTable (f :*: g) where gParseTable = do x <- gParseTable y <- gParseTable pure (x :*: y) {-# INLINE gParseTable #-} -- | Omits the key from the table on nothing, includes it on just instance {-# OVERLAPS #-} (Selector s, FromValue a) => GParseTable (S1 s (K1 i (Maybe a))) where gParseTable = do x <- optKey (Text.pack (selName (M1 [] :: S1 s [] ()))) pure (M1 (K1 x)) {-# INLINE gParseTable #-} -- | Uses record selector name as table key instance (Selector s, FromValue a) => GParseTable (S1 s (K1 i a)) where gParseTable = do x <- reqKey (Text.pack (selName (M1 [] :: S1 s [] ()))) pure (M1 (K1 x)) {-# INLINE gParseTable #-} -- | Emits empty table instance GParseTable U1 where gParseTable = pure U1 {-# INLINE gParseTable #-} -- | Supports conversion of TOML arrays into product-type values. class GFromArray f where gFromArray :: StateT [Value' l] (Matcher l) (f a) instance GFromArray f => GFromArray (M1 i c f) where gFromArray :: forall a l. StateT [Value' l] (Matcher l) (M1 i c f a) gFromArray = coerce (gFromArray :: StateT [Value' l] (Matcher l) (f a)) {-# INLINE gFromArray #-} instance (GFromArray f, GFromArray g) => GFromArray (f :*: g) where gFromArray = do x <- gFromArray y <- gFromArray pure (x :*: y) {-# INLINE gFromArray #-} instance FromValue a => GFromArray (K1 i a) where gFromArray = StateT \case [] -> fail "array too short" x:xs -> (\v -> (K1 v, xs)) <$> fromValue x {-# INLINE gFromArray #-} -- | Uses no array elements instance GFromArray U1 where gFromArray = pure U1 {-# INLINE gFromArray #-}