{-# 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
/= :: TValue -> TValue -> Bool
$c/= :: TValue -> TValue -> Bool
== :: TValue -> TValue -> Bool
$c== :: 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
showList :: [TValue] -> ShowS
$cshowList :: [TValue] -> ShowS
show :: TValue -> String
$cshow :: TValue -> String
showsPrec :: Int -> TValue -> ShowS
$cshowsPrec :: Int -> 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
readListPrec :: ReadPrec [TValue]
$creadListPrec :: ReadPrec [TValue]
readPrec :: ReadPrec TValue
$creadPrec :: ReadPrec TValue
readList :: ReadS [TValue]
$creadList :: ReadS [TValue]
readsPrec :: Int -> ReadS TValue
$creadsPrec :: Int -> ReadS 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
$cto :: forall x. Rep TValue x -> TValue
$cfrom :: forall x. TValue -> Rep TValue x
Generic)
deriving anyclass (TValue -> ()
(TValue -> ()) -> NFData TValue
forall a. (a -> ()) -> NFData a
rnf :: TValue -> ()
$crnf :: TValue -> ()
NFData)
showType :: TValue -> String
showType :: TValue -> String
showType = Int -> ShowS
forall a. Int -> [a] -> [a]
drop 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 n :: Bool
n) = Bool -> ()
forall a. NFData a => a -> ()
rnf Bool
n
rnf (Integer n :: Integer
n) = Integer -> ()
forall a. NFData a => a -> ()
rnf Integer
n
rnf (Double n :: Double
n) = Double -> ()
forall a. NFData a => a -> ()
rnf Double
n
rnf (Text n :: Text
n) = Text -> ()
forall a. NFData a => a -> ()
rnf Text
n
rnf (Zoned n :: ZonedTime
n) = ZonedTime -> ()
forall a. NFData a => a -> ()
rnf ZonedTime
n
rnf (Local n :: LocalTime
n) = LocalTime -> ()
forall a. NFData a => a -> ()
rnf LocalTime
n
rnf (Day n :: Day
n) = Day -> ()
forall a. NFData a => a -> ()
rnf Day
n
rnf (Hours n :: TimeOfDay
n) = TimeOfDay -> ()
forall a. NFData a => a -> ()
rnf TimeOfDay
n
rnf (Array n :: [Value t]
n) = [Value t] -> ()
forall a. NFData a => a -> ()
rnf [Value t]
n
instance (t ~ 'TInteger) => Num (Value t) where
(Integer a :: Integer
a) + :: Value t -> Value t -> Value t
+ (Integer b :: Integer
b) = Integer -> Value t
Integer -> Value 'TInteger
Integer (Integer -> Value t) -> Integer -> Value t
forall a b. (a -> b) -> a -> b
$ Integer
a Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
b
(Integer a :: Integer
a) * :: Value t -> Value t -> Value t
* (Integer b :: Integer
b) = Integer -> Value t
Integer -> Value 'TInteger
Integer (Integer -> Value t) -> Integer -> Value t
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 a :: Integer
a) = Integer -> Value 'TInteger
Integer (Integer -> Integer
forall a. Num a => a -> a
abs Integer
a)
signum :: Value t -> Value t
signum (Integer a :: 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 a :: 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 'TText
Text (Text -> Value 'TText)
-> (String -> Text) -> String -> Value 'TText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IsString Text => String -> Text
forall a. IsString a => String -> a
fromString @Text
{-# INLINE fromString #-}
instance Eq (Value t) where
(Bool b1 :: Bool
b1) == :: Value t -> Value t -> Bool
== (Bool b2 :: Bool
b2) = Bool
b1 Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
b2
(Integer i1 :: Integer
i1) == (Integer i2 :: Integer
i2) = Integer
i1 Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
i2
(Double f1 :: Double
f1) == (Double f2 :: 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 s1 :: Text
s1) == (Text s2 :: Text
s2) = Text
s1 Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
s2
(Zoned a :: ZonedTime
a) == (Zoned b :: ZonedTime
b) = ZonedTime -> UTCTime
zonedTimeToUTC ZonedTime
a UTCTime -> UTCTime -> Bool
forall a. Eq a => a -> a -> Bool
== ZonedTime -> UTCTime
zonedTimeToUTC ZonedTime
b
(Local a :: LocalTime
a) == (Local b :: LocalTime
b) = LocalTime
a LocalTime -> LocalTime -> Bool
forall a. Eq a => a -> a -> Bool
== LocalTime
b
(Day a :: Day
a) == (Day b :: Day
b) = Day
a Day -> Day -> Bool
forall a. Eq a => a -> a -> Bool
== Day
b
(Hours a :: TimeOfDay
a) == (Hours b :: TimeOfDay
b) = TimeOfDay
a TimeOfDay -> TimeOfDay -> Bool
forall a. Eq a => a -> a -> Bool
== TimeOfDay
b
(Array a1 :: [Value t]
a1) == (Array a2 :: [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 :: [Value a] -> [Value b] -> Bool
eqValueList [] [] = Bool
True
eqValueList (x :: Value a
x:xs :: [Value a]
xs) (y :: Value b
y:ys :: [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 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 _ -> Bool
False
eqValueList _ _ = Bool
False
valueType :: Value t -> TValue
valueType :: Value t -> TValue
valueType (Bool _) = TValue
TBool
valueType (Integer _) = TValue
TInteger
valueType (Double _) = TValue
TDouble
valueType (Text _) = TValue
TText
valueType (Zoned _) = TValue
TZoned
valueType (Local _) = TValue
TLocal
valueType (Day _) = TValue
TDay
valueType (Hours _) = TValue
THours
valueType (Array _) = 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
/= :: TypeMismatchError -> TypeMismatchError -> Bool
$c/= :: TypeMismatchError -> TypeMismatchError -> Bool
== :: TypeMismatchError -> TypeMismatchError -> Bool
$c== :: TypeMismatchError -> TypeMismatchError -> Bool
Eq)
instance Show TypeMismatchError where
show :: TypeMismatchError -> String
show TypeMismatchError{..} = "Expected type '" String -> ShowS
forall a. [a] -> [a] -> [a]
++ TValue -> String
showType TValue
typeExpected
String -> ShowS
forall a. [a] -> [a] -> [a]
++ "' but actual type: '" String -> ShowS
forall a. [a] -> [a] -> [a]
++ TValue -> String
showType TValue
typeActual String -> ShowS
forall a. [a] -> [a] -> [a]
++ "'"
sameValue :: Value a -> Value b -> Either TypeMismatchError (a :~: b)
sameValue :: Value a -> Value b -> Either TypeMismatchError (a :~: b)
sameValue Bool{} Bool{} = (a :~: a) -> Either TypeMismatchError (a :~: a)
forall a b. b -> Either a b
Right a :~: a
forall k (a :: k). a :~: a
Refl
sameValue Integer{} Integer{} = (a :~: a) -> Either TypeMismatchError (a :~: a)
forall a b. b -> Either a b
Right a :~: a
forall k (a :: k). a :~: a
Refl
sameValue Double{} Double{} = (a :~: a) -> Either TypeMismatchError (a :~: a)
forall a b. b -> Either a b
Right a :~: a
forall k (a :: k). a :~: a
Refl
sameValue Text{} Text{} = (a :~: a) -> Either TypeMismatchError (a :~: a)
forall a b. b -> Either a b
Right a :~: a
forall k (a :: k). a :~: a
Refl
sameValue Zoned{} Zoned{} = (a :~: a) -> Either TypeMismatchError (a :~: a)
forall a b. b -> Either a b
Right a :~: a
forall k (a :: k). a :~: a
Refl
sameValue Local{} Local{} = (a :~: a) -> Either TypeMismatchError (a :~: a)
forall a b. b -> Either a b
Right a :~: a
forall k (a :: k). a :~: a
Refl
sameValue Day{} Day{} = (a :~: a) -> Either TypeMismatchError (a :~: a)
forall a b. b -> Either a b
Right a :~: a
forall k (a :: k). a :~: a
Refl
sameValue Hours{} Hours{} = (a :~: a) -> Either TypeMismatchError (a :~: a)
forall a b. b -> Either a b
Right a :~: a
forall k (a :: k). a :~: a
Refl
sameValue Array{} Array{} = (a :~: a) -> Either TypeMismatchError (a :~: a)
forall a b. b -> Either a b
Right a :~: a
forall k (a :: k). a :~: a
Refl
sameValue l :: Value a
l r :: 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
$ $WTypeMismatchError :: TValue -> TValue -> TypeMismatchError
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
}