{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE StandaloneDeriving #-}

module Data.Store.TypeHash.Internal where

import           Control.Applicative
import           Control.DeepSeq (NFData)
import           Control.Monad (when, unless)
import qualified Crypto.Hash.SHA1 as SHA1
import qualified Data.ByteString as BS
import           Data.Char (isUpper, isLower)
import           Data.Data (Data)
import           Data.Functor.Contravariant
import           Data.Generics (listify)
import           Data.List (sortBy)
import           Data.Monoid ((<>))
import           Data.Ord (comparing)
import           Data.Proxy (Proxy(..))
import           Data.Store
import           Data.Store.Internal
import           Data.Typeable (Typeable)
import           GHC.Generics (Generic)
import           Language.Haskell.TH
import           Language.Haskell.TH.ReifyMany (reifyMany)
import           Language.Haskell.TH.Syntax (Lift(..), unsafeTExpCoerce)
import           Prelude

{-# DEPRECATED mkManyHasTypeHash, mkHasTypeHash
    "Use of Data.Store.TypeHash isn't recommended, as the hashes are too unstable for most uses.  Please instead consider using Data.Store.Version.  See https://github.com/fpco/store/issues/53"
  #-}

newtype Tagged a = Tagged { Tagged a -> a
unTagged :: a }
    deriving (Tagged a -> Tagged a -> Bool
(Tagged a -> Tagged a -> Bool)
-> (Tagged a -> Tagged a -> Bool) -> Eq (Tagged a)
forall a. Eq a => Tagged a -> Tagged a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Tagged a -> Tagged a -> Bool
$c/= :: forall a. Eq a => Tagged a -> Tagged a -> Bool
== :: Tagged a -> Tagged a -> Bool
$c== :: forall a. Eq a => Tagged a -> Tagged a -> Bool
Eq, Eq (Tagged a)
Eq (Tagged a)
-> (Tagged a -> Tagged a -> Ordering)
-> (Tagged a -> Tagged a -> Bool)
-> (Tagged a -> Tagged a -> Bool)
-> (Tagged a -> Tagged a -> Bool)
-> (Tagged a -> Tagged a -> Bool)
-> (Tagged a -> Tagged a -> Tagged a)
-> (Tagged a -> Tagged a -> Tagged a)
-> Ord (Tagged a)
Tagged a -> Tagged a -> Bool
Tagged a -> Tagged a -> Ordering
Tagged a -> Tagged a -> Tagged a
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a. Ord a => Eq (Tagged a)
forall a. Ord a => Tagged a -> Tagged a -> Bool
forall a. Ord a => Tagged a -> Tagged a -> Ordering
forall a. Ord a => Tagged a -> Tagged a -> Tagged a
min :: Tagged a -> Tagged a -> Tagged a
$cmin :: forall a. Ord a => Tagged a -> Tagged a -> Tagged a
max :: Tagged a -> Tagged a -> Tagged a
$cmax :: forall a. Ord a => Tagged a -> Tagged a -> Tagged a
>= :: Tagged a -> Tagged a -> Bool
$c>= :: forall a. Ord a => Tagged a -> Tagged a -> Bool
> :: Tagged a -> Tagged a -> Bool
$c> :: forall a. Ord a => Tagged a -> Tagged a -> Bool
<= :: Tagged a -> Tagged a -> Bool
$c<= :: forall a. Ord a => Tagged a -> Tagged a -> Bool
< :: Tagged a -> Tagged a -> Bool
$c< :: forall a. Ord a => Tagged a -> Tagged a -> Bool
compare :: Tagged a -> Tagged a -> Ordering
$ccompare :: forall a. Ord a => Tagged a -> Tagged a -> Ordering
$cp1Ord :: forall a. Ord a => Eq (Tagged a)
Ord, Int -> Tagged a -> ShowS
[Tagged a] -> ShowS
Tagged a -> String
(Int -> Tagged a -> ShowS)
-> (Tagged a -> String) -> ([Tagged a] -> ShowS) -> Show (Tagged a)
forall a. Show a => Int -> Tagged a -> ShowS
forall a. Show a => [Tagged a] -> ShowS
forall a. Show a => Tagged a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Tagged a] -> ShowS
$cshowList :: forall a. Show a => [Tagged a] -> ShowS
show :: Tagged a -> String
$cshow :: forall a. Show a => Tagged a -> String
showsPrec :: Int -> Tagged a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Tagged a -> ShowS
Show, Typeable (Tagged a)
DataType
Constr
Typeable (Tagged a)
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> Tagged a -> c (Tagged a))
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c (Tagged a))
-> (Tagged a -> Constr)
-> (Tagged a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c (Tagged a)))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e))
    -> Maybe (c (Tagged a)))
-> ((forall b. Data b => b -> b) -> Tagged a -> Tagged a)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> Tagged a -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> Tagged a -> r)
-> (forall u. (forall d. Data d => d -> u) -> Tagged a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> Tagged a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> Tagged a -> m (Tagged a))
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> Tagged a -> m (Tagged a))
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> Tagged a -> m (Tagged a))
-> Data (Tagged a)
Tagged a -> DataType
Tagged a -> Constr
(forall d. Data d => c (t d)) -> Maybe (c (Tagged a))
(forall b. Data b => b -> b) -> Tagged a -> Tagged a
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Tagged a -> c (Tagged a)
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (Tagged a)
forall a. Data a => Typeable (Tagged a)
forall a. Data a => Tagged a -> DataType
forall a. Data a => Tagged a -> Constr
forall a.
Data a =>
(forall b. Data b => b -> b) -> Tagged a -> Tagged a
forall a u.
Data a =>
Int -> (forall d. Data d => d -> u) -> Tagged a -> u
forall a u.
Data a =>
(forall d. Data d => d -> u) -> Tagged a -> [u]
forall a r r'.
Data a =>
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Tagged a -> r
forall a r r'.
Data a =>
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Tagged a -> r
forall a (m :: * -> *).
(Data a, Monad m) =>
(forall d. Data d => d -> m d) -> Tagged a -> m (Tagged a)
forall a (m :: * -> *).
(Data a, MonadPlus m) =>
(forall d. Data d => d -> m d) -> Tagged a -> m (Tagged a)
forall a (c :: * -> *).
Data a =>
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (Tagged a)
forall a (c :: * -> *).
Data a =>
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Tagged a -> c (Tagged a)
forall a (t :: * -> *) (c :: * -> *).
(Data a, Typeable t) =>
(forall d. Data d => c (t d)) -> Maybe (c (Tagged a))
forall a (t :: * -> * -> *) (c :: * -> *).
(Data a, Typeable t) =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c (Tagged a))
forall a.
Typeable a
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> Tagged a -> u
forall u. (forall d. Data d => d -> u) -> Tagged a -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Tagged a -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Tagged a -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Tagged a -> m (Tagged a)
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Tagged a -> m (Tagged a)
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (Tagged a)
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Tagged a -> c (Tagged a)
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c (Tagged a))
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c (Tagged a))
$cTagged :: Constr
$tTagged :: DataType
gmapMo :: (forall d. Data d => d -> m d) -> Tagged a -> m (Tagged a)
$cgmapMo :: forall a (m :: * -> *).
(Data a, MonadPlus m) =>
(forall d. Data d => d -> m d) -> Tagged a -> m (Tagged a)
gmapMp :: (forall d. Data d => d -> m d) -> Tagged a -> m (Tagged a)
$cgmapMp :: forall a (m :: * -> *).
(Data a, MonadPlus m) =>
(forall d. Data d => d -> m d) -> Tagged a -> m (Tagged a)
gmapM :: (forall d. Data d => d -> m d) -> Tagged a -> m (Tagged a)
$cgmapM :: forall a (m :: * -> *).
(Data a, Monad m) =>
(forall d. Data d => d -> m d) -> Tagged a -> m (Tagged a)
gmapQi :: Int -> (forall d. Data d => d -> u) -> Tagged a -> u
$cgmapQi :: forall a u.
Data a =>
Int -> (forall d. Data d => d -> u) -> Tagged a -> u
gmapQ :: (forall d. Data d => d -> u) -> Tagged a -> [u]
$cgmapQ :: forall a u.
Data a =>
(forall d. Data d => d -> u) -> Tagged a -> [u]
gmapQr :: (r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Tagged a -> r
$cgmapQr :: forall a r r'.
Data a =>
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Tagged a -> r
gmapQl :: (r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Tagged a -> r
$cgmapQl :: forall a r r'.
Data a =>
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Tagged a -> r
gmapT :: (forall b. Data b => b -> b) -> Tagged a -> Tagged a
$cgmapT :: forall a.
Data a =>
(forall b. Data b => b -> b) -> Tagged a -> Tagged a
dataCast2 :: (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c (Tagged a))
$cdataCast2 :: forall a (t :: * -> * -> *) (c :: * -> *).
(Data a, Typeable t) =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c (Tagged a))
dataCast1 :: (forall d. Data d => c (t d)) -> Maybe (c (Tagged a))
$cdataCast1 :: forall a (t :: * -> *) (c :: * -> *).
(Data a, Typeable t) =>
(forall d. Data d => c (t d)) -> Maybe (c (Tagged a))
dataTypeOf :: Tagged a -> DataType
$cdataTypeOf :: forall a. Data a => Tagged a -> DataType
toConstr :: Tagged a -> Constr
$ctoConstr :: forall a. Data a => Tagged a -> Constr
gunfold :: (forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (Tagged a)
$cgunfold :: forall a (c :: * -> *).
Data a =>
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (Tagged a)
gfoldl :: (forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Tagged a -> c (Tagged a)
$cgfoldl :: forall a (c :: * -> *).
Data a =>
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Tagged a -> c (Tagged a)
$cp1Data :: forall a. Data a => Typeable (Tagged a)
Data, Typeable, (forall x. Tagged a -> Rep (Tagged a) x)
-> (forall x. Rep (Tagged a) x -> Tagged a) -> Generic (Tagged a)
forall x. Rep (Tagged a) x -> Tagged a
forall x. Tagged a -> Rep (Tagged a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (Tagged a) x -> Tagged a
forall a x. Tagged a -> Rep (Tagged a) x
$cto :: forall a x. Rep (Tagged a) x -> Tagged a
$cfrom :: forall a x. Tagged a -> Rep (Tagged a) x
Generic)

instance NFData a => NFData (Tagged a)

instance (Store a, HasTypeHash a) => Store (Tagged a) where
    size :: Size (Tagged a)
size = Int -> Size (Tagged a) -> Size (Tagged a)
forall a. Int -> Size a -> Size a
addSize Int
20 ((Tagged a -> a) -> Size a -> Size (Tagged a)
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap Tagged a -> a
forall a. Tagged a -> a
unTagged Size a
forall a. Store a => Size a
size)
    peek :: Peek (Tagged a)
peek = do
        TypeHash
tag <- Peek TypeHash
forall a. Store a => Peek a
peek
        let expected :: TypeHash
expected = Proxy a -> TypeHash
forall a. HasTypeHash a => Proxy a -> TypeHash
typeHash (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a)
        Bool -> Peek () -> Peek ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TypeHash
tag TypeHash -> TypeHash -> Bool
forall a. Eq a => a -> a -> Bool
/= TypeHash
expected) (Peek () -> Peek ()) -> Peek () -> Peek ()
forall a b. (a -> b) -> a -> b
$ String -> Peek ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Mismatched type hash"
        a -> Tagged a
forall a. a -> Tagged a
Tagged (a -> Tagged a) -> Peek a -> Peek (Tagged a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Peek a
forall a. Store a => Peek a
peek
    poke :: Tagged a -> Poke ()
poke (Tagged a
x) = do
        TypeHash -> Poke ()
forall a. Store a => a -> Poke ()
poke (Proxy a -> TypeHash
forall a. HasTypeHash a => Proxy a -> TypeHash
typeHash (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a))
        a -> Poke ()
forall a. Store a => a -> Poke ()
poke a
x

newtype TypeHash = TypeHash { TypeHash -> StaticSize 20 ByteString
unTypeHash :: StaticSize 20 BS.ByteString }
    deriving (TypeHash -> TypeHash -> Bool
(TypeHash -> TypeHash -> Bool)
-> (TypeHash -> TypeHash -> Bool) -> Eq TypeHash
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TypeHash -> TypeHash -> Bool
$c/= :: TypeHash -> TypeHash -> Bool
== :: TypeHash -> TypeHash -> Bool
$c== :: TypeHash -> TypeHash -> Bool
Eq, Eq TypeHash
Eq TypeHash
-> (TypeHash -> TypeHash -> Ordering)
-> (TypeHash -> TypeHash -> Bool)
-> (TypeHash -> TypeHash -> Bool)
-> (TypeHash -> TypeHash -> Bool)
-> (TypeHash -> TypeHash -> Bool)
-> (TypeHash -> TypeHash -> TypeHash)
-> (TypeHash -> TypeHash -> TypeHash)
-> Ord TypeHash
TypeHash -> TypeHash -> Bool
TypeHash -> TypeHash -> Ordering
TypeHash -> TypeHash -> TypeHash
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: TypeHash -> TypeHash -> TypeHash
$cmin :: TypeHash -> TypeHash -> TypeHash
max :: TypeHash -> TypeHash -> TypeHash
$cmax :: TypeHash -> TypeHash -> TypeHash
>= :: TypeHash -> TypeHash -> Bool
$c>= :: TypeHash -> TypeHash -> Bool
> :: TypeHash -> TypeHash -> Bool
$c> :: TypeHash -> TypeHash -> Bool
<= :: TypeHash -> TypeHash -> Bool
$c<= :: TypeHash -> TypeHash -> Bool
< :: TypeHash -> TypeHash -> Bool
$c< :: TypeHash -> TypeHash -> Bool
compare :: TypeHash -> TypeHash -> Ordering
$ccompare :: TypeHash -> TypeHash -> Ordering
$cp1Ord :: Eq TypeHash
Ord, Int -> TypeHash -> ShowS
[TypeHash] -> ShowS
TypeHash -> String
(Int -> TypeHash -> ShowS)
-> (TypeHash -> String) -> ([TypeHash] -> ShowS) -> Show TypeHash
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TypeHash] -> ShowS
$cshowList :: [TypeHash] -> ShowS
show :: TypeHash -> String
$cshow :: TypeHash -> String
showsPrec :: Int -> TypeHash -> ShowS
$cshowsPrec :: Int -> TypeHash -> ShowS
Show, Peek TypeHash
Size TypeHash
Size TypeHash
-> (TypeHash -> Poke ()) -> Peek TypeHash -> Store TypeHash
TypeHash -> Poke ()
forall a. Size a -> (a -> Poke ()) -> Peek a -> Store a
peek :: Peek TypeHash
$cpeek :: Peek TypeHash
poke :: TypeHash -> Poke ()
$cpoke :: TypeHash -> Poke ()
size :: Size TypeHash
$csize :: Size TypeHash
Store, (forall x. TypeHash -> Rep TypeHash x)
-> (forall x. Rep TypeHash x -> TypeHash) -> Generic TypeHash
forall x. Rep TypeHash x -> TypeHash
forall x. TypeHash -> Rep TypeHash x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep TypeHash x -> TypeHash
$cfrom :: forall x. TypeHash -> Rep TypeHash x
Generic)

#if __GLASGOW_HASKELL__ >= 710
deriving instance Typeable TypeHash
deriving instance Data TypeHash
#endif

instance NFData TypeHash

instance Lift TypeHash where
    lift :: TypeHash -> Q Exp
lift = ByteString -> Q Exp
staticByteStringExp (ByteString -> Q Exp)
-> (TypeHash -> ByteString) -> TypeHash -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StaticSize 20 ByteString -> ByteString
forall (n :: Nat) a. StaticSize n a -> a
unStaticSize (StaticSize 20 ByteString -> ByteString)
-> (TypeHash -> StaticSize 20 ByteString) -> TypeHash -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeHash -> StaticSize 20 ByteString
unTypeHash
#if MIN_VERSION_template_haskell(2,17,0)
    liftTyped = Code . unsafeTExpCoerce . lift
#elif MIN_VERSION_template_haskell(2,16,0)
    liftTyped :: TypeHash -> Q (TExp TypeHash)
liftTyped = Q Exp -> Q (TExp TypeHash)
forall a. Q Exp -> Q (TExp a)
unsafeTExpCoerce (Q Exp -> Q (TExp TypeHash))
-> (TypeHash -> Q Exp) -> TypeHash -> Q (TExp TypeHash)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeHash -> Q Exp
forall t. Lift t => t -> Q Exp
lift
#endif

reifyManyTyDecls :: ((Name, Info) -> Q (Bool, [Name]))
                 -> [Name]
                 -> Q [(Name, Info)]
reifyManyTyDecls :: ((Name, Info) -> Q (Bool, [Name])) -> [Name] -> Q [(Name, Info)]
reifyManyTyDecls (Name, Info) -> Q (Bool, [Name])
f = ((Name, Info) -> Q (Bool, [Name])) -> [Name] -> Q [(Name, Info)]
reifyMany (Name, Info) -> Q (Bool, [Name])
go
  where
    go :: (Name, Info) -> Q (Bool, [Name])
go x :: (Name, Info)
x@(Name
_, TyConI{}) = (Name, Info) -> Q (Bool, [Name])
f (Name, Info)
x
    go x :: (Name, Info)
x@(Name
_, FamilyI{}) = (Name, Info) -> Q (Bool, [Name])
f (Name, Info)
x
    go x :: (Name, Info)
x@(Name
_, PrimTyConI{}) = (Name, Info) -> Q (Bool, [Name])
f (Name, Info)
x
    go x :: (Name, Info)
x@(Name
_, DataConI{}) = (Name, Info) -> Q (Bool, [Name])
f (Name, Info)
x
    go (Name
_, ClassI{}) = (Bool, [Name]) -> Q (Bool, [Name])
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, [])
    go (Name
_, ClassOpI{}) = (Bool, [Name]) -> Q (Bool, [Name])
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, [])
    go (Name
_, VarI{}) = (Bool, [Name]) -> Q (Bool, [Name])
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, [])
    go (Name
_, TyVarI{}) = (Bool, [Name]) -> Q (Bool, [Name])
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, [])
#if MIN_VERSION_template_haskell(2,12,0)
    go (Name
_, PatSynI{}) = (Bool, [Name]) -> Q (Bool, [Name])
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, [])
#endif

-- | At compiletime, this yields a hash of the specified datatypes.
-- Not only does this cover the datatypes themselves, but also all
-- transitive dependencies.
--
-- The resulting expression is a literal of type 'TypeHash'.
typeHashForNames :: [Name] -> Q Exp
typeHashForNames :: [Name] -> Q Exp
typeHashForNames [Name]
ns = do
    [(Name, Info)]
infos <- [Name] -> Q [(Name, Info)]
getTypeInfosRecursively [Name]
ns
    [| TypeHash $(staticByteStringExp (SHA1.hash (encode infos))) |]

-- | At compiletime, this yields a cryptographic hash of the specified 'Type',
-- including the definition of things it references (transitively).
--
-- The resulting expression is a literal of type 'TypeHash'.
hashOfType :: Type -> Q Exp
hashOfType :: Type -> Q Exp
hashOfType Type
ty = do
    Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Name] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Type -> [Name]
forall a. Data a => a -> [Name]
getVarNames Type
ty)) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$ String -> Q ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q ()) -> String -> Q ()
forall a b. (a -> b) -> a -> b
$ String
"hashOfType cannot handle polymorphic type " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Type -> String
forall a. Ppr a => a -> String
pprint Type
ty
    [(Name, Info)]
infos <- [Name] -> Q [(Name, Info)]
getTypeInfosRecursively (Type -> [Name]
forall a. Data a => a -> [Name]
getConNames Type
ty)
    [| TypeHash $(staticByteStringExp (SHA1.hash (encode infos))) |]

getTypeInfosRecursively :: [Name] -> Q [(Name, Info)]
getTypeInfosRecursively :: [Name] -> Q [(Name, Info)]
getTypeInfosRecursively [Name]
names = do
    [(Name, Info)]
allInfos <- ((Name, Info) -> Q (Bool, [Name])) -> [Name] -> Q [(Name, Info)]
reifyManyTyDecls (\(Name
_, Info
info) -> (Bool, [Name]) -> Q (Bool, [Name])
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, Info -> [Name]
forall a. Data a => a -> [Name]
getConNames Info
info)) [Name]
names
    -- Sorting step probably unnecessary because this should be
    -- deterministic, but hey why not.
    [(Name, Info)] -> Q [(Name, Info)]
forall (m :: * -> *) a. Monad m => a -> m a
return (((Name, Info) -> (Name, Info) -> Ordering)
-> [(Name, Info)] -> [(Name, Info)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((Name, Info) -> Name) -> (Name, Info) -> (Name, Info) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (Name, Info) -> Name
forall a b. (a, b) -> a
fst) [(Name, Info)]
allInfos)

getConNames :: Data a => a -> [Name]
getConNames :: a -> [Name]
getConNames = (Name -> Bool) -> forall a. Data a => a -> [Name]
forall r. Typeable r => (r -> Bool) -> GenericQ [r]
listify (Char -> Bool
isUpper (Char -> Bool) -> (Name -> Char) -> Name -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Char
forall a. [a] -> a
head (String -> Char) -> (Name -> String) -> Name -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase)

getVarNames :: Data a => a -> [Name]
getVarNames :: a -> [Name]
getVarNames = (Name -> Bool) -> forall a. Data a => a -> [Name]
forall r. Typeable r => (r -> Bool) -> GenericQ [r]
listify (Char -> Bool
isLower (Char -> Bool) -> (Name -> Char) -> Name -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Char
forall a. [a] -> a
head (String -> Char) -> (Name -> String) -> Name -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase)

-- TODO: Generic instance for polymorphic types, or have TH generate
-- polymorphic instances.

class HasTypeHash a where
    typeHash :: Proxy a -> TypeHash

mkHasTypeHash :: Type -> Q [Dec]
mkHasTypeHash :: Type -> Q [Dec]
mkHasTypeHash Type
ty =
    [d| instance HasTypeHash $(return ty) where
            typeHash _ = $(hashOfType ty)
      |]

mkManyHasTypeHash :: [Q Type] -> Q [Dec]
mkManyHasTypeHash :: [Q Type] -> Q [Dec]
mkManyHasTypeHash [Q Type]
qtys = [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Q Type -> Q [Dec]) -> [Q Type] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Type -> Q [Dec]
mkHasTypeHash (Type -> Q [Dec]) -> Q Type -> Q [Dec]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) [Q Type]
qtys

combineTypeHashes :: [TypeHash] -> TypeHash
combineTypeHashes :: [TypeHash] -> TypeHash
combineTypeHashes = StaticSize 20 ByteString -> TypeHash
TypeHash (StaticSize 20 ByteString -> TypeHash)
-> ([TypeHash] -> StaticSize 20 ByteString)
-> [TypeHash]
-> TypeHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> StaticSize 20 ByteString
forall (n :: Nat) a. IsStaticSize n a => a -> StaticSize n a
toStaticSizeEx (ByteString -> StaticSize 20 ByteString)
-> ([TypeHash] -> ByteString)
-> [TypeHash]
-> StaticSize 20 ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
SHA1.hash (ByteString -> ByteString)
-> ([TypeHash] -> ByteString) -> [TypeHash] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> ByteString
BS.concat ([ByteString] -> ByteString)
-> ([TypeHash] -> [ByteString]) -> [TypeHash] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TypeHash -> ByteString) -> [TypeHash] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map (StaticSize 20 ByteString -> ByteString
forall (n :: Nat) a. StaticSize n a -> a
unStaticSize (StaticSize 20 ByteString -> ByteString)
-> (TypeHash -> StaticSize 20 ByteString) -> TypeHash -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeHash -> StaticSize 20 ByteString
unTypeHash)