{-# 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 { forall a. 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
$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
/= :: 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
$ccompare :: forall a. Ord a => Tagged a -> Tagged a -> Ordering
compare :: Tagged a -> Tagged a -> Ordering
$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
>= :: Tagged a -> Tagged a -> Bool
$cmax :: forall a. Ord a => Tagged a -> Tagged a -> Tagged a
max :: Tagged a -> Tagged a -> Tagged a
$cmin :: forall a. Ord a => Tagged a -> Tagged a -> Tagged a
min :: Tagged a -> Tagged a -> 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
$cshowsPrec :: forall a. Show a => Int -> Tagged a -> ShowS
showsPrec :: Int -> Tagged a -> ShowS
$cshow :: forall a. Show a => Tagged a -> String
show :: Tagged a -> String
$cshowList :: forall a. Show a => [Tagged a] -> ShowS
showList :: [Tagged a] -> ShowS
Show, Typeable (Tagged a)
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 -> Constr
Tagged a -> DataType
(forall b. Data b => b -> b) -> Tagged a -> Tagged a
forall a. Data a => Typeable (Tagged a)
forall a. Data a => Tagged a -> Constr
forall a. Data a => Tagged a -> DataType
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))
$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)
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Tagged a -> 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)
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (Tagged a)
$ctoConstr :: forall a. Data a => Tagged a -> Constr
toConstr :: Tagged a -> Constr
$cdataTypeOf :: forall a. Data a => Tagged a -> DataType
dataTypeOf :: Tagged a -> DataType
$cdataCast1 :: forall a (t :: * -> *) (c :: * -> *).
(Data a, Typeable t) =>
(forall d. Data d => c (t d)) -> Maybe (c (Tagged a))
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> 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))
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c (Tagged a))
$cgmapT :: forall a.
Data a =>
(forall b. Data b => b -> b) -> Tagged a -> Tagged a
gmapT :: (forall b. Data b => b -> b) -> Tagged a -> Tagged a
$cgmapQl :: forall a r r'.
Data a =>
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Tagged a -> r
gmapQl :: forall r r'.
(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
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Tagged a -> r
$cgmapQ :: forall a u.
Data a =>
(forall d. Data d => d -> u) -> Tagged a -> [u]
gmapQ :: forall u. (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
gmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> Tagged a -> u
$cgmapM :: forall a (m :: * -> *).
(Data a, Monad m) =>
(forall d. Data d => d -> m d) -> Tagged a -> m (Tagged a)
gmapM :: forall (m :: * -> *).
Monad m =>
(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)
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(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)
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Tagged a -> m (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
$cfrom :: forall a x. Tagged a -> Rep (Tagged a) x
from :: forall x. Tagged a -> Rep (Tagged a) x
$cto :: forall a x. Rep (Tagged a) x -> Tagged a
to :: forall x. Rep (Tagged a) x -> Tagged a
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 a' a. (a' -> a) -> Size a -> Size a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> 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 a. String -> Peek a
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
$c== :: TypeHash -> TypeHash -> Bool
== :: TypeHash -> TypeHash -> Bool
$c/= :: TypeHash -> TypeHash -> Bool
/= :: 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
$ccompare :: TypeHash -> TypeHash -> Ordering
compare :: TypeHash -> TypeHash -> Ordering
$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
>= :: TypeHash -> TypeHash -> Bool
$cmax :: TypeHash -> TypeHash -> TypeHash
max :: TypeHash -> TypeHash -> TypeHash
$cmin :: TypeHash -> TypeHash -> TypeHash
min :: TypeHash -> TypeHash -> 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
$cshowsPrec :: Int -> TypeHash -> ShowS
showsPrec :: Int -> TypeHash -> ShowS
$cshow :: TypeHash -> String
show :: TypeHash -> String
$cshowList :: [TypeHash] -> ShowS
showList :: [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
$csize :: Size TypeHash
size :: Size TypeHash
$cpoke :: TypeHash -> Poke ()
poke :: TypeHash -> Poke ()
$cpeek :: Peek TypeHash
peek :: Peek 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
$cfrom :: forall x. TypeHash -> Rep TypeHash x
from :: forall x. TypeHash -> Rep TypeHash x
$cto :: forall x. Rep TypeHash x -> TypeHash
to :: forall x. Rep TypeHash x -> TypeHash
Generic)

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

instance NFData TypeHash

instance Lift TypeHash where
    lift :: forall (m :: * -> *). Quote m => TypeHash -> m Exp
lift = ByteString -> m Exp
forall (m :: * -> *). Quote m => ByteString -> m Exp
staticByteStringExp (ByteString -> m Exp)
-> (TypeHash -> ByteString) -> TypeHash -> m 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 :: forall (m :: * -> *). Quote m => TypeHash -> Code m TypeHash
liftTyped = m (TExp TypeHash) -> Code m TypeHash
forall (m :: * -> *) a. m (TExp a) -> Code m a
Code (m (TExp TypeHash) -> Code m TypeHash)
-> (TypeHash -> m (TExp TypeHash)) -> TypeHash -> Code m TypeHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m Exp -> m (TExp TypeHash)
forall a (m :: * -> *). Quote m => m Exp -> m (TExp a)
unsafeTExpCoerce (m Exp -> m (TExp TypeHash))
-> (TypeHash -> m Exp) -> TypeHash -> m (TExp TypeHash)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeHash -> m Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => TypeHash -> m Exp
lift
#elif MIN_VERSION_template_haskell(2,16,0)
    liftTyped = unsafeTExpCoerce . 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 a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, [])
    go (Name
_, ClassOpI{}) = (Bool, [Name]) -> Q (Bool, [Name])
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, [])
    go (Name
_, VarI{}) = (Bool, [Name]) -> Q (Bool, [Name])
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, [])
    go (Name
_, TyVarI{}) = (Bool, [Name]) -> Q (Bool, [Name])
forall a. a -> Q a
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 a. a -> Q a
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 $(ByteString -> Q Exp
forall (m :: * -> *). Quote m => ByteString -> m Exp
staticByteStringExp (ByteString -> ByteString
SHA1.hash ([(Name, Info)] -> ByteString
forall a. Store a => a -> ByteString
encode [(Name, Info)]
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 a. [a] -> 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 a. String -> Q a
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 $(ByteString -> Q Exp
forall (m :: * -> *). Quote m => ByteString -> m Exp
staticByteStringExp (ByteString -> ByteString
SHA1.hash ([(Name, Info)] -> ByteString
forall a. Store a => a -> ByteString
encode [(Name, Info)]
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 a. a -> Q a
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 a. a -> Q a
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 :: forall a. Data a => 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. HasCallStack => [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 :: forall a. Data a => 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. HasCallStack => [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 $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
ty) where
            typeHash _ = $(Type -> Q Exp
hashOfType Type
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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [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)