{-# LANGUAGE DeriveDataTypeable  #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving  #-}
{-# LANGUAGE TypeOperators       #-}
-- |
-- Module      :  Pinch.Internal.TType
-- Copyright   :  (c) Abhinav Gupta 2015
-- License     :  BSD3
--
-- Maintainer  :  Abhinav Gupta <mail@abhinavg.net>
-- Stability   :  experimental
--
-- Defines the different types Thrift supports at the protocol level.
--
module Pinch.Internal.TType
    (
    -- * TType

      TType(..)
    , IsTType(..)
    , SomeTType(..)

    , ttypeEquality
    , ttypeEqT

    -- * Tags

    , TBool
    , TByte
    , TDouble
    , TInt16
    , TInt32
    , TEnum
    , TInt64
    , TBinary
    , TText
    , TStruct
    , TUnion
    , TException
    , TMap
    , TSet
    , TList
    ) where

import Data.Hashable (Hashable (..))
import Data.Typeable ((:~:) (..), Typeable)

-- | > bool
data TBool   deriving (Typeable)

-- | > byte
data TByte   deriving (Typeable)

-- | > double
data TDouble deriving (Typeable)

-- | > i16
data TInt16  deriving (Typeable)

-- | > i32
data TInt32  deriving (Typeable)

-- | > enum
type TEnum = TInt32

-- | > i64
data TInt64  deriving (Typeable)

-- | > binary
data TBinary deriving (Typeable)

-- | > string
type TText = TBinary

-- | > struct
data TStruct deriving (Typeable)

-- | > union
type TUnion = TStruct

-- | > exception
type TException = TStruct

-- | > map<k, v>
data TMap    deriving (Typeable)

-- | > set<x>
data TSet    deriving (Typeable)

-- | > list<x>
data TList   deriving (Typeable)


-- | Represents the type of a Thrift value.
--
-- Objects of this type are tagged with one of the TType tags, so this type
-- also acts as a singleton on the TTypes. It allows writing code that can
-- enforce properties about the TType of values at compile time.
data TType a where
    TBool   :: TType TBool    -- 2
    TByte   :: TType TByte    -- 3
    TDouble :: TType TDouble  -- 4
    TInt16  :: TType TInt16   -- 6
    TInt32  :: TType TInt32   -- 8
    TInt64  :: TType TInt64   -- 10
    TBinary :: TType TBinary  -- 11
    TStruct :: TType TStruct  -- 12
    TMap    :: TType TMap     -- 13
    TSet    :: TType TSet     -- 14
    TList   :: TType TList    -- 15
  deriving (Typeable)

deriving instance Show (TType a)
deriving instance Eq (TType a)

instance Hashable (TType a) where
    hashWithSalt :: Int -> TType a -> Int
hashWithSalt Int
s TType a
TBool   = Int
s Int -> Int -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` (Int
0  :: Int)
    hashWithSalt Int
s TType a
TByte   = Int
s Int -> Int -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` (Int
1  :: Int)
    hashWithSalt Int
s TType a
TDouble = Int
s Int -> Int -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` (Int
2  :: Int)
    hashWithSalt Int
s TType a
TInt16  = Int
s Int -> Int -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` (Int
3  :: Int)
    hashWithSalt Int
s TType a
TInt32  = Int
s Int -> Int -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` (Int
4  :: Int)
    hashWithSalt Int
s TType a
TInt64  = Int
s Int -> Int -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` (Int
5  :: Int)
    hashWithSalt Int
s TType a
TBinary = Int
s Int -> Int -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` (Int
6  :: Int)
    hashWithSalt Int
s TType a
TStruct = Int
s Int -> Int -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` (Int
7  :: Int)
    hashWithSalt Int
s TType a
TMap    = Int
s Int -> Int -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` (Int
8  :: Int)
    hashWithSalt Int
s TType a
TSet    = Int
s Int -> Int -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` (Int
9  :: Int)
    hashWithSalt Int
s TType a
TList   = Int
s Int -> Int -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` (Int
10 :: Int)


-- | Typeclass used to map type-leve TTypes into 'TType' objects. All TType
-- tags are instances of this class.
class Typeable a => IsTType a where
    -- | Based on the context in which this is used, it will automatically
    -- return the corresponding 'TType' object.
    ttype :: TType a


instance IsTType TBool   where ttype :: TType TBool
ttype = TType TBool
TBool
instance IsTType TByte   where ttype :: TType TByte
ttype = TType TByte
TByte
instance IsTType TDouble where ttype :: TType TDouble
ttype = TType TDouble
TDouble
instance IsTType TInt16  where ttype :: TType TInt16
ttype = TType TInt16
TInt16
instance IsTType TInt32  where ttype :: TType TInt32
ttype = TType TInt32
TInt32
instance IsTType TInt64  where ttype :: TType TInt64
ttype = TType TInt64
TInt64
instance IsTType TBinary where ttype :: TType TBinary
ttype = TType TBinary
TBinary
instance IsTType TStruct where ttype :: TType TStruct
ttype = TType TStruct
TStruct
instance IsTType TMap    where ttype :: TType TMap
ttype = TType TMap
TMap
instance IsTType TSet    where ttype :: TType TSet
ttype = TType TSet
TSet
instance IsTType TList   where ttype :: TType TList
ttype = TType TList
TList


-- | Used when the 'TType' for something is not known at compile time.
-- Typically, this will be pattern matched inside a case statement and code
-- that depends on the TType will be go there.
data SomeTType where
    SomeTType :: forall a. IsTType a => TType a -> SomeTType
  deriving Typeable

deriving instance Show SomeTType

-- | Witness the equality of two ttypes.
ttypeEquality :: TType a -> TType b -> Maybe (a :~: b)
ttypeEquality :: TType a -> TType b -> Maybe (a :~: b)
ttypeEquality TType a
TBool   TType b
TBool   = (a :~: a) -> Maybe (a :~: a)
forall a. a -> Maybe a
Just a :~: a
forall k (a :: k). a :~: a
Refl
ttypeEquality TType a
TByte   TType b
TByte   = (a :~: a) -> Maybe (a :~: a)
forall a. a -> Maybe a
Just a :~: a
forall k (a :: k). a :~: a
Refl
ttypeEquality TType a
TDouble TType b
TDouble = (a :~: a) -> Maybe (a :~: a)
forall a. a -> Maybe a
Just a :~: a
forall k (a :: k). a :~: a
Refl
ttypeEquality TType a
TInt16  TType b
TInt16  = (a :~: a) -> Maybe (a :~: a)
forall a. a -> Maybe a
Just a :~: a
forall k (a :: k). a :~: a
Refl
ttypeEquality TType a
TInt32  TType b
TInt32  = (a :~: a) -> Maybe (a :~: a)
forall a. a -> Maybe a
Just a :~: a
forall k (a :: k). a :~: a
Refl
ttypeEquality TType a
TInt64  TType b
TInt64  = (a :~: a) -> Maybe (a :~: a)
forall a. a -> Maybe a
Just a :~: a
forall k (a :: k). a :~: a
Refl
ttypeEquality TType a
TBinary TType b
TBinary = (a :~: a) -> Maybe (a :~: a)
forall a. a -> Maybe a
Just a :~: a
forall k (a :: k). a :~: a
Refl
ttypeEquality TType a
TStruct TType b
TStruct = (a :~: a) -> Maybe (a :~: a)
forall a. a -> Maybe a
Just a :~: a
forall k (a :: k). a :~: a
Refl
ttypeEquality TType a
TMap    TType b
TMap    = (a :~: a) -> Maybe (a :~: a)
forall a. a -> Maybe a
Just a :~: a
forall k (a :: k). a :~: a
Refl
ttypeEquality TType a
TSet    TType b
TSet    = (a :~: a) -> Maybe (a :~: a)
forall a. a -> Maybe a
Just a :~: a
forall k (a :: k). a :~: a
Refl
ttypeEquality TType a
TList   TType b
TList   = (a :~: a) -> Maybe (a :~: a)
forall a. a -> Maybe a
Just a :~: a
forall k (a :: k). a :~: a
Refl
ttypeEquality TType a
_       TType b
_       = Maybe (a :~: b)
forall a. Maybe a
Nothing
{-# INLINE ttypeEquality #-}

-- | Witness the equality of two TTypes.
--
-- Implicit version of @ttypeEquality@.
ttypeEqT :: forall a b. (IsTType a, IsTType b) => Maybe (a :~: b)
ttypeEqT :: Maybe (a :~: b)
ttypeEqT = TType a -> TType b -> Maybe (a :~: b)
forall a b. TType a -> TType b -> Maybe (a :~: b)
ttypeEquality TType a
forall a. IsTType a => TType a
ttype TType b
forall a. IsTType a => TType a
ttype
{-# INLINE ttypeEqT #-}