{-# Language DataKinds, InstanceSigs, ScopedTypeVariables, TypeOperators #-}
{-|
Module      : Toml.FromValue.Generic
Description : GHC.Generics derived table parsing
Copyright   : (c) Eric Mertens, 2023
License     : ISC
Maintainer  : emertens@gmail.com

Use 'genericParseTable' to derive a 'ParseTable' using the field names
of a record. This can be combined with 'Toml.FromValue.parseTableFromValue'
to derive a 'Toml.FromValue.FromValue' instance.

-}
module Toml.FromValue.Generic (
    -- * Record from table
    GParseTable(..),
    genericParseTable,

    -- * Product type from array 
    GFromArray(..),
    genericFromArray,
    ) where

import Control.Monad.Trans.State (StateT(..))
import Data.Coerce (coerce)
import GHC.Generics
import Toml.FromValue (FromValue, fromValue, optKey, reqKey)
import Toml.FromValue.Matcher (Matcher)
import Toml.FromValue.ParseTable (ParseTable)
import Toml.Value (Value)

-- | Match a 'Table' using the field names in a record.
--
-- @since 1.2.0.0
genericParseTable :: (Generic a, GParseTable (Rep a)) => ParseTable a
genericParseTable :: forall a. (Generic a, GParseTable (Rep a)) => ParseTable a
genericParseTable = Rep a Any -> a
forall a x. Generic a => Rep a x -> a
forall x. Rep a x -> a
to (Rep a Any -> a) -> ParseTable (Rep a Any) -> ParseTable a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParseTable (Rep a Any)
forall a. ParseTable (Rep a a)
forall (f :: * -> *) a. GParseTable f => ParseTable (f a)
gParseTable
{-# INLINE genericParseTable #-}

-- | Match a 'Value' as an array positionally matching field fields
-- of a constructor to the elements of the array.
--
-- @since 1.3.2.0
genericFromArray :: (Generic a, GFromArray (Rep a)) => Value -> Matcher a
genericFromArray :: forall a. (Generic a, GFromArray (Rep a)) => Value -> Matcher a
genericFromArray Value
v =
 do [Value]
xs <- Value -> Matcher [Value]
forall a. FromValue a => Value -> Matcher a
fromValue Value
v
    (Rep a Any
gen, [Value]
xs') <- StateT [Value] Matcher (Rep a Any)
-> [Value] -> Matcher (Rep a Any, [Value])
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT StateT [Value] Matcher (Rep a Any)
forall a. StateT [Value] Matcher (Rep a a)
forall (f :: * -> *) a.
GFromArray f =>
StateT [Value] Matcher (f a)
gFromArray [Value]
xs
    if [Value] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Value]
xs' then
        a -> Matcher a
forall a. a -> Matcher a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Rep a Any -> a
forall a x. Generic a => Rep a x -> a
forall x. Rep a x -> a
to Rep a Any
gen)
    else
        String -> Matcher a
forall a. String -> Matcher a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"array " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([Value] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Value]
xs') String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" elements too long")
{-# 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.
--
-- @since 1.0.2.0
class GParseTable f where
    -- | Convert a value and apply the continuation to the result.
    gParseTable :: ParseTable (f a)

-- | Ignores type constructor name
instance GParseTable f => GParseTable (D1 c f) where
    gParseTable :: forall a. ParseTable (D1 c f a)
gParseTable = f a -> M1 D c f a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f a -> M1 D c f a) -> ParseTable (f a) -> ParseTable (M1 D c f a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>  ParseTable (f a)
forall a. ParseTable (f a)
forall (f :: * -> *) a. GParseTable f => ParseTable (f a)
gParseTable
    {-# INLINE gParseTable #-}

-- | Ignores value constructor name - only supports record constructors
instance GParseTable f => GParseTable (C1 ('MetaCons sym fix 'True) f) where
    gParseTable :: forall a. ParseTable (C1 ('MetaCons sym fix 'True) f a)
gParseTable = f a -> M1 C ('MetaCons sym fix 'True) f a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f a -> M1 C ('MetaCons sym fix 'True) f a)
-> ParseTable (f a)
-> ParseTable (M1 C ('MetaCons sym fix 'True) f a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParseTable (f a)
forall a. ParseTable (f a)
forall (f :: * -> *) a. GParseTable f => ParseTable (f a)
gParseTable
    {-# INLINE gParseTable #-}

-- | Matches left then right component
instance (GParseTable f, GParseTable g) => GParseTable (f :*: g) where
    gParseTable :: forall a. ParseTable ((:*:) f g a)
gParseTable =
     do f a
x <- ParseTable (f a)
forall a. ParseTable (f a)
forall (f :: * -> *) a. GParseTable f => ParseTable (f a)
gParseTable
        g a
y <- ParseTable (g a)
forall a. ParseTable (g a)
forall (f :: * -> *) a. GParseTable f => ParseTable (f a)
gParseTable
        (:*:) f g a -> ParseTable ((:*:) f g a)
forall a. a -> ParseTable a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (f a
x f a -> g a -> (:*:) f g a
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: g a
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 :: forall a. ParseTable (S1 s (K1 i (Maybe a)) a)
gParseTable =
     do Maybe a
x <- String -> ParseTable (Maybe a)
forall a. FromValue a => String -> ParseTable (Maybe a)
optKey (M1 S s [] () -> String
forall {k} (s :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Selector s =>
t s f a -> String
forall k1 (t :: Meta -> (k1 -> *) -> k1 -> *) (f :: k1 -> *)
       (a :: k1).
t s f a -> String
selName ([()] -> M1 S s [] ()
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 [] :: S1 s [] ()))
        S1 s (K1 i (Maybe a)) a -> ParseTable (S1 s (K1 i (Maybe a)) a)
forall a. a -> ParseTable a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (K1 i (Maybe a) a -> S1 s (K1 i (Maybe a)) a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (Maybe a -> K1 i (Maybe a) a
forall k i c (p :: k). c -> K1 i c p
K1 Maybe a
x))
    {-# INLINE gParseTable #-}

-- | Uses record selector name as table key
instance (Selector s, FromValue a) => GParseTable (S1 s (K1 i a)) where
    gParseTable :: forall a. ParseTable (S1 s (K1 i a) a)
gParseTable =
     do a
x <- String -> ParseTable a
forall a. FromValue a => String -> ParseTable a
reqKey (M1 S s [] () -> String
forall {k} (s :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Selector s =>
t s f a -> String
forall k1 (t :: Meta -> (k1 -> *) -> k1 -> *) (f :: k1 -> *)
       (a :: k1).
t s f a -> String
selName ([()] -> M1 S s [] ()
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 [] :: S1 s [] ()))
        S1 s (K1 i a) a -> ParseTable (S1 s (K1 i a) a)
forall a. a -> ParseTable a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (K1 i a a -> S1 s (K1 i a) a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (a -> K1 i a a
forall k i c (p :: k). c -> K1 i c p
K1 a
x))
    {-# INLINE gParseTable #-}

-- | Emits empty table
instance GParseTable U1 where
    gParseTable :: forall a. ParseTable (U1 a)
gParseTable = U1 a -> ParseTable (U1 a)
forall a. a -> ParseTable a
forall (f :: * -> *) a. Applicative f => a -> f a
pure U1 a
forall k (p :: k). U1 p
U1
    {-# INLINE gParseTable #-}

-- | Supports conversion of TOML arrays into product-type values.
--
-- @since 1.3.2.0
class GFromArray f where
    gFromArray :: StateT [Value] Matcher (f a)

instance GFromArray f => GFromArray (M1 i c f) where
    gFromArray :: forall a. StateT [Value] Matcher (M1 i c f a)
    gFromArray :: forall a. StateT [Value] Matcher (M1 i c f a)
gFromArray = StateT [Value] Matcher (f a) -> StateT [Value] Matcher (M1 i c f a)
forall a b. Coercible a b => a -> b
coerce (StateT [Value] Matcher (f a)
forall a. StateT [Value] Matcher (f a)
forall (f :: * -> *) a.
GFromArray f =>
StateT [Value] Matcher (f a)
gFromArray :: StateT [Value] Matcher (f a))
    {-# INLINE gFromArray #-}

instance (GFromArray f, GFromArray g) => GFromArray (f :*: g) where
    gFromArray :: forall a. StateT [Value] Matcher ((:*:) f g a)
gFromArray =
     do f a
x <- StateT [Value] Matcher (f a)
forall a. StateT [Value] Matcher (f a)
forall (f :: * -> *) a.
GFromArray f =>
StateT [Value] Matcher (f a)
gFromArray
        g a
y <- StateT [Value] Matcher (g a)
forall a. StateT [Value] Matcher (g a)
forall (f :: * -> *) a.
GFromArray f =>
StateT [Value] Matcher (f a)
gFromArray
        (:*:) f g a -> StateT [Value] Matcher ((:*:) f g a)
forall a. a -> StateT [Value] Matcher a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (f a
x f a -> g a -> (:*:) f g a
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: g a
y)
    {-# INLINE gFromArray #-}

instance FromValue a => GFromArray (K1 i a) where
    gFromArray :: forall a. StateT [Value] Matcher (K1 i a a)
gFromArray = ([Value] -> Matcher (K1 i a a, [Value]))
-> StateT [Value] Matcher (K1 i a a)
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT \case
        [] -> String -> Matcher (K1 i a a, [Value])
forall a. String -> Matcher a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"array too short"
        Value
x:[Value]
xs -> (\a
v -> (a -> K1 i a a
forall k i c (p :: k). c -> K1 i c p
K1 a
v, [Value]
xs)) (a -> (K1 i a a, [Value]))
-> Matcher a -> Matcher (K1 i a a, [Value])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Matcher a
forall a. FromValue a => Value -> Matcher a
fromValue Value
x
    {-# INLINE gFromArray #-}

-- | Uses no array elements
instance GFromArray U1 where
    gFromArray :: forall a. StateT [Value] Matcher (U1 a)
gFromArray = U1 a -> StateT [Value] Matcher (U1 a)
forall a. a -> StateT [Value] Matcher a
forall (f :: * -> *) a. Applicative f => a -> f a
pure U1 a
forall k (p :: k). U1 p
U1
    {-# INLINE gFromArray #-}