{-# LANGUAGE CPP             #-}
{-# LANGUAGE QuasiQuotes     #-}
{-# LANGUAGE TemplateHaskell #-}
module Data.LargeHashable.TH (

    deriveLargeHashable, deriveLargeHashableCtx, deriveLargeHashableNoCtx
  , deriveLargeHashableCustomCtx

) where

import Control.Arrow (first)
import Control.Monad (forM)
import Data.LargeHashable.Class
import Data.Word
import Language.Haskell.TH

-- | Template Haskell function to automatically derive
--   instances of 'LargeHashable'. The derived instances first
--   calls 'updateHash' with an unique identifier number for
--   every constructor, followed by 'updateHash' calls for every
--   field of the constructor (if existent). It also works for
--   type families.
--
--   E. g. for the following code
--
--   @
--
-- data BlaFoo a = Foo
--               | Bar Int a
--               | Baz a a
--
-- $(deriveLargeHashable ''BlaFoo)
--   @
--
--   The following instance gets generated:
--
--   @
-- instance LargeHashable a_apg8 =>
--         LargeHashable (BlaFoo a_apg8) where
--  updateHash Foo = updateHash (0 :: Foreign.C.Types.CULong)
--  updateHash (Bar a b)
--    = (((updateHash (1 :: Foreign.C.Types.CULong)) >> (updateHash a))
--       >> (updateHash b))
--  updateHash (XY a b)
--    = (((updateHash (2 :: Foreign.C.Types.CULong)) >> (updateHash a))
--       >> (updateHash b))
--    @
deriveLargeHashable :: Name -> Q [Dec]
deriveLargeHashable :: Name -> Q [Dec]
deriveLargeHashable Name
n = Name -> Q Info
reify Name
n Q Info -> (Info -> Q [Dec]) -> Q [Dec]
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Info
info ->
    case Info
info of
        TyConI Dec
dec ->
            case Dec
dec of
#if MIN_VERSION_template_haskell(2,11,0)
                DataD Cxt
context Name
name [TyVarBndr ()]
tyvars Maybe Kind
_ [Con]
cons [DerivClause]
_ ->
#else
                DataD context name tyvars cons _ ->
#endif
                    Kind -> Cxt -> [TyVarBndr ()] -> [Con] -> Q [Dec]
forall f. Kind -> Cxt -> [TyVarBndr f] -> [Con] -> Q [Dec]
buildInstance (Name -> Kind
ConT Name
name) Cxt
context [TyVarBndr ()]
tyvars [Con]
cons

#if MIN_VERSION_template_haskell(2,11,0)
                NewtypeD Cxt
context Name
name [TyVarBndr ()]
tyvars Maybe Kind
_ Con
con [DerivClause]
_  ->
#else
                NewtypeD context name tyvars con _  ->
#endif
                    Kind -> Cxt -> [TyVarBndr ()] -> [Con] -> Q [Dec]
forall f. Kind -> Cxt -> [TyVarBndr f] -> [Con] -> Q [Dec]
buildInstance (Name -> Kind
ConT Name
name) Cxt
context [TyVarBndr ()]
tyvars [Con
con]
                Dec
_ -> String -> Q [Dec]
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q [Dec]) -> String -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ Name -> Info -> String
notDeriveAbleErrorMsg Name
n Info
info
        FamilyI Dec
_ [Dec]
instDecs -> ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Q [[Dec]] -> Q [Dec]) -> Q [[Dec]] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ [Dec] -> (Dec -> Q [Dec]) -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Dec]
instDecs ((Dec -> Q [Dec]) -> Q [[Dec]]) -> (Dec -> Q [Dec]) -> Q [[Dec]]
forall a b. (a -> b) -> a -> b
$ \Dec
instDec ->
            case Dec
instDec of
#if MIN_VERSION_template_haskell(2,15,0)
                DataInstD Cxt
context Maybe [TyVarBndr ()]
_ Kind
ty Maybe Kind
_ [Con]
cons [DerivClause]
_ ->
#elif MIN_VERSION_template_haskell(2,11,0)
                DataInstD context name types _ cons _ -> let ty = foldl AppT (ConT name) types in
#else
                DataInstD context name types cons _ -> let ty = foldl AppT (ConT name) types in
#endif
                    Kind -> Cxt -> [TyVarBndr Any] -> [Con] -> Q [Dec]
forall f. Kind -> Cxt -> [TyVarBndr f] -> [Con] -> Q [Dec]
buildInstance Kind
ty Cxt
context [] [Con]
cons
#if MIN_VERSION_template_haskell(2,15,0)
                NewtypeInstD Cxt
context Maybe [TyVarBndr ()]
_ Kind
ty Maybe Kind
_ Con
con [DerivClause]
_ ->
#elif MIN_VERSION_template_haskell(2,11,0)
                NewtypeInstD context name types _ con _ -> let ty = foldl AppT (ConT name) types in
#else
                NewtypeInstD context name types con _ -> let ty = foldl AppT (ConT name) types in
#endif
                    Kind -> Cxt -> [TyVarBndr Any] -> [Con] -> Q [Dec]
forall f. Kind -> Cxt -> [TyVarBndr f] -> [Con] -> Q [Dec]
buildInstance Kind
ty Cxt
context [] [Con
con]
                Dec
_ -> String -> Q [Dec]
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q [Dec]) -> String -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ Name -> Info -> String
notDeriveAbleErrorMsg Name
n Info
info
        Info
_ -> String -> Q [Dec]
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q [Dec]) -> String -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ Name -> Info -> String
notDeriveAbleErrorMsg Name
n Info
info

-- | Derive a 'LargeHashable' instance with extra constraints in the
-- context of the instance.
deriveLargeHashableCtx ::
       Name
    -> ([TypeQ] -> [PredQ])
       -- ^ Function mapping the type variables in the instance head to the additional constraints
    -> Q [Dec]
deriveLargeHashableCtx :: Name -> ([TypeQ] -> [TypeQ]) -> Q [Dec]
deriveLargeHashableCtx Name
tyName [TypeQ] -> [TypeQ]
extraPreds =
    Name -> ([TypeQ] -> [TypeQ] -> [TypeQ]) -> Q [Dec]
deriveLargeHashableCustomCtx Name
tyName [TypeQ] -> [TypeQ] -> [TypeQ]
mkCtx
    where
      mkCtx :: [TypeQ] -> [TypeQ] -> [TypeQ]
mkCtx [TypeQ]
args [TypeQ]
oldCtx =
          [TypeQ]
oldCtx [TypeQ] -> [TypeQ] -> [TypeQ]
forall a. [a] -> [a] -> [a]
++ [TypeQ] -> [TypeQ]
extraPreds [TypeQ]
args

-- | Derive a 'LargeHashable' instance with no constraints in the context of the instance.
deriveLargeHashableNoCtx ::
       Name
    -> (Q [Dec])
deriveLargeHashableNoCtx :: Name -> Q [Dec]
deriveLargeHashableNoCtx Name
tyName =
    Name -> ([TypeQ] -> [TypeQ] -> [TypeQ]) -> Q [Dec]
deriveLargeHashableCustomCtx Name
tyName (\[TypeQ]
_ [TypeQ]
_ -> [])

-- | Derive a 'LargeHashable' instance with a completely custom instance context.
deriveLargeHashableCustomCtx ::
       Name
    -> ([TypeQ] -> [PredQ] -> [PredQ])
       -- ^ Function mapping the type variables in the instance head and the
       -- constraints that would normally be generated to the constraints
       -- that should be generated.
    -> (Q [Dec])
deriveLargeHashableCustomCtx :: Name -> ([TypeQ] -> [TypeQ] -> [TypeQ]) -> Q [Dec]
deriveLargeHashableCustomCtx Name
tyName [TypeQ] -> [TypeQ] -> [TypeQ]
extraPreds =
    do [Dec]
decs <- Name -> Q [Dec]
deriveLargeHashable Name
tyName
       case [Dec]
decs of
#if MIN_VERSION_template_haskell(2,11,0)
         (InstanceD Maybe Overlap
overlap Cxt
ctx Kind
ty [Dec]
body : [Dec]
_) ->
#else
         (InstanceD ctx ty body : _) ->
#endif
             do let args :: Cxt
args = Cxt -> Cxt
forall a. [a] -> [a]
reverse (Kind -> Cxt
collectArgs Kind
ty)
                Cxt
newCtx <- [TypeQ] -> Q Cxt
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence ([TypeQ] -> [TypeQ] -> [TypeQ]
extraPreds ((Kind -> TypeQ) -> Cxt -> [TypeQ]
forall a b. (a -> b) -> [a] -> [b]
map Kind -> TypeQ
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Cxt
args) ((Kind -> TypeQ) -> Cxt -> [TypeQ]
forall a b. (a -> b) -> [a] -> [b]
map Kind -> TypeQ
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Cxt
ctx))
                -- _ <- fail ("args: " ++ show args ++", ty: " ++ show ty)
#if MIN_VERSION_template_haskell(2,11,0)
                [Dec] -> Q [Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return [Maybe Overlap -> Cxt -> Kind -> [Dec] -> Dec
InstanceD Maybe Overlap
overlap Cxt
newCtx Kind
ty [Dec]
body]
#else
                return [InstanceD newCtx ty body]
#endif
         [Dec]
_ ->
             String -> Q [Dec]
forall a. HasCallStack => String -> a
error (String -> Q [Dec]) -> String -> Q [Dec]
forall a b. (a -> b) -> a -> b
$
                 String
"Unexpected declarations returned by deriveLargeHashable: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Doc -> String
forall a. Show a => a -> String
show ([Dec] -> Doc
forall a. Ppr a => a -> Doc
ppr [Dec]
decs)
    where
      collectArgs :: Type -> [Type]
      collectArgs :: Kind -> Cxt
collectArgs Kind
outerTy =
          let loop :: Kind -> Cxt
loop Kind
ty =
                  case Kind
ty of
                    (AppT Kind
l Kind
r) ->
                        case Kind
l of
                          AppT Kind
_ Kind
_ -> Kind
r Kind -> Cxt -> Cxt
forall a. a -> [a] -> [a]
: Kind -> Cxt
loop Kind
l
                          Kind
_ -> [Kind
r]
                    Kind
_ -> []
          in case Kind
outerTy of
               AppT Kind
_ Kind
r -> Kind -> Cxt
loop Kind
r
               Kind
_ -> []

-- | Generates the error message displayed when somebody tries to let us
--   derive impossible instances!
notDeriveAbleErrorMsg :: Name -> Info -> String
notDeriveAbleErrorMsg :: Name -> Info -> String
notDeriveAbleErrorMsg Name
name Info
info = String
"Could not derive LargeHashable instance for "
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Name -> String
forall a. Show a => a -> String
show Name
name) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Info -> String
forall a. Show a => a -> String
show Info
info) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"). If you think this should be possible, file an issue."

-- | After 'deriveLargeHashable' has matched all the important information
--   this function gets called to build the instance declaration.
#if MIN_VERSION_template_haskell(2,17,0)
buildInstance :: Type -> Cxt -> [TyVarBndr f] -> [Con] ->  Q [Dec]
#else
buildInstance :: Type -> Cxt -> [TyVarBndr] -> [Con] ->  Q [Dec]
#endif
buildInstance :: forall f. Kind -> Cxt -> [TyVarBndr f] -> [Con] -> Q [Dec]
buildInstance Kind
basicType Cxt
context [TyVarBndr f]
vars [Con]
cons =
    let consWithIds :: [(Integer, Con)]
consWithIds = [Integer] -> [Con] -> [(Integer, Con)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Integer
0..] [Con]
cons
        constraints :: Q Cxt
constraints = Cxt -> [TyVarBndr f] -> Q Cxt
forall f. Cxt -> [TyVarBndr f] -> Q Cxt
makeConstraints Cxt
context [TyVarBndr f]
vars
        typeWithVars :: TypeQ
typeWithVars = (TypeQ -> TypeQ -> TypeQ) -> TypeQ -> [TypeQ] -> TypeQ
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl TypeQ -> TypeQ -> TypeQ
forall (m :: * -> *). Quote m => m Kind -> m Kind -> m Kind
appT (Kind -> TypeQ
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Kind
basicType) ([TypeQ] -> TypeQ) -> [TypeQ] -> TypeQ
forall a b. (a -> b) -> a -> b
$ (TyVarBndr f -> TypeQ) -> [TyVarBndr f] -> [TypeQ]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> TypeQ
forall (m :: * -> *). Quote m => Name -> m Kind
varT (Name -> TypeQ) -> (TyVarBndr f -> Name) -> TyVarBndr f -> TypeQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVarBndr f -> Name
forall f. TyVarBndr f -> Name
varName) [TyVarBndr f]
vars
      in (Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
:[]) (Dec -> [Dec]) -> Q Dec -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Cxt -> TypeQ -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m Cxt -> m Kind -> [m Dec] -> m Dec
instanceD Q Cxt
constraints (Name -> TypeQ
forall (m :: * -> *). Quote m => Name -> m Kind
conT ''LargeHashable TypeQ -> TypeQ -> TypeQ
forall (m :: * -> *). Quote m => m Kind -> m Kind -> m Kind
`appT` TypeQ
typeWithVars)
            [Name -> [(Integer, Con)] -> Q Dec
updateHashDeclaration 'updateHash [(Integer, Con)]
consWithIds,
             Name -> [(Integer, Con)] -> Q Dec
updateHashDeclaration 'updateHashStable [(Integer, Con)]
consWithIds]

-- | This function generates the declaration for the 'updateHash' and the
--   'updateHashStable functions
--   of the 'LargeHashable' typeclass. By taking the constructors with there
--   selected IDs and calling 'updateHashClause' for everyone of them to generate
--   the corresponding clause.
updateHashDeclaration :: Name -> [(Integer, Con)] -> Q Dec
updateHashDeclaration :: Name -> [(Integer, Con)] -> Q Dec
updateHashDeclaration Name
name [(Integer
_, Con
con)] =
    Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD Name
name [Name -> Maybe Integer -> Con -> Q Clause
updateHashClause Name
name Maybe Integer
forall a. Maybe a
Nothing Con
con]
updateHashDeclaration Name
name [(Integer, Con)]
consWIds =
    Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD Name
name (((Integer, Con) -> Q Clause) -> [(Integer, Con)] -> [Q Clause]
forall a b. (a -> b) -> [a] -> [b]
map ((Maybe Integer -> Con -> Q Clause)
-> (Maybe Integer, Con) -> Q Clause
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Name -> Maybe Integer -> Con -> Q Clause
updateHashClause Name
name) ((Maybe Integer, Con) -> Q Clause)
-> ((Integer, Con) -> (Maybe Integer, Con))
-> (Integer, Con)
-> Q Clause
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Integer -> Maybe Integer)
-> (Integer, Con) -> (Maybe Integer, Con)
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first Integer -> Maybe Integer
forall a. a -> Maybe a
Just) [(Integer, Con)]
consWIds)

-- | 'updateHashClause' generates a clause of the 'updateHash' function.
--   It makes sure all the fields are matched correctly and updates the hash
--   with the neccessary information about the constructor (its ID) and all
--   of its fields.
updateHashClause :: Name -> Maybe Integer -> Con -> Q Clause
updateHashClause :: Name -> Maybe Integer -> Con -> Q Clause
updateHashClause Name
name Maybe Integer
mI Con
con =
        [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [Pat -> Q Pat
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Pat
patOfClause]
            (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
forall a b. (a -> b) -> a -> b
$
                (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> [Q Exp] -> Q Exp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Q Exp -> Q Exp -> Q Exp
sequenceExps
                    Q Exp
conMarker
                    [Q Exp]
hashUpdatesOfConFields)
            []
    where conMarker :: Q Exp
conMarker = case Maybe Integer
mI of
                        Just Integer
i -> [| updateHash ($(Lit -> Q Exp
forall (m :: * -> *). Quote m => Lit -> m Exp
litE (Lit -> Q Exp) -> (Integer -> Lit) -> Integer -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Lit
IntegerL (Integer -> Q Exp) -> Integer -> Q Exp
forall a b. (a -> b) -> a -> b
$ Integer
i) :: Word64) |]
                        Maybe Integer
Nothing -> [| return () |]
          hashUpdatesOfConFields :: [Q Exp]
hashUpdatesOfConFields = (Name -> Q Exp) -> [Name] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map (\Name
pn -> [| $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
name) $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
pn) |]) [Name]
patVarNames
          -- Extract the names of all the
          -- pattern variables from usedPat.
          patVarNames :: [Name]
patVarNames = case Pat
patOfClause of
#if MIN_VERSION_template_haskell(2,18,0)
                          ConP Name
_ Cxt
_ [Pat]
vars -> (Pat -> Name) -> [Pat] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (\(VarP Name
v) -> Name
v) [Pat]
vars
#else
                          ConP _ vars -> map (\(VarP v) -> v) vars
#endif
                          InfixP (VarP Name
v1) Name
_ (VarP Name
v2) -> [Name
v1, Name
v2]
                          Pat
_ -> String -> [Name]
forall a. HasCallStack => String -> a
error String
"Pattern in patVarNames not matched!"
          patOfClause :: Pat
patOfClause = Con -> Pat
patternForCon Con
con

-- | Generate a Pattern that matches the supplied constructor
--   and all of its fields.
patternForCon :: Con -> Pat
patternForCon :: Con -> Pat
patternForCon Con
con = case Con
con of
              NormalC Name
n [BangType]
types -> Name -> [Pat] -> Pat
conP Name
n ([Pat] -> Pat) -> [Pat] -> Pat
forall a b. (a -> b) -> a -> b
$ Int -> [Pat]
uniqueVarPats ([BangType] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [BangType]
types)
              RecC Name
n [VarBangType]
varTypes -> Name -> [Pat] -> Pat
conP Name
n ([Pat] -> Pat) -> [Pat] -> Pat
forall a b. (a -> b) -> a -> b
$ Int -> [Pat]
uniqueVarPats ([VarBangType] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [VarBangType]
varTypes)
              InfixC BangType
_ Name
n BangType
_ -> Pat -> Name -> Pat -> Pat
InfixP (Name -> Pat
VarP (Name -> Pat) -> (String -> Name) -> String -> Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName (String -> Pat) -> String -> Pat
forall a b. (a -> b) -> a -> b
$ String
"x") Name
n (Name -> Pat
VarP (Name -> Pat) -> (String -> Name) -> String -> Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName (String -> Pat) -> String -> Pat
forall a b. (a -> b) -> a -> b
$ String
"y")
              c :: Con
c@(ForallC{}) -> String -> Pat
forall a. HasCallStack => String -> a
error (String -> Pat) -> String -> Pat
forall a b. (a -> b) -> a -> b
$ String
"Cannot derive quantified type as it would potentially violate uniqueness: "String -> String -> String
forall a. [a] -> [a] -> [a]
++ Con -> String
forall a. Show a => a -> String
show Con
c
#if MIN_VERSION_template_haskell(2,11,0)
              GadtC [Name
n] [BangType]
types Kind
_ -> Name -> [Pat] -> Pat
conP Name
n ([Pat] -> Pat) -> [Pat] -> Pat
forall a b. (a -> b) -> a -> b
$ Int -> [Pat]
uniqueVarPats ([BangType] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [BangType]
types)
              RecGadtC [Name
n] [VarBangType]
varTypes Kind
_ -> Name -> [Pat] -> Pat
conP Name
n ([Pat] -> Pat) -> [Pat] -> Pat
forall a b. (a -> b) -> a -> b
$ Int -> [Pat]
uniqueVarPats ([VarBangType] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [VarBangType]
varTypes)
              Con
_ -> String -> Pat
forall a. HasCallStack => String -> a
error (String -> Pat) -> String -> Pat
forall a b. (a -> b) -> a -> b
$ String
"Constructor not supported: "String -> String -> String
forall a. [a] -> [a] -> [a]
++Con -> String
forall a. Show a => a -> String
show Con
con
#endif
    where
        uniqueVarPats :: Int -> [Pat]
uniqueVarPats Int
n = Int -> [Pat] -> [Pat]
forall a. Int -> [a] -> [a]
take Int
n ([Pat] -> [Pat]) -> ([String] -> [Pat]) -> [String] -> [Pat]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Pat) -> [String] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> Pat
VarP (Name -> Pat) -> (String -> Name) -> String -> Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName) ([String] -> [Pat]) -> [String] -> [Pat]
forall a b. (a -> b) -> a -> b
$ [String]
names
        conP :: Name -> [Pat] -> Pat
conP Name
n =
#if MIN_VERSION_template_haskell(2,18,0)
            Name -> Cxt -> [Pat] -> Pat
ConP Name
n []
#else
            ConP n
#endif


-- | Sequences two Expressions using the '(>>)' operator.
sequenceExps :: Q Exp -> Q Exp -> Q Exp
sequenceExps :: Q Exp -> Q Exp -> Q Exp
sequenceExps Q Exp
first Q Exp
second = Maybe (Q Exp) -> Q Exp -> Maybe (Q Exp) -> Q Exp
forall (m :: * -> *).
Quote m =>
Maybe (m Exp) -> m Exp -> Maybe (m Exp) -> m Exp
infixE (Q Exp -> Maybe (Q Exp)
forall a. a -> Maybe a
Just Q Exp
first) (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE '(>>)) (Q Exp -> Maybe (Q Exp)
forall a. a -> Maybe a
Just Q Exp
second)

-- | Generates the constraints needed for the declaration of
--   the 'LargeHashable' class. This means that the constraint
--   @LargeHashable $TypeVar$@ is added for every type variable
--   the type has.
#if MIN_VERSION_template_haskell(2,17,0)
makeConstraints :: Cxt -> [TyVarBndr f] -> Q Cxt
#else
makeConstraints :: Cxt -> [TyVarBndr] -> Q Cxt
#endif
makeConstraints :: forall f. Cxt -> [TyVarBndr f] -> Q Cxt
makeConstraints Cxt
context [TyVarBndr f]
vars = Cxt -> Q Cxt
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Cxt -> Q Cxt) -> Cxt -> Q Cxt
forall a b. (a -> b) -> a -> b
$ Cxt
context Cxt -> Cxt -> Cxt
forall a. [a] -> [a] -> [a]
++
    (TyVarBndr f -> Kind) -> [TyVarBndr f] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map (\TyVarBndr f
v -> (Name -> Kind
ConT (TyVarBndr f -> Name
forall f. TyVarBndr f -> Name
toLargeHashableClass TyVarBndr f
v)) Kind -> Kind -> Kind
`AppT` (Name -> Kind
VarT (Name -> Kind) -> (TyVarBndr f -> Name) -> TyVarBndr f -> Kind
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVarBndr f -> Name
forall f. TyVarBndr f -> Name
varName (TyVarBndr f -> Kind) -> TyVarBndr f -> Kind
forall a b. (a -> b) -> a -> b
$ TyVarBndr f
v)) [TyVarBndr f]
vars
    where
#if MIN_VERSION_template_haskell(2,17,0)
      toLargeHashableClass :: TyVarBndr f -> Name
      toLargeHashableClass :: forall f. TyVarBndr f -> Name
toLargeHashableClass TyVarBndr f
var =
        case TyVarBndr f
var of
          (PlainTV Name
_ f
_) -> ''LargeHashable
          (KindedTV Name
_ f
_ (AppT (AppT Kind
ArrowT Kind
StarT) Kind
StarT)) -> ''LargeHashable'
          (KindedTV Name
_ f
_ Kind
_) -> ''LargeHashable
#else
      toLargeHashableClass :: TyVarBndr -> Name
      toLargeHashableClass var =
        case var of
          (PlainTV _) -> ''LargeHashable
          (KindedTV _ (AppT (AppT ArrowT StarT) StarT)) -> ''LargeHashable'
          (KindedTV _ _) -> ''LargeHashable
#endif

-- | Returns the 'Name' for a type variable.
#if MIN_VERSION_template_haskell(2,17,0)
varName :: TyVarBndr f -> Name
varName :: forall f. TyVarBndr f -> Name
varName (PlainTV Name
n f
_) = Name
n
varName (KindedTV Name
n f
_ Kind
_) = Name
n
#else
varName :: TyVarBndr -> Name
varName (PlainTV n) = n
varName (KindedTV n _) = n
#endif

-- | An infinite list of unique names that
--   are used in the generations of patterns.
names :: [String]
names :: [String]
names = [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[String]] -> [String]) -> [[String]] -> [String]
forall a b. (a -> b) -> a -> b
$ (Integer -> [String]) -> [Integer] -> [[String]]
forall a b. (a -> b) -> [a] -> [b]
map ([String] -> Integer -> [String]
gen ((Char -> String) -> String -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Char -> String -> String
forall a. a -> [a] -> [a]
:[]) [Char
'a'..Char
'z'])) [Integer
0..]
  where gen :: [String] -> Integer -> [String]
        gen :: [String] -> Integer -> [String]
gen [String]
acc Integer
0 = [String]
acc
        gen [String]
acc Integer
n = [String] -> Integer -> [String]
gen ([[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[String]] -> [String]) -> [[String]] -> [String]
forall a b. (a -> b) -> a -> b
$ (String -> [String]) -> [String] -> [[String]]
forall a b. (a -> b) -> [a] -> [b]
map (\String
q -> (Char -> String) -> String -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\Char
c -> Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: String
q) [Char
'a'..Char
'z']) [String]
acc) (Integer
n Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1)