    {-# 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
    $c== :: ConcreteTypeRep -> ConcreteTypeRep -> Bool
    == :: ConcreteTypeRep -> ConcreteTypeRep -> Bool
    $c/= :: ConcreteTypeRep -> ConcreteTypeRep -> Bool
    /= :: 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
    $cput :: SerialRep -> Put
    put :: SerialRep -> Put
    $cget :: Get SerialRep
    get :: Get SerialRep
    $cputList :: [SerialRep] -> Put
    putList :: [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 (ZonkAny 1) -> TypeRep)
    -> TypeRep (ZonkAny 1)
    -> ConcreteTypeRep
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . TypeRep (ZonkAny 1) -> TypeRep
    forall k (a :: k). TypeRep a -> TypeRep
    SomeTypeRep (TypeRep (ZonkAny 1) -> ConcreteTypeRep)
    -> TypeRep (ZonkAny 1) -> ConcreteTypeRep
    forall a b. (a -> b) -> a -> b
    $ TyCon -> [TypeRep] -> TypeRep (ZonkAny 1)
    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