    {-# 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 :: forall a l. (Generic a, GParseTable (Rep a)) => ParseTable l a
    genericParseTable = Rep a (ZonkAny 1) -> a
    forall a x. Generic a => Rep a x -> a
    forall x. Rep a x -> a
    to (Rep a (ZonkAny 1) -> a)
    -> ParseTable l (Rep a (ZonkAny 1)) -> ParseTable l a
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> ParseTable l (Rep a (ZonkAny 1))
    forall l a. ParseTable l (Rep a a)
    forall (f :: * -> *) l a. GParseTable f => ParseTable l (f a)
    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 :: forall a l.
    (Generic a, GParseTable (Rep a)) =>
    Value' l -> Matcher l a
    genericFromTable = ParseTable l a -> Value' l -> Matcher l a
    forall l a. ParseTable l a -> Value' l -> Matcher l a
    parseTableFromValue ParseTable l a
    forall a l. (Generic a, GParseTable (Rep a)) => ParseTable l a
    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 :: forall a l.
    (Generic a, GFromArray (Rep a)) =>
    Value' l -> Matcher l a
    genericFromArray (List' l
    a [Value' l]
    xs) =
     do (gen, xs') <- StateT [Value' l] (Matcher l) (Rep a (ZonkAny 0))
    -> [Value' l] -> Matcher l (Rep a (ZonkAny 0), [Value' l])
    forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
    runStateT StateT [Value' l] (Matcher l) (Rep a (ZonkAny 0))
    forall l a. StateT [Value' l] (Matcher l) (Rep a a)
    forall (f :: * -> *) l a.
    GFromArray f =>
    StateT [Value' l] (Matcher l) (f a)
    gFromArray [Value' l]
    xs
        if null xs' then
            pure (to gen)
        else
            failAt a ("array " ++ show (length xs') ++ " elements too long")
    genericFromArray Value' l
    v = String -> Value' l -> Matcher l a
    forall l a. String -> Value' l -> Matcher l a
    typeError String
    "array" Value' l
    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 :: forall l a. ParseTable l (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 l (f a) -> ParseTable l (M1 D c f a)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$>  ParseTable l (f a)
    forall l a. ParseTable l (f a)
    forall (f :: * -> *) l a. GParseTable f => ParseTable l (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 l a. ParseTable l (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 l (f a)
    -> ParseTable l (M1 C ('MetaCons sym fix 'True) f a)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> ParseTable l (f a)
    forall l a. ParseTable l (f a)
    forall (f :: * -> *) l a. GParseTable f => ParseTable l (f a)
    gParseTable
        {-# INLINE gParseTable #-}

    -- | Matches left then right component
    instance (GParseTable f, GParseTable g) => GParseTable (f :*: g) where
        gParseTable :: forall l a. ParseTable l ((:*:) f g a)
    gParseTable =
         do x <- ParseTable l (f a)
    forall l a. ParseTable l (f a)
    forall (f :: * -> *) l a. GParseTable f => ParseTable l (f a)
    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 :: forall l a. ParseTable l (S1 s (K1 i (Maybe a)) a)
    gParseTable =
         do x <- Text -> ParseTable l (Maybe a)
    forall a l. FromValue a => Text -> ParseTable l (Maybe a)
    optKey (String -> Text
    Text.pack (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 [] ())))
            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 :: forall l a. ParseTable l (S1 s (K1 i a) a)
    gParseTable =
         do x <- Text -> ParseTable l a
    forall a l. FromValue a => Text -> ParseTable l a
    reqKey (String -> Text
    Text.pack (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 [] ())))
            pure (M1 (K1 x))
        {-# INLINE gParseTable #-}

    -- | Emits empty table
    instance GParseTable U1 where
        gParseTable :: forall l a. ParseTable l (U1 a)
    gParseTable = U1 a -> ParseTable l (U1 a)
    forall a. a -> ParseTable l 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.
    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 :: forall a l. StateT [Value' l] (Matcher l) (M1 i c f a)
    gFromArray = StateT [Value' l] (Matcher l) (f a)
    -> StateT [Value' l] (Matcher l) (M1 i c f a)
    forall a b. Coercible a b => a -> b
    coerce (StateT [Value' l] (Matcher l) (f a)
    forall l a. StateT [Value' l] (Matcher l) (f a)
    forall (f :: * -> *) l a.
    GFromArray f =>
    StateT [Value' l] (Matcher l) (f a)
    gFromArray :: StateT [Value' l] (Matcher l) (f a))
        {-# INLINE gFromArray #-}

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

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

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