{-# LANGUAGE DataKinds          #-}
{-# LANGUAGE DeriveAnyClass     #-}
{-# LANGUAGE FlexibleInstances  #-}
{-# LANGUAGE GADTs              #-}
{-# LANGUAGE KindSignatures     #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeOperators      #-}

{- |
Copyright: (c) 2018-2020 Kowainik
SPDX-License-Identifier: MPL-2.0
Maintainer: Kowainik <xrom.xkov@gmail.com>

GADT value for TOML.

@since 0.0.0
-}

module Toml.Type.Value
       ( -- * Type of value
         TValue (..)
       , showType

         -- * Value
       , Value (..)
       , eqValueList
       , valueType

         -- * Type checking
       , 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)


{- | Needed for GADT parameterization

@since 0.0.0
-}
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)

{- | Convert 'TValue' constructors to 'String' without @T@ prefix.

@since 0.0.0
-}
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

{- | Value in @key = value@ pair.

@since 0.0.0
-}
data Value (t :: TValue) where
    {- | Boolean value:

@
bool1 = true
bool2 = false
@
    -}
    Bool :: Bool -> Value 'TBool

    {- | Integer value:

@
int1 = +99
int2 = 42
int3 = 0
int4 = -17
int5 = 5_349_221
hex1 = 0xDEADBEEF  # hexadecimal
oct2 = 0o755  # octal, useful for Unix file permissions
bin1 = 0b11010110  # binary
@
    -}
    Integer :: Integer -> Value 'TInteger

    {- | Floating point number:

@
# fractional
flt1 = +1.0
flt2 = 3.1415
flt3 = -0.01

# exponent
flt4 = 5e+22
flt5 = 1e6
flt6 = -2E-2

# both
flt7 = 6.626e-34

# infinity
sf1 = inf  # positive infinity
sf2 = +inf # positive infinity
sf3 = -inf # negative infinity

# not a number
sf4 = nan  # actual sNaN/qNaN encoding is implementation specific
sf5 = +nan # same as \`nan\`
sf6 = -nan # same as \`nan\`
@
    -}
    Double :: Double -> Value 'TDouble

    {- | String value:

@
# basic string
name = \"Orange\"
physical.color = "orange"
physical.shape = "round"

# multiline basic string
str1 = """
Roses are red
Violets are blue"""

# literal string: What you see is what you get.
winpath  = 'C:\Users\nodejs\templates'
winpath2 = '\\ServerX\admin$\system32\'
quoted   = 'Tom \"Dubs\" Preston-Werner'
regex    = '<\i\c*\s*>'
@
    -}
    Text :: Text -> Value 'TText

    {- | Offset date-time:

@
odt1 = 1979-05-27T07:32:00Z
odt2 = 1979-05-27T00:32:00-07:00
odt3 = 1979-05-27T00:32:00.999999-07:00
@
    -}
    Zoned :: ZonedTime -> Value 'TZoned

    {- | Local date-time (without offset):

@
ldt1 = 1979-05-27T07:32:00
ldt2 = 1979-05-27T00:32:00.999999
@
    -}
    Local :: LocalTime -> Value 'TLocal

    {- | Local date (only day):

@
ld1 = 1979-05-27
@
    -}
    Day :: Day -> Value 'TDay

    {- | Local time (time of the day):

@
lt1 = 07:32:00
lt2 = 00:32:00.999999

@
    -}
    Hours :: TimeOfDay -> Value 'THours

    {- | Array of values. According to TOML specification all values in array
      should have the same type. This is guaranteed statically with this type.

@
arr1 = [ 1, 2, 3 ]
arr2 = [ "red", "yellow", "green" ]
arr3 = [ [ 1, 2 ], [3, 4, 5] ]
arr4 = [ "all", \'strings\', """are the same""", \'\'\'type\'\'\']
arr5 = [ [ 1, 2 ], ["a", "b", "c"] ]

arr6 = [ 1, 2.0 ] # INVALID
@
    -}
    Array  :: [Value t] -> Value 'TArray

-- | @since 0.0.0
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

{- | Compare list of 'Value' of possibly different types.

@since 0.0.0
-}
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

{- | Reifies type of 'Value' into 'TValue'. Unfortunately, there's no
way to guarantee that 'valueType' will return @t@ for object with type
@Value \'t@.

@since 0.0.0
-}
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

----------------------------------------------------------------------------
-- Typechecking values
----------------------------------------------------------------------------

{- | Data type that holds expected vs. actual type.

@since 0.1.0
-}
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)

-- | @since 0.1.0
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]
++ "'"

{- | Checks whether two values are the same. This function is used for type
checking where first argument is expected type and second argument is actual
type.

@since 0.0.0
-}
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
                                         }