{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, CPP, ViewPatterns #-}

{- |
Copyright (c)2011, Reiner Pope

All rights reserved.

Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:

    * Redistributions of source code must retain the above copyright
      notice, this list of conditions and the following disclaimer.

    * Redistributions in binary form must reproduce the above
      copyright notice, this list of conditions and the following
      disclaimer in the documentation and/or other materials provided
      with the distribution.

    * Neither the name of Reiner Pope nor the names of other
      contributors may be used to endorse or promote products derived
      from this software without specific prior written permission.

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

This module defines 'Binary' and 'Hashable' instances for 'TypeRep'. These are defined on a newtype of 'TypeRep', namely 'ConcreteTypeRep', for two purposes:

  * to avoid making orphan instances

  * the 'Hashable' instance for 'ConcreteTypeRep' may not be pure enough for some people's tastes.

As usual with 'Typeable', this module will typically be used with some variant of @Data.Dynamic@. Two possible uses of this module are:

  * making hashmaps: @HashMap 'ConcreteTypeRep' Dynamic@

  * serializing @Dynamic@s.

-}

module Data.ConcreteTypeRep (
  ConcreteTypeRep,
  cTypeOf,
  toTypeRep,
  fromTypeRep,
 ) where

#if MIN_VERSION_base(4,10,0)
import Type.Reflection (SomeTypeRep(..))
import Type.Reflection.Unsafe (mkTyCon, mkTrCon, tyConKindArgs, tyConKindRep, KindRep)
#endif
import Data.Typeable
import Data.Hashable
import Data.Binary
import GHC.Fingerprint

-- | Abstract type providing the functionality of 'TypeRep', but additionally supporting hashing and serialization.
--
-- The 'Eq' instance is just the 'Eq' instance for 'TypeRep', so an analogous guarantee holds: @'cTypeOf' a == 'cTypeOf' b@ if and only if @a@ and @b@ have the same type.
-- The hashing and serialization functions preserve this equality.
newtype ConcreteTypeRep = CTR { ConcreteTypeRep -> TypeRep
unCTR :: TypeRep }
    deriving (ConcreteTypeRep -> ConcreteTypeRep -> Bool
(ConcreteTypeRep -> ConcreteTypeRep -> Bool)
-> (ConcreteTypeRep -> ConcreteTypeRep -> Bool)
-> Eq ConcreteTypeRep
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ConcreteTypeRep -> ConcreteTypeRep -> Bool
$c/= :: ConcreteTypeRep -> ConcreteTypeRep -> Bool
== :: ConcreteTypeRep -> ConcreteTypeRep -> Bool
$c== :: ConcreteTypeRep -> ConcreteTypeRep -> Bool
Eq, Typeable)

-- | \"Concrete\" version of 'typeOf'.
cTypeOf :: Typeable a => a -> ConcreteTypeRep
cTypeOf :: forall a. Typeable a => a -> ConcreteTypeRep
cTypeOf = TypeRep -> ConcreteTypeRep
fromTypeRep (TypeRep -> ConcreteTypeRep)
-> (a -> TypeRep) -> a -> ConcreteTypeRep
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf

-- | Converts to the underlying 'TypeRep'
toTypeRep :: ConcreteTypeRep -> TypeRep
toTypeRep :: ConcreteTypeRep -> TypeRep
toTypeRep = ConcreteTypeRep -> TypeRep
unCTR

-- | Converts from the underlying 'TypeRep'
fromTypeRep :: TypeRep -> ConcreteTypeRep
fromTypeRep :: TypeRep -> ConcreteTypeRep
fromTypeRep = TypeRep -> ConcreteTypeRep
CTR

-- show as a normal TypeRep
instance Show ConcreteTypeRep where
  showsPrec :: Int -> ConcreteTypeRep -> ShowS
showsPrec Int
i = Int -> TypeRep -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
i (TypeRep -> ShowS)
-> (ConcreteTypeRep -> TypeRep) -> ConcreteTypeRep -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConcreteTypeRep -> TypeRep
unCTR

-- | This instance is guaranteed to be consistent for a single run of the program, but not for multiple runs.
instance Hashable ConcreteTypeRep where
    hashWithSalt :: Int -> ConcreteTypeRep -> Int
hashWithSalt Int
salt (CTR (TypeRep -> Fingerprint
typeRepFingerprint -> Fingerprint Word64
w1 Word64
w2)) = Int
salt Int -> Word64 -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` Word64
w1 Int -> Word64 -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` Word64
w2

------------- serialization: this uses Gökhan San's construction, from
---- http://www.mail-archive.com/haskell-cafe@haskell.org/msg41134.html
#if MIN_VERSION_base(4,10,0)
type TyConRep = (String, String, String, Int, KindRep)
#else
type TyConRep = (String, String, String)
#endif

toTyConRep :: TyCon -> TyConRep
fromTyConRep :: TyConRep -> TyCon

#if MIN_VERSION_base(4,10,0)
toTyConRep :: TyCon -> TyConRep
toTyConRep TyCon
tc = (TyCon -> String
tyConPackage TyCon
tc, TyCon -> String
tyConModule TyCon
tc, TyCon -> String
tyConName TyCon
tc, TyCon -> Int
tyConKindArgs TyCon
tc, TyCon -> KindRep
tyConKindRep TyCon
tc)
#else
toTyConRep tc = (tyConPackage tc, tyConModule tc, tyConName tc)
#endif

#if MIN_VERSION_base(4,10,0)
fromTyConRep :: TyConRep -> TyCon
fromTyConRep (String
pack, String
mod', String
name, Int
ka, KindRep
kr) = String -> String -> String -> Int -> KindRep -> TyCon
mkTyCon String
pack String
mod' String
name Int
ka KindRep
kr
#else
fromTyConRep (pack, mod', name) = mkTyCon3 pack mod' name
#endif

newtype SerialRep = SR (TyConRep, [SerialRep])
    deriving (Get SerialRep
[SerialRep] -> Put
SerialRep -> Put
(SerialRep -> Put)
-> Get SerialRep -> ([SerialRep] -> Put) -> Binary SerialRep
forall t. (t -> Put) -> Get t -> ([t] -> Put) -> Binary t
putList :: [SerialRep] -> Put
$cputList :: [SerialRep] -> Put
get :: Get SerialRep
$cget :: Get SerialRep
put :: SerialRep -> Put
$cput :: SerialRep -> Put
Binary)

toSerial :: ConcreteTypeRep -> SerialRep
toSerial :: ConcreteTypeRep -> SerialRep
toSerial (CTR TypeRep
t) =
  case TypeRep -> (TyCon, [TypeRep])
splitTyConApp TypeRep
t of
    (TyCon
con, [TypeRep]
args) -> (TyConRep, [SerialRep]) -> SerialRep
SR (TyCon -> TyConRep
toTyConRep TyCon
con, (TypeRep -> SerialRep) -> [TypeRep] -> [SerialRep]
forall a b. (a -> b) -> [a] -> [b]
map (ConcreteTypeRep -> SerialRep
toSerial (ConcreteTypeRep -> SerialRep)
-> (TypeRep -> ConcreteTypeRep) -> TypeRep -> SerialRep
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeRep -> ConcreteTypeRep
CTR) [TypeRep]
args)

fromSerial :: SerialRep -> ConcreteTypeRep
#if MIN_VERSION_base(4,10,0)
fromSerial :: SerialRep -> ConcreteTypeRep
fromSerial (SR (TyConRep
con, [SerialRep]
args)) = TypeRep -> ConcreteTypeRep
CTR (TypeRep -> ConcreteTypeRep)
-> (TypeRep Any -> TypeRep) -> TypeRep Any -> ConcreteTypeRep
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeRep Any -> TypeRep
forall k (a :: k). TypeRep a -> TypeRep
SomeTypeRep (TypeRep Any -> ConcreteTypeRep) -> TypeRep Any -> ConcreteTypeRep
forall a b. (a -> b) -> a -> b
$ TyCon -> [TypeRep] -> TypeRep Any
forall k (a :: k). TyCon -> [TypeRep] -> TypeRep a
mkTrCon (TyConRep -> TyCon
fromTyConRep TyConRep
con) ((SerialRep -> TypeRep) -> [SerialRep] -> [TypeRep]
forall a b. (a -> b) -> [a] -> [b]
map (ConcreteTypeRep -> TypeRep
unCTR (ConcreteTypeRep -> TypeRep)
-> (SerialRep -> ConcreteTypeRep) -> SerialRep -> TypeRep
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SerialRep -> ConcreteTypeRep
fromSerial) [SerialRep]
args)
#else
fromSerial (SR (con, args)) = CTR $ mkTyConApp (fromTyConRep con) (map (unCTR . fromSerial) args)
#endif

instance Binary ConcreteTypeRep where
  put :: ConcreteTypeRep -> Put
put = SerialRep -> Put
forall t. Binary t => t -> Put
put (SerialRep -> Put)
-> (ConcreteTypeRep -> SerialRep) -> ConcreteTypeRep -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConcreteTypeRep -> SerialRep
toSerial
  get :: Get ConcreteTypeRep
get = SerialRep -> ConcreteTypeRep
fromSerial (SerialRep -> ConcreteTypeRep)
-> Get SerialRep -> Get ConcreteTypeRep
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get SerialRep
forall t. Binary t => Get t
get