{-# Language DataKinds, InstanceSigs, ScopedTypeVariables, TypeOperators #-}
module Toml.Schema.Generic.FromValue (
GParseTable(..),
genericParseTable,
genericFromTable,
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'))
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 #-}
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 #-}
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 #-}
class GParseTable f where
gParseTable :: ParseTable l (f a)
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 #-}
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 #-}
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 #-}
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 #-}
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 #-}
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 #-}
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 #-}
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 #-}