{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeOperators #-}
module Toml.Type.Value
(
TValue (..)
, showType
, Value (..)
, eqValueList
, valueType
, TypeMismatchError (..)
, sameValue
) where
import Control.DeepSeq (NFData (..), rnf)
import Data.String (IsString (..))
import Data.Text (Text)
import Data.Time (Day, LocalTime, TimeOfDay, ZonedTime, zonedTimeToUTC)
import Data.Type.Equality ((:~:) (..))
import GHC.Generics (Generic)
data TValue
= TBool
| TInteger
| TDouble
| TText
| TZoned
| TLocal
| TDay
| THours
| TArray
deriving stock (TValue -> TValue -> Bool
(TValue -> TValue -> Bool)
-> (TValue -> TValue -> Bool) -> Eq TValue
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TValue -> TValue -> Bool
== :: TValue -> TValue -> Bool
$c/= :: TValue -> TValue -> Bool
/= :: TValue -> TValue -> Bool
Eq, Int -> TValue -> ShowS
[TValue] -> ShowS
TValue -> String
(Int -> TValue -> ShowS)
-> (TValue -> String) -> ([TValue] -> ShowS) -> Show TValue
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TValue -> ShowS
showsPrec :: Int -> TValue -> ShowS
$cshow :: TValue -> String
show :: TValue -> String
$cshowList :: [TValue] -> ShowS
showList :: [TValue] -> ShowS
Show, ReadPrec [TValue]
ReadPrec TValue
Int -> ReadS TValue
ReadS [TValue]
(Int -> ReadS TValue)
-> ReadS [TValue]
-> ReadPrec TValue
-> ReadPrec [TValue]
-> Read TValue
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS TValue
readsPrec :: Int -> ReadS TValue
$creadList :: ReadS [TValue]
readList :: ReadS [TValue]
$creadPrec :: ReadPrec TValue
readPrec :: ReadPrec TValue
$creadListPrec :: ReadPrec [TValue]
readListPrec :: ReadPrec [TValue]
Read, (forall x. TValue -> Rep TValue x)
-> (forall x. Rep TValue x -> TValue) -> Generic TValue
forall x. Rep TValue x -> TValue
forall x. TValue -> Rep TValue x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. TValue -> Rep TValue x
from :: forall x. TValue -> Rep TValue x
$cto :: forall x. Rep TValue x -> TValue
to :: forall x. Rep TValue x -> TValue
Generic)
deriving anyclass (TValue -> ()
(TValue -> ()) -> NFData TValue
forall a. (a -> ()) -> NFData a
$crnf :: TValue -> ()
rnf :: TValue -> ()
NFData)
showType :: TValue -> String
showType :: TValue -> String
showType = Int -> ShowS
forall a. Int -> [a] -> [a]
drop Int
1 ShowS -> (TValue -> String) -> TValue -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TValue -> String
forall a. Show a => a -> String
show
data Value (t :: TValue) where
Bool :: Bool -> Value 'TBool
Integer :: Integer -> Value 'TInteger
Double :: Double -> Value 'TDouble
Text :: Text -> Value 'TText
Zoned :: ZonedTime -> Value 'TZoned
Local :: LocalTime -> Value 'TLocal
Day :: Day -> Value 'TDay
Hours :: TimeOfDay -> Value 'THours
Array :: [Value t] -> Value 'TArray
deriving stock instance Show (Value t)
instance NFData (Value t) where
rnf :: Value t -> ()
rnf (Bool Bool
n) = Bool -> ()
forall a. NFData a => a -> ()
rnf Bool
n
rnf (Integer Integer
n) = Integer -> ()
forall a. NFData a => a -> ()
rnf Integer
n
rnf (Double Double
n) = Double -> ()
forall a. NFData a => a -> ()
rnf Double
n
rnf (Text Text
n) = Text -> ()
forall a. NFData a => a -> ()
rnf Text
n
rnf (Zoned ZonedTime
n) = ZonedTime -> ()
forall a. NFData a => a -> ()
rnf ZonedTime
n
rnf (Local LocalTime
n) = LocalTime -> ()
forall a. NFData a => a -> ()
rnf LocalTime
n
rnf (Day Day
n) = Day -> ()
forall a. NFData a => a -> ()
rnf Day
n
rnf (Hours TimeOfDay
n) = TimeOfDay -> ()
forall a. NFData a => a -> ()
rnf TimeOfDay
n
rnf (Array [Value t]
n) = [Value t] -> ()
forall a. NFData a => a -> ()
rnf [Value t]
n
instance (t ~ 'TInteger) => Num (Value t) where
(Integer Integer
a) + :: Value t -> Value t -> Value t
+ (Integer Integer
b) = Integer -> Value 'TInteger
Integer (Integer -> Value 'TInteger) -> Integer -> Value 'TInteger
forall a b. (a -> b) -> a -> b
$ Integer
a Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
b
(Integer Integer
a) * :: Value t -> Value t -> Value t
* (Integer Integer
b) = Integer -> Value 'TInteger
Integer (Integer -> Value 'TInteger) -> Integer -> Value 'TInteger
forall a b. (a -> b) -> a -> b
$ Integer
a Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
b
abs :: Value t -> Value t
abs (Integer Integer
a) = Integer -> Value 'TInteger
Integer (Integer -> Integer
forall a. Num a => a -> a
abs Integer
a)
signum :: Value t -> Value t
signum (Integer Integer
a) = Integer -> Value 'TInteger
Integer (Integer -> Integer
forall a. Num a => a -> a
signum Integer
a)
fromInteger :: Integer -> Value t
fromInteger = Integer -> Value t
Integer -> Value 'TInteger
Integer
negate :: Value t -> Value t
negate (Integer Integer
a) = Integer -> Value 'TInteger
Integer (Integer -> Integer
forall a. Num a => a -> a
negate Integer
a)
instance (t ~ 'TText) => IsString (Value t) where
fromString :: String -> Value t
fromString = Text -> Value t
Text -> Value 'TText
Text (Text -> Value t) -> (String -> Text) -> String -> Value t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsString a => String -> a
fromString @Text
{-# INLINE fromString #-}
instance Eq (Value t) where
(Bool Bool
b1) == :: Value t -> Value t -> Bool
== (Bool Bool
b2) = Bool
b1 Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
b2
(Integer Integer
i1) == (Integer Integer
i2) = Integer
i1 Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
i2
(Double Double
f1) == (Double Double
f2)
| Double -> Bool
forall a. RealFloat a => a -> Bool
isNaN Double
f1 Bool -> Bool -> Bool
&& Double -> Bool
forall a. RealFloat a => a -> Bool
isNaN Double
f2 = Bool
True
| Bool
otherwise = Double
f1 Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
f2
(Text Text
s1) == (Text Text
s2) = Text
s1 Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
s2
(Zoned ZonedTime
a) == (Zoned ZonedTime
b) = ZonedTime -> UTCTime
zonedTimeToUTC ZonedTime
a UTCTime -> UTCTime -> Bool
forall a. Eq a => a -> a -> Bool
== ZonedTime -> UTCTime
zonedTimeToUTC ZonedTime
b
(Local LocalTime
a) == (Local LocalTime
b) = LocalTime
a LocalTime -> LocalTime -> Bool
forall a. Eq a => a -> a -> Bool
== LocalTime
b
(Day Day
a) == (Day Day
b) = Day
a Day -> Day -> Bool
forall a. Eq a => a -> a -> Bool
== Day
b
(Hours TimeOfDay
a) == (Hours TimeOfDay
b) = TimeOfDay
a TimeOfDay -> TimeOfDay -> Bool
forall a. Eq a => a -> a -> Bool
== TimeOfDay
b
(Array [Value t]
a1) == (Array [Value t]
a2) = [Value t] -> [Value t] -> Bool
forall (a :: TValue) (b :: TValue). [Value a] -> [Value b] -> Bool
eqValueList [Value t]
a1 [Value t]
a2
eqValueList :: [Value a] -> [Value b] -> Bool
eqValueList :: forall (a :: TValue) (b :: TValue). [Value a] -> [Value b] -> Bool
eqValueList [] [] = Bool
True
eqValueList (Value a
x:[Value a]
xs) (Value b
y:[Value b]
ys) = case Value a -> Value b -> Either TypeMismatchError (a :~: b)
forall (a :: TValue) (b :: TValue).
Value a -> Value b -> Either TypeMismatchError (a :~: b)
sameValue Value a
x Value b
y of
Right a :~: b
Refl -> Value a
x Value a -> Value a -> Bool
forall a. Eq a => a -> a -> Bool
== Value a
Value b
y Bool -> Bool -> Bool
&& [Value a] -> [Value b] -> Bool
forall (a :: TValue) (b :: TValue). [Value a] -> [Value b] -> Bool
eqValueList [Value a]
xs [Value b]
ys
Left TypeMismatchError
_ -> Bool
False
eqValueList [Value a]
_ [Value b]
_ = Bool
False
valueType :: Value t -> TValue
valueType :: forall (t :: TValue). Value t -> TValue
valueType (Bool Bool
_) = TValue
TBool
valueType (Integer Integer
_) = TValue
TInteger
valueType (Double Double
_) = TValue
TDouble
valueType (Text Text
_) = TValue
TText
valueType (Zoned ZonedTime
_) = TValue
TZoned
valueType (Local LocalTime
_) = TValue
TLocal
valueType (Day Day
_) = TValue
TDay
valueType (Hours TimeOfDay
_) = TValue
THours
valueType (Array [Value t]
_) = TValue
TArray
data TypeMismatchError = TypeMismatchError
{ TypeMismatchError -> TValue
typeExpected :: !TValue
, TypeMismatchError -> TValue
typeActual :: !TValue
} deriving stock (TypeMismatchError -> TypeMismatchError -> Bool
(TypeMismatchError -> TypeMismatchError -> Bool)
-> (TypeMismatchError -> TypeMismatchError -> Bool)
-> Eq TypeMismatchError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TypeMismatchError -> TypeMismatchError -> Bool
== :: TypeMismatchError -> TypeMismatchError -> Bool
$c/= :: TypeMismatchError -> TypeMismatchError -> Bool
/= :: TypeMismatchError -> TypeMismatchError -> Bool
Eq)
instance Show TypeMismatchError where
show :: TypeMismatchError -> String
show TypeMismatchError{TValue
typeExpected :: TypeMismatchError -> TValue
typeActual :: TypeMismatchError -> TValue
typeExpected :: TValue
typeActual :: TValue
..} = String
"Expected type '" String -> ShowS
forall a. [a] -> [a] -> [a]
++ TValue -> String
showType TValue
typeExpected
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"' but actual type: '" String -> ShowS
forall a. [a] -> [a] -> [a]
++ TValue -> String
showType TValue
typeActual String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"'"
sameValue :: Value a -> Value b -> Either TypeMismatchError (a :~: b)
sameValue :: forall (a :: TValue) (b :: TValue).
Value a -> Value b -> Either TypeMismatchError (a :~: b)
sameValue Bool{} Bool{} = (a :~: b) -> Either TypeMismatchError (a :~: b)
forall a b. b -> Either a b
Right a :~: a
a :~: b
forall {k} (a :: k). a :~: a
Refl
sameValue Integer{} Integer{} = (a :~: b) -> Either TypeMismatchError (a :~: b)
forall a b. b -> Either a b
Right a :~: a
a :~: b
forall {k} (a :: k). a :~: a
Refl
sameValue Double{} Double{} = (a :~: b) -> Either TypeMismatchError (a :~: b)
forall a b. b -> Either a b
Right a :~: a
a :~: b
forall {k} (a :: k). a :~: a
Refl
sameValue Text{} Text{} = (a :~: b) -> Either TypeMismatchError (a :~: b)
forall a b. b -> Either a b
Right a :~: a
a :~: b
forall {k} (a :: k). a :~: a
Refl
sameValue Zoned{} Zoned{} = (a :~: b) -> Either TypeMismatchError (a :~: b)
forall a b. b -> Either a b
Right a :~: a
a :~: b
forall {k} (a :: k). a :~: a
Refl
sameValue Local{} Local{} = (a :~: b) -> Either TypeMismatchError (a :~: b)
forall a b. b -> Either a b
Right a :~: a
a :~: b
forall {k} (a :: k). a :~: a
Refl
sameValue Day{} Day{} = (a :~: b) -> Either TypeMismatchError (a :~: b)
forall a b. b -> Either a b
Right a :~: a
a :~: b
forall {k} (a :: k). a :~: a
Refl
sameValue Hours{} Hours{} = (a :~: b) -> Either TypeMismatchError (a :~: b)
forall a b. b -> Either a b
Right a :~: a
a :~: b
forall {k} (a :: k). a :~: a
Refl
sameValue Array{} Array{} = (a :~: b) -> Either TypeMismatchError (a :~: b)
forall a b. b -> Either a b
Right a :~: a
a :~: b
forall {k} (a :: k). a :~: a
Refl
sameValue Value a
l Value b
r = TypeMismatchError -> Either TypeMismatchError (a :~: b)
forall a b. a -> Either a b
Left (TypeMismatchError -> Either TypeMismatchError (a :~: b))
-> TypeMismatchError -> Either TypeMismatchError (a :~: b)
forall a b. (a -> b) -> a -> b
$ TypeMismatchError
{ typeExpected :: TValue
typeExpected = Value a -> TValue
forall (t :: TValue). Value t -> TValue
valueType Value a
l
, typeActual :: TValue
typeActual = Value b -> TValue
forall (t :: TValue). Value t -> TValue
valueType Value b
r
}