{-# LANGUAGE AllowAmbiguousTypes       #-}
{-# LANGUAGE DataKinds                 #-}
{-# LANGUAGE DeriveAnyClass            #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE GADTs                     #-}
{-# LANGUAGE KindSignatures            #-}

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

Existential wrapper over 'Value' type and matching functions.
-}

module Toml.Type.AnyValue
       ( AnyValue (..)
       , reifyAnyValues
       , toMArray

         -- * Matching
       , 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)


-- | Existential wrapper for 'Value'.
data AnyValue = forall (t :: TValue) . AnyValue (Value t)

instance Show AnyValue where
    show :: AnyValue -> String
show (AnyValue v :: Value t
v) = Value t -> String
forall a. Show a => a -> String
show Value t
v

instance Eq AnyValue where
    (AnyValue val1 :: Value t
val1) == :: AnyValue -> AnyValue -> Bool
== (AnyValue val2 :: 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 Refl -> Value t
val1 Value t -> Value t -> Bool
forall a. Eq a => a -> a -> Bool
== Value t
Value t
val2
        Left _     -> Bool
False

instance NFData AnyValue where
    rnf :: AnyValue -> ()
rnf (AnyValue val :: Value t
val) = Value t -> ()
forall a. NFData a => a -> ()
rnf Value t
val

-- | Value type mismatch error.
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
/= :: MatchError -> MatchError -> Bool
$c/= :: MatchError -> MatchError -> Bool
== :: MatchError -> MatchError -> Bool
$c== :: 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
showList :: [MatchError] -> ShowS
$cshowList :: [MatchError] -> ShowS
show :: MatchError -> String
$cshow :: MatchError -> String
showsPrec :: Int -> MatchError -> ShowS
$cshowsPrec :: Int -> 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
$cto :: forall x. Rep MatchError x -> MatchError
$cfrom :: forall x. MatchError -> Rep MatchError x
Generic)
      deriving anyclass (MatchError -> ()
(MatchError -> ()) -> NFData MatchError
forall a. (a -> ()) -> NFData a
rnf :: MatchError -> ()
$crnf :: MatchError -> ()
NFData)

-- | Helper function to create 'MatchError'.
mkMatchError :: TValue -> Value t -> Either MatchError a
mkMatchError :: TValue -> Value t -> Either MatchError a
mkMatchError t :: 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

----------------------------------------------------------------------------
-- Matching functions for values
----------------------------------------------------------------------------

-- | Extract 'Prelude.Bool' from 'Value'.
matchBool :: Value t -> Either MatchError Bool
matchBool :: Value t -> Either MatchError Bool
matchBool (Bool b :: Bool
b) = Bool -> Either MatchError Bool
forall a b. b -> Either a b
Right Bool
b
matchBool value :: 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 #-}

-- | Extract 'Prelude.Integer' from 'Value'.
matchInteger :: Value t -> Either MatchError Integer
matchInteger :: Value t -> Either MatchError Integer
matchInteger (Integer n :: Integer
n) = Integer -> Either MatchError Integer
forall a b. b -> Either a b
Right Integer
n
matchInteger value :: 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 #-}

-- | Extract 'Prelude.Double' from 'Value'.
matchDouble :: Value t -> Either MatchError Double
matchDouble :: Value t -> Either MatchError Double
matchDouble (Double f :: Double
f) = Double -> Either MatchError Double
forall a b. b -> Either a b
Right Double
f
matchDouble value :: 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 #-}

-- | Extract 'Data.Text.Text' from 'Value'.
matchText :: Value t -> Either MatchError Text
matchText :: Value t -> Either MatchError Text
matchText (Text s :: Text
s) = Text -> Either MatchError Text
forall a b. b -> Either a b
Right Text
s
matchText value :: 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 #-}

-- | Extract 'Data.Time.ZonedTime' from 'Value'.
matchZoned :: Value t -> Either MatchError ZonedTime
matchZoned :: Value t -> Either MatchError ZonedTime
matchZoned (Zoned d :: ZonedTime
d) = ZonedTime -> Either MatchError ZonedTime
forall a b. b -> Either a b
Right ZonedTime
d
matchZoned value :: 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 #-}

-- | Extract 'Data.Time.LocalTime' from 'Value'.
matchLocal :: Value t -> Either MatchError LocalTime
matchLocal :: Value t -> Either MatchError LocalTime
matchLocal (Local d :: LocalTime
d) = LocalTime -> Either MatchError LocalTime
forall a b. b -> Either a b
Right LocalTime
d
matchLocal value :: 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 #-}

-- | Extract 'Data.Time.Day' from 'Value'.
matchDay :: Value t -> Either MatchError Day
matchDay :: Value t -> Either MatchError Day
matchDay (Day d :: Day
d) = Day -> Either MatchError Day
forall a b. b -> Either a b
Right Day
d
matchDay value :: 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 #-}

-- | Extract 'Data.Time.TimeOfDay' from 'Value'.
matchHours :: Value t -> Either MatchError TimeOfDay
matchHours :: Value t -> Either MatchError TimeOfDay
matchHours (Hours d :: TimeOfDay
d) = TimeOfDay -> Either MatchError TimeOfDay
forall a b. b -> Either a b
Right TimeOfDay
d
matchHours value :: 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 #-}

-- | Extract list of elements of type @a@ from array.
matchArray :: (AnyValue -> Either MatchError a) -> Value t -> Either MatchError [a]
matchArray :: (AnyValue -> Either MatchError a)
-> Value t -> Either MatchError [a]
matchArray matchValue :: AnyValue -> Either MatchError a
matchValue (Array a :: [Value t]
a) = (Value t -> Either MatchError a)
-> [Value t] -> Either MatchError [a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((AnyValue -> Either MatchError a) -> Value t -> Either MatchError a
forall r (t :: TValue). (AnyValue -> r) -> Value t -> r
applyAsToAny AnyValue -> Either MatchError a
matchValue) [Value t]
a
matchArray _          value :: 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 #-}

-- | Make function that works with 'AnyValue' also work with specific 'Value'.
applyAsToAny :: (AnyValue -> r) -> (Value t -> r)
applyAsToAny :: (AnyValue -> r) -> Value t -> r
applyAsToAny f :: 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

-- | Checks whether all elements inside given list of 'AnyValue' have the same
-- type as given 'Value'. Returns list of @Value t@ without given 'Value'.
reifyAnyValues :: Value t -> [AnyValue] -> Either TypeMismatchError [Value t]
reifyAnyValues :: Value t -> [AnyValue] -> Either TypeMismatchError [Value t]
reifyAnyValues _ []                 = [Value t] -> Either TypeMismatchError [Value t]
forall a b. b -> Either a b
Right []
reifyAnyValues v :: Value t
v (AnyValue av :: Value t
av : xs :: [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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Refl -> (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

-- | Function for creating 'Array' from list of 'AnyValue'.
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 (t :: TValue). [Value t] -> Value 'TArray
Array []
toMArray (AnyValue x :: Value t
x : xs :: [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 -> Value t -> Either MatchError (Value 'TArray)
forall (t :: TValue) a. TValue -> Value t -> Either MatchError a
mkMatchError TValue
typeExpected Value t
x
    Right vals :: [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 (t :: TValue). [Value t] -> Value 'TArray
Array (Value t
x Value t -> [Value t] -> [Value t]
forall a. a -> [a] -> [a]
: [Value t]
vals)