{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
module Toml.Type.AnyValue
( AnyValue (..)
, reifyAnyValues
, toMArray
, MatchError (..)
, mkMatchError
, matchBool
, matchInteger
, matchDouble
, matchText
, matchZoned
, matchLocal
, matchDay
, matchHours
, matchArray
, applyAsToAny
) where
import Control.DeepSeq (NFData, rnf)
import Data.Text (Text)
import Data.Time (Day, LocalTime, TimeOfDay, ZonedTime)
import Data.Type.Equality ((:~:) (..))
import GHC.Generics (Generic)
import Toml.Type.Value (TValue (..), TypeMismatchError (..), Value (..), sameValue)
data AnyValue = forall (t :: TValue) . AnyValue (Value t)
instance Show AnyValue where
show :: AnyValue -> String
show (AnyValue Value t
v) = Value t -> String
forall a. Show a => a -> String
show Value t
v
instance Eq AnyValue where
(AnyValue Value t
val1) == :: AnyValue -> AnyValue -> Bool
== (AnyValue Value t
val2) = case Value t -> Value t -> Either TypeMismatchError (t :~: t)
forall (a :: TValue) (b :: TValue).
Value a -> Value b -> Either TypeMismatchError (a :~: b)
sameValue Value t
val1 Value t
val2 of
Right t :~: t
Refl -> Value t
val1 Value t -> Value t -> Bool
forall a. Eq a => a -> a -> Bool
== Value t
Value t
val2
Left TypeMismatchError
_ -> Bool
False
instance NFData AnyValue where
rnf :: AnyValue -> ()
rnf (AnyValue Value t
val) = Value t -> ()
forall a. NFData a => a -> ()
rnf Value t
val
data MatchError = MatchError
{ MatchError -> TValue
valueExpected :: !TValue
, MatchError -> AnyValue
valueActual :: !AnyValue
} deriving stock (MatchError -> MatchError -> Bool
(MatchError -> MatchError -> Bool)
-> (MatchError -> MatchError -> Bool) -> Eq MatchError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MatchError -> MatchError -> Bool
== :: MatchError -> MatchError -> Bool
$c/= :: MatchError -> MatchError -> Bool
/= :: MatchError -> MatchError -> Bool
Eq, Int -> MatchError -> ShowS
[MatchError] -> ShowS
MatchError -> String
(Int -> MatchError -> ShowS)
-> (MatchError -> String)
-> ([MatchError] -> ShowS)
-> Show MatchError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MatchError -> ShowS
showsPrec :: Int -> MatchError -> ShowS
$cshow :: MatchError -> String
show :: MatchError -> String
$cshowList :: [MatchError] -> ShowS
showList :: [MatchError] -> ShowS
Show, (forall x. MatchError -> Rep MatchError x)
-> (forall x. Rep MatchError x -> MatchError) -> Generic MatchError
forall x. Rep MatchError x -> MatchError
forall x. MatchError -> Rep MatchError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. MatchError -> Rep MatchError x
from :: forall x. MatchError -> Rep MatchError x
$cto :: forall x. Rep MatchError x -> MatchError
to :: forall x. Rep MatchError x -> MatchError
Generic)
deriving anyclass (MatchError -> ()
(MatchError -> ()) -> NFData MatchError
forall a. (a -> ()) -> NFData a
$crnf :: MatchError -> ()
rnf :: MatchError -> ()
NFData)
mkMatchError :: TValue -> Value t -> Either MatchError a
mkMatchError :: forall (t :: TValue) a. TValue -> Value t -> Either MatchError a
mkMatchError TValue
t = MatchError -> Either MatchError a
forall a b. a -> Either a b
Left (MatchError -> Either MatchError a)
-> (Value t -> MatchError) -> Value t -> Either MatchError a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TValue -> AnyValue -> MatchError
MatchError TValue
t (AnyValue -> MatchError)
-> (Value t -> AnyValue) -> Value t -> MatchError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value t -> AnyValue
forall (t :: TValue). Value t -> AnyValue
AnyValue
matchBool :: Value t -> Either MatchError Bool
matchBool :: forall (t :: TValue). Value t -> Either MatchError Bool
matchBool (Bool Bool
b) = Bool -> Either MatchError Bool
forall a b. b -> Either a b
Right Bool
b
matchBool Value t
value = TValue -> Value t -> Either MatchError Bool
forall (t :: TValue) a. TValue -> Value t -> Either MatchError a
mkMatchError TValue
TBool Value t
value
{-# INLINE matchBool #-}
matchInteger :: Value t -> Either MatchError Integer
matchInteger :: forall (t :: TValue). Value t -> Either MatchError Integer
matchInteger (Integer Integer
n) = Integer -> Either MatchError Integer
forall a b. b -> Either a b
Right Integer
n
matchInteger Value t
value = TValue -> Value t -> Either MatchError Integer
forall (t :: TValue) a. TValue -> Value t -> Either MatchError a
mkMatchError TValue
TInteger Value t
value
{-# INLINE matchInteger #-}
matchDouble :: Value t -> Either MatchError Double
matchDouble :: forall (t :: TValue). Value t -> Either MatchError Double
matchDouble (Double Double
f) = Double -> Either MatchError Double
forall a b. b -> Either a b
Right Double
f
matchDouble Value t
value = TValue -> Value t -> Either MatchError Double
forall (t :: TValue) a. TValue -> Value t -> Either MatchError a
mkMatchError TValue
TDouble Value t
value
{-# INLINE matchDouble #-}
matchText :: Value t -> Either MatchError Text
matchText :: forall (t :: TValue). Value t -> Either MatchError Text
matchText (Text Text
s) = Text -> Either MatchError Text
forall a b. b -> Either a b
Right Text
s
matchText Value t
value = TValue -> Value t -> Either MatchError Text
forall (t :: TValue) a. TValue -> Value t -> Either MatchError a
mkMatchError TValue
TText Value t
value
{-# INLINE matchText #-}
matchZoned :: Value t -> Either MatchError ZonedTime
matchZoned :: forall (t :: TValue). Value t -> Either MatchError ZonedTime
matchZoned (Zoned ZonedTime
d) = ZonedTime -> Either MatchError ZonedTime
forall a b. b -> Either a b
Right ZonedTime
d
matchZoned Value t
value = TValue -> Value t -> Either MatchError ZonedTime
forall (t :: TValue) a. TValue -> Value t -> Either MatchError a
mkMatchError TValue
TZoned Value t
value
{-# INLINE matchZoned #-}
matchLocal :: Value t -> Either MatchError LocalTime
matchLocal :: forall (t :: TValue). Value t -> Either MatchError LocalTime
matchLocal (Local LocalTime
d) = LocalTime -> Either MatchError LocalTime
forall a b. b -> Either a b
Right LocalTime
d
matchLocal Value t
value = TValue -> Value t -> Either MatchError LocalTime
forall (t :: TValue) a. TValue -> Value t -> Either MatchError a
mkMatchError TValue
TLocal Value t
value
{-# INLINE matchLocal #-}
matchDay :: Value t -> Either MatchError Day
matchDay :: forall (t :: TValue). Value t -> Either MatchError Day
matchDay (Day Day
d) = Day -> Either MatchError Day
forall a b. b -> Either a b
Right Day
d
matchDay Value t
value = TValue -> Value t -> Either MatchError Day
forall (t :: TValue) a. TValue -> Value t -> Either MatchError a
mkMatchError TValue
TDay Value t
value
{-# INLINE matchDay #-}
matchHours :: Value t -> Either MatchError TimeOfDay
matchHours :: forall (t :: TValue). Value t -> Either MatchError TimeOfDay
matchHours (Hours TimeOfDay
d) = TimeOfDay -> Either MatchError TimeOfDay
forall a b. b -> Either a b
Right TimeOfDay
d
matchHours Value t
value = TValue -> Value t -> Either MatchError TimeOfDay
forall (t :: TValue) a. TValue -> Value t -> Either MatchError a
mkMatchError TValue
THours Value t
value
{-# INLINE matchHours #-}
matchArray :: (AnyValue -> Either MatchError a) -> Value t -> Either MatchError [a]
matchArray :: forall a (t :: TValue).
(AnyValue -> Either MatchError a)
-> Value t -> Either MatchError [a]
matchArray AnyValue -> Either MatchError a
matchValue (Array [Value t1]
a) = (Value t1 -> Either MatchError a)
-> [Value t1] -> Either MatchError [a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((AnyValue -> Either MatchError a)
-> Value t1 -> Either MatchError a
forall r (t :: TValue). (AnyValue -> r) -> Value t -> r
applyAsToAny AnyValue -> Either MatchError a
matchValue) [Value t1]
a
matchArray AnyValue -> Either MatchError a
_ Value t
value = TValue -> Value t -> Either MatchError [a]
forall (t :: TValue) a. TValue -> Value t -> Either MatchError a
mkMatchError TValue
TArray Value t
value
{-# INLINE matchArray #-}
applyAsToAny :: (AnyValue -> r) -> (Value t -> r)
applyAsToAny :: forall r (t :: TValue). (AnyValue -> r) -> Value t -> r
applyAsToAny AnyValue -> r
f = AnyValue -> r
f (AnyValue -> r) -> (Value t -> AnyValue) -> Value t -> r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value t -> AnyValue
forall (t :: TValue). Value t -> AnyValue
AnyValue
reifyAnyValues :: Value t -> [AnyValue] -> Either TypeMismatchError [Value t]
reifyAnyValues :: forall (t :: TValue).
Value t -> [AnyValue] -> Either TypeMismatchError [Value t]
reifyAnyValues Value t
_ [] = [Value t] -> Either TypeMismatchError [Value t]
forall a b. b -> Either a b
Right []
reifyAnyValues Value t
v (AnyValue Value t
av : [AnyValue]
xs) = Value t -> Value t -> Either TypeMismatchError (t :~: t)
forall (a :: TValue) (b :: TValue).
Value a -> Value b -> Either TypeMismatchError (a :~: b)
sameValue Value t
v Value t
av Either TypeMismatchError (t :~: t)
-> ((t :~: t) -> Either TypeMismatchError [Value t])
-> Either TypeMismatchError [Value t]
forall a b.
Either TypeMismatchError a
-> (a -> Either TypeMismatchError b) -> Either TypeMismatchError b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \t :~: t
Refl -> (Value t
Value t
av Value t -> [Value t] -> [Value t]
forall a. a -> [a] -> [a]
:) ([Value t] -> [Value t])
-> Either TypeMismatchError [Value t]
-> Either TypeMismatchError [Value t]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value t -> [AnyValue] -> Either TypeMismatchError [Value t]
forall (t :: TValue).
Value t -> [AnyValue] -> Either TypeMismatchError [Value t]
reifyAnyValues Value t
v [AnyValue]
xs
toMArray :: [AnyValue] -> Either MatchError (Value 'TArray)
toMArray :: [AnyValue] -> Either MatchError (Value 'TArray)
toMArray [] = Value 'TArray -> Either MatchError (Value 'TArray)
forall a b. b -> Either a b
Right (Value 'TArray -> Either MatchError (Value 'TArray))
-> Value 'TArray -> Either MatchError (Value 'TArray)
forall a b. (a -> b) -> a -> b
$ [Value Any] -> Value 'TArray
forall (t1 :: TValue). [Value t1] -> Value 'TArray
Array []
toMArray (AnyValue Value t
x : [AnyValue]
xs) = case Value t -> [AnyValue] -> Either TypeMismatchError [Value t]
forall (t :: TValue).
Value t -> [AnyValue] -> Either TypeMismatchError [Value t]
reifyAnyValues Value t
x [AnyValue]
xs of
Left TypeMismatchError{TValue
typeExpected :: TValue
typeActual :: TValue
typeExpected :: TypeMismatchError -> TValue
typeActual :: TypeMismatchError -> TValue
..} -> TValue -> Value t -> Either MatchError (Value 'TArray)
forall (t :: TValue) a. TValue -> Value t -> Either MatchError a
mkMatchError TValue
typeExpected Value t
x
Right [Value t]
vals -> Value 'TArray -> Either MatchError (Value 'TArray)
forall a b. b -> Either a b
Right (Value 'TArray -> Either MatchError (Value 'TArray))
-> Value 'TArray -> Either MatchError (Value 'TArray)
forall a b. (a -> b) -> a -> b
$ [Value t] -> Value 'TArray
forall (t1 :: TValue). [Value t1] -> Value 'TArray
Array (Value t
x Value t -> [Value t] -> [Value t]
forall a. a -> [a] -> [a]
: [Value t]
vals)