{-# 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 Any -> a
forall a x. Generic a => Rep a x -> a
forall x. Rep a x -> a
to (Rep a Any -> a) -> ParseTable l (Rep a Any) -> ParseTable l a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParseTable l (Rep a Any)
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 (Rep a Any
gen, [Value' l]
xs') <- StateT [Value' l] (Matcher l) (Rep a Any)
-> [Value' l] -> Matcher l (Rep a Any, [Value' l])
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT StateT [Value' l] (Matcher l) (Rep a Any)
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 [Value' l] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Value' l]
xs' then
        a -> Matcher l a
forall a. a -> Matcher l 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
        l -> String -> Matcher l a
forall l a. l -> String -> Matcher l a
failAt l
a (String
"array " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([Value' l] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Value' l]
xs') String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" 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 f a
x <- ParseTable l (f a)
forall l a. ParseTable l (f a)
forall (f :: * -> *) l a. GParseTable f => ParseTable l (f a)
gParseTable
        g a
y <- ParseTable l (g a)
forall l a. ParseTable l (g a)
forall (f :: * -> *) l a. GParseTable f => ParseTable l (f a)
gParseTable
        (:*:) f g a -> ParseTable l ((:*:) f g a)
forall a. a -> ParseTable l 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 l a. ParseTable l (S1 s (K1 i (Maybe a)) a)
gParseTable =
     do Maybe a
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 [] ())))
        S1 s (K1 i (Maybe a)) a -> ParseTable l (S1 s (K1 i (Maybe a)) a)
forall a. a -> ParseTable l 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 l a. ParseTable l (S1 s (K1 i a) a)
gParseTable =
     do a
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 [] ())))
        S1 s (K1 i a) a -> ParseTable l (S1 s (K1 i a) a)
forall a. a -> ParseTable l 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 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 f a
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
        g a
y <- StateT [Value' l] (Matcher l) (g a)
forall l a. StateT [Value' l] (Matcher l) (g a)
forall (f :: * -> *) l a.
GFromArray f =>
StateT [Value' l] (Matcher l) (f a)
gFromArray
        (:*:) f g a -> StateT [Value' l] (Matcher l) ((:*:) f g a)
forall a. a -> StateT [Value' l] (Matcher l) 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 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 #-}