    ------------------------------------------------------------------------
    -- |
    -- Module           : Data.Parameterized.TH.GADT
    -- Copyright        : (c) Galois, Inc 2013-2019
    -- Maintainer       : Joe Hendrix <jhendrix@galois.com>
    -- Description : Template Haskell primitives for working with large GADTs
    --
    -- This module declares template Haskell primitives so that it is easier
    -- to work with GADTs that have many constructors.
    ------------------------------------------------------------------------
    {-# LANGUAGE CPP #-}
    {-# LANGUAGE DoAndIfThenElse #-}
    {-# LANGUAGE GADTs #-}
    {-# LANGUAGE MultiParamTypeClasses #-}
    {-# LANGUAGE TemplateHaskell #-}
    {-# LANGUAGE TypeOperators #-}
    {-# LANGUAGE EmptyCase #-}
    module Data.Parameterized.TH.GADT
      ( -- * Instance generators
        -- $typePatterns
      structuralEquality
      , structuralTypeEquality
      , structuralTypeOrd
      , structuralTraversal
      , structuralShowsPrec
      , structuralHash
      , structuralHashWithSalt
      , PolyEq(..)
        -- * Repr generators (\"singletons\")
        -- $reprs
      , mkRepr
      , mkKnownReprs
        -- * Template haskell utilities that may be useful in other contexts.
      , DataD
      , lookupDataType'
      , asTypeCon
      , conPat
      , TypePat(..)
      , dataParamTypes
      , assocTypePats
      ) where

    import Control.Monad
    import Data.Maybe
    import Data.Set (Set)
    import qualified Data.Set as Set
    import Language.Haskell.TH
    import Language.Haskell.TH.Datatype

    import Data.Parameterized.Classes

    ------------------------------------------------------------------------
    -- Template Haskell utilities

    type DataD = DatatypeInfo

    lookupDataType' :: Name -> Q DatatypeInfo
    lookupDataType' :: Name -> Q DatatypeInfo
    lookupDataType' = Name -> Q DatatypeInfo
    reifyDatatype

    -- | Given a constructor and string, this generates a pattern for matching
    -- the expression, and the names of variables bound by pattern in order
    -- they appear in constructor.
    conPat ::
      ConstructorInfo {- ^ constructor information -} ->
      String          {- ^ generated name prefix   -} ->
      Q (Pat, [Name]) {- ^ pattern and bound names -}
    conPat :: ConstructorInfo -> String -> Q (Pat, [Name])
    conPat ConstructorInfo
    con String
    pre = do
      nms <- String -> Int -> Q [Name]
    newNames String
    pre ([Type] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length (ConstructorInfo -> [Type]
    constructorFields ConstructorInfo
    con))
      return (conPCompat (constructorName con) (VarP <$> nms), nms)

    -- | Return an expression corresponding to the constructor.
    -- Note that this will have the type of a function expecting
    -- the argumetns given.
    conExpr :: ConstructorInfo -> Exp
    conExpr :: ConstructorInfo -> Exp
    conExpr = Name -> Exp
    ConE (Name -> Exp)
    -> (ConstructorInfo -> Name) -> ConstructorInfo -> Exp
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ConstructorInfo -> Name
    constructorName

    ------------------------------------------------------------------------
    -- TypePat

    -- | A type used to describe (and match) types appearing in generated pattern
    -- matches inside of the TH generators in this module ('structuralEquality',
    -- 'structuralTypeEquality', 'structuralTypeOrd', and 'structuralTraversal')
    data TypePat
       = TypeApp TypePat TypePat -- ^ The application of a type.
       | AnyType       -- ^ Match any type.
       | DataArg Int   -- ^ Match the i'th argument of the data type we are traversing.
       | ConType TypeQ -- ^ Match a ground type.

    matchTypePat :: [Type] -> TypePat -> Type -> Q Bool
    matchTypePat :: [Type] -> TypePat -> Type -> Q Bool
    matchTypePat [Type]
    d (TypeApp TypePat
    p TypePat
    q) (AppT Type
    x Type
    y) = do
      r <- [Type] -> TypePat -> Type -> Q Bool
    matchTypePat [Type]
    d TypePat
    p Type
    x
      case r of
        Bool
    True -> [Type] -> TypePat -> Type -> Q Bool
    matchTypePat [Type]
    d TypePat
    q Type
    y
        Bool
    False -> Bool -> Q Bool
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Bool
    False
    matchTypePat [Type]
    _ TypePat
    AnyType Type
    _ = Bool -> Q Bool
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Bool
    True
    matchTypePat [Type]
    tps (DataArg Int
    i) Type
    tp
      | Int
    i Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    < Int
    0 Bool -> Bool -> Bool
    || Int
    i Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    >= [Type] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [Type]
    tps = String -> Q Bool
    forall a. HasCallStack => String -> a
    error (String
    "Type pattern index " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Int -> String
    forall a. Show a => a -> String
    show Int
    i String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    " out of bounds")
      | Bool
    otherwise = Bool -> Q Bool
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Type -> Type
    stripSigT ([Type]
    tps [Type] -> Int -> Type
    forall a. HasCallStack => [a] -> Int -> a
    !! Int
    i) Type -> Type -> Bool
    forall a. Eq a => a -> a -> Bool
    == Type
    tp)
      where
        -- th-abstraction can annotate type parameters with their kinds,
        -- we ignore these for matching
        stripSigT :: Type -> Type
    stripSigT (SigT Type
    t Type
    _) = Type
    t
        stripSigT Type
    t          = Type
    t
    matchTypePat [Type]
    _ (ConType TypeQ
    tpq) Type
    tp = do
      tp' <- TypeQ
    tpq
      return (tp' == tp)
    matchTypePat [Type]
    _ TypePat
    _ Type
    _ = Bool -> Q Bool
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Bool
    False

    -- | The dataParamTypes function returns the list of Type arguments
    -- for the constructor.  For example, if passed the DatatypeInfo for a
    -- @newtype Id a = MkId a@ then this would return @['SigT' ('VarT' a)
    -- 'StarT']@.  Note that there may be type *variables* not referenced
    -- in the returned array; this simply returns the type *arguments*.
    dataParamTypes :: DatatypeInfo -> [Type]
    dataParamTypes :: DatatypeInfo -> [Type]
    dataParamTypes = DatatypeInfo -> [Type]
    datatypeInstTypes
     -- see th-abstraction 'dataTypeVars' for the type variables if needed

    -- | Find value associated with first pattern that matches given pat if any.
    assocTypePats :: [Type] -> [(TypePat, v)] -> Type -> Q (Maybe v)
    assocTypePats :: forall v. [Type] -> [(TypePat, v)] -> Type -> Q (Maybe v)
    assocTypePats [Type]
    _ [] Type
    _ = Maybe v -> Q (Maybe v)
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Maybe v
    forall a. Maybe a
    Nothing
    assocTypePats [Type]
    dTypes ((TypePat
    p,v
    v):[(TypePat, v)]
    pats) Type
    tp = do
      r <- [Type] -> TypePat -> Type -> Q Bool
    matchTypePat [Type]
    dTypes TypePat
    p Type
    tp
      case r of
        Bool
    True -> Maybe v -> Q (Maybe v)
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (v -> Maybe v
    forall a. a -> Maybe a
    Just v
    v)
        Bool
    False -> [Type] -> [(TypePat, v)] -> Type -> Q (Maybe v)
    forall v. [Type] -> [(TypePat, v)] -> Type -> Q (Maybe v)
    assocTypePats [Type]
    dTypes [(TypePat, v)]
    pats Type
    tp

    ------------------------------------------------------------------------
    -- Contructor cases

    typeVars :: TypeSubstitution a => a -> Set Name
    typeVars :: forall a. TypeSubstitution a => a -> Set Name
    typeVars = [Name] -> Set Name
    forall a. Ord a => [a] -> Set a
    Set.fromList ([Name] -> Set Name) -> (a -> [Name]) -> a -> Set Name
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . a -> [Name]
    forall a. TypeSubstitution a => a -> [Name]
    freeVariables

    -- | @structuralEquality@ declares a structural equality predicate.
    structuralEquality :: TypeQ -> [(TypePat,ExpQ)] -> ExpQ
    structuralEquality :: TypeQ -> [(TypePat, ExpQ)] -> ExpQ
    structuralEquality TypeQ
    tpq [(TypePat, ExpQ)]
    pats =
      [| \x y -> isJust ($(TypeQ -> [(TypePat, ExpQ)] -> ExpQ
    structuralTypeEquality TypeQ
    tpq [(TypePat, ExpQ)]
    pats) x y) |]

    joinEqMaybe :: Name -> Name -> ExpQ -> ExpQ
    joinEqMaybe :: Name -> Name -> ExpQ -> ExpQ
    joinEqMaybe Name
    x Name
    y ExpQ
    r = do
      [| if $(Name -> ExpQ
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE Name
    x) == $(Name -> ExpQ
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE Name
    y) then $(ExpQ
    r) else Nothing |]

    joinTestEquality :: ExpQ -> Name -> Name -> ExpQ -> ExpQ
    joinTestEquality :: ExpQ -> Name -> Name -> ExpQ -> ExpQ
    joinTestEquality ExpQ
    f Name
    x Name
    y ExpQ
    r =
      [| case $(ExpQ
    f) $(Name -> ExpQ
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE Name
    x) $(Name -> ExpQ
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE Name
    y) of
          Nothing -> Nothing
          Just Refl -> $(ExpQ
    r)
       |]

    matchEqArguments :: [Type]
                        -- ^ Types bound by data arguments.
                     -> [(TypePat,ExpQ)] -- ^ Patterns for matching arguments
                     -> Name
                         -- ^ Name of constructor.
                     -> Set Name
                     -> [Type]
                     -> [Name]
                     -> [Name]
                     -> ExpQ
    matchEqArguments :: [Type]
    -> [(TypePat, ExpQ)]
    -> Name
    -> Set Name
    -> [Type]
    -> [Name]
    -> [Name]
    -> ExpQ
    matchEqArguments [Type]
    dTypes [(TypePat, ExpQ)]
    pats Name
    cnm Set Name
    bnd (Type
    tp:[Type]
    tpl) (Name
    x:[Name]
    xl) (Name
    y:[Name]
    yl) = do
      doesMatch <- [Type] -> [(TypePat, ExpQ)] -> Type -> Q (Maybe ExpQ)
    forall v. [Type] -> [(TypePat, v)] -> Type -> Q (Maybe v)
    assocTypePats [Type]
    dTypes [(TypePat, ExpQ)]
    pats Type
    tp
      case doesMatch of
        Just ExpQ
    q -> do
          let bnd' :: Set Name
    bnd' =
                case Type
    tp of
                  AppT Type
    _ (VarT Name
    nm) -> Name -> Set Name -> Set Name
    forall a. Ord a => a -> Set a -> Set a
    Set.insert Name
    nm Set Name
    bnd
                  Type
    _ -> Set Name
    bnd
          ExpQ -> Name -> Name -> ExpQ -> ExpQ
    joinTestEquality ExpQ
    q Name
    x Name
    y ([Type]
    -> [(TypePat, ExpQ)]
    -> Name
    -> Set Name
    -> [Type]
    -> [Name]
    -> [Name]
    -> ExpQ
    matchEqArguments [Type]
    dTypes [(TypePat, ExpQ)]
    pats Name
    cnm Set Name
    bnd' [Type]
    tpl [Name]
    xl [Name]
    yl)
        Maybe ExpQ
    Nothing | Type -> Set Name
    forall a. TypeSubstitution a => a -> Set Name
    typeVars Type
    tp Set Name -> Set Name -> Bool
    forall a. Ord a => Set a -> Set a -> Bool
    `Set.isSubsetOf` Set Name
    bnd -> do
          Name -> Name -> ExpQ -> ExpQ
    joinEqMaybe Name
    x Name
    y        ([Type]
    -> [(TypePat, ExpQ)]
    -> Name
    -> Set Name
    -> [Type]
    -> [Name]
    -> [Name]
    -> ExpQ
    matchEqArguments [Type]
    dTypes [(TypePat, ExpQ)]
    pats Name
    cnm Set Name
    bnd  [Type]
    tpl [Name]
    xl [Name]
    yl)
        Maybe ExpQ
    Nothing -> do
          String -> ExpQ
    forall a. String -> Q a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> ExpQ) -> String -> ExpQ
    forall a b. (a -> b) -> a -> b
    $ String
    "Unsupported argument type " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Type -> String
    forall a. Show a => a -> String
    show Type
    tp
              String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    " in " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Doc -> String
    forall a. Show a => a -> String
    show (Name -> Doc
    forall a. Ppr a => a -> Doc
    ppr Name
    cnm) String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "."
    matchEqArguments [Type]
    _ [(TypePat, ExpQ)]
    _ Name
    _ Set Name
    _ [] [] [] = [| Just Refl |]
    matchEqArguments [Type]
    _ [(TypePat, ExpQ)]
    _ Name
    _ Set Name
    _ [] [Name]
    _  [Name]
    _  = String -> ExpQ
    forall a. HasCallStack => String -> a
    error String
    "Unexpected end of types."
    matchEqArguments [Type]
    _ [(TypePat, ExpQ)]
    _ Name
    _ Set Name
    _ [Type]
    _  [] [Name]
    _  = String -> ExpQ
    forall a. HasCallStack => String -> a
    error String
    "Unexpected end of names."
    matchEqArguments [Type]
    _ [(TypePat, ExpQ)]
    _ Name
    _ Set Name
    _ [Type]
    _  [Name]
    _  [] = String -> ExpQ
    forall a. HasCallStack => String -> a
    error String
    "Unexpected end of names."

    mkSimpleEqF :: [Type] -- ^ Data declaration types
                -> Set Name
                 -> [(TypePat,ExpQ)] -- ^ Patterns for matching arguments
                 -> ConstructorInfo
                 -> [Name]
                 -> ExpQ
                 -> Bool -- ^ wildcard case required
                 -> ExpQ
    mkSimpleEqF :: [Type]
    -> Set Name
    -> [(TypePat, ExpQ)]
    -> ConstructorInfo
    -> [Name]
    -> ExpQ
    -> Bool
    -> ExpQ
    mkSimpleEqF [Type]
    dTypes Set Name
    bnd [(TypePat, ExpQ)]
    pats ConstructorInfo
    con [Name]
    xv ExpQ
    yQ Bool
    multipleCases = do
      -- Get argument types for constructor.
      let nm :: Name
    nm = ConstructorInfo -> Name
    constructorName ConstructorInfo
    con
      (yp,yv) <- ConstructorInfo -> String -> Q (Pat, [Name])
    conPat ConstructorInfo
    con String
    "y"
      let rv = [Type]
    -> [(TypePat, ExpQ)]
    -> Name
    -> Set Name
    -> [Type]
    -> [Name]
    -> [Name]
    -> ExpQ
    matchEqArguments [Type]
    dTypes [(TypePat, ExpQ)]
    pats Name
    nm Set Name
    bnd (ConstructorInfo -> [Type]
    constructorFields ConstructorInfo
    con) [Name]
    xv [Name]
    yv
      caseE yQ $ match (pure yp) (normalB rv) []
               : [ match wildP (normalB [| Nothing |]) [] | multipleCases ]

    -- | Match equational form.
    mkEqF :: DatatypeInfo -- ^ Data declaration.
          -> [(TypePat,ExpQ)]
          -> ConstructorInfo
          -> [Name]
          -> ExpQ
          -> Bool -- ^ wildcard case required
          -> ExpQ
    mkEqF :: DatatypeInfo
    -> [(TypePat, ExpQ)]
    -> ConstructorInfo
    -> [Name]
    -> ExpQ
    -> Bool
    -> ExpQ
    mkEqF DatatypeInfo
    d [(TypePat, ExpQ)]
    pats ConstructorInfo
    con =
      let dVars :: [Type]
    dVars = DatatypeInfo -> [Type]
    dataParamTypes DatatypeInfo
    d  -- the type arguments for the constructor
          -- bnd is the list of type arguments for this datatype.  Since
          -- this is Functor equality, ignore the final type since this is
          -- a higher-kinded equality.
          bnd :: Set Name
    bnd | [Type] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [Type]
    dVars = Set Name
    forall a. Set a
    Set.empty
              | Bool
    otherwise  = [Type] -> Set Name
    forall a. TypeSubstitution a => a -> Set Name
    typeVars ([Type] -> [Type]
    forall a. HasCallStack => [a] -> [a]
    init [Type]
    dVars)
      in [Type]
    -> Set Name
    -> [(TypePat, ExpQ)]
    -> ConstructorInfo
    -> [Name]
    -> ExpQ
    -> Bool
    -> ExpQ
    mkSimpleEqF [Type]
    dVars Set Name
    bnd [(TypePat, ExpQ)]
    pats ConstructorInfo
    con

    -- | @structuralTypeEquality f@ returns a function with the type:
    --   @
    --     forall x y . f x -> f y -> Maybe (x :~: y)
    --   @
    structuralTypeEquality :: TypeQ -> [(TypePat,ExpQ)] -> ExpQ
    structuralTypeEquality :: TypeQ -> [(TypePat, ExpQ)] -> ExpQ
    structuralTypeEquality TypeQ
    tpq [(TypePat, ExpQ)]
    pats = do
      d <- Name -> Q DatatypeInfo
    reifyDatatype (Name -> Q DatatypeInfo) -> Q Name -> Q DatatypeInfo
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
    =<< String -> Type -> Q Name
    asTypeCon String
    "structuralTypeEquality" (Type -> Q Name) -> TypeQ -> Q Name
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
    =<< TypeQ
    tpq

      let multipleCons = Bool -> Bool
    not ([ConstructorInfo] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null (Int -> [ConstructorInfo] -> [ConstructorInfo]
    forall a. Int -> [a] -> [a]
    drop Int
    1 (DatatypeInfo -> [ConstructorInfo]
    datatypeCons DatatypeInfo
    d)))
          trueEqs ExpQ
    yQ = [ do (xp,xv) <- ConstructorInfo -> String -> Q (Pat, [Name])
    conPat ConstructorInfo
    con String
    "x"
                            match (pure xp) (normalB (mkEqF d pats con xv yQ multipleCons)) []
                       | ConstructorInfo
    con <- DatatypeInfo -> [ConstructorInfo]
    datatypeCons DatatypeInfo
    d
                       ]

      if null (datatypeCons d)
        then [| \x -> case x of {} |]
        else [| \x y -> $(caseE [| x |] (trueEqs [| y |])) |]

    -- | @structuralTypeOrd f@ returns a function with the type:
    --   @
    --     forall x y . f x -> f y -> OrderingF x y
    --   @
    --
    -- This implementation avoids matching on both the first and second
    -- parameters in a simple case expression in order to avoid stressing
    -- GHC's coverage checker. In the case that the first and second parameters
    -- have unique constructors, a simple numeric comparison is done to
    -- compute the result.
    structuralTypeOrd ::
      TypeQ ->
      [(TypePat,ExpQ)] {- ^ List of type patterns to match. -} ->
      ExpQ
    structuralTypeOrd :: TypeQ -> [(TypePat, ExpQ)] -> ExpQ
    structuralTypeOrd TypeQ
    tpq [(TypePat, ExpQ)]
    l = do
      d <- Name -> Q DatatypeInfo
    reifyDatatype (Name -> Q DatatypeInfo) -> Q Name -> Q DatatypeInfo
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
    =<< String -> Type -> Q Name
    asTypeCon String
    "structuralTypeEquality" (Type -> Q Name) -> TypeQ -> Q Name
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
    =<< TypeQ
    tpq

      let withNumber :: ExpQ -> (Maybe ExpQ -> ExpQ) -> ExpQ
          withNumber ExpQ
    yQ Maybe ExpQ -> ExpQ
    k
            | [ConstructorInfo] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null (Int -> [ConstructorInfo] -> [ConstructorInfo]
    forall a. Int -> [a] -> [a]
    drop Int
    1 (DatatypeInfo -> [ConstructorInfo]
    datatypeCons DatatypeInfo
    d)) = Maybe ExpQ -> ExpQ
    k Maybe ExpQ
    forall a. Maybe a
    Nothing
            | Bool
    otherwise =  [| let yn :: Int
                                  yn = $(ExpQ -> [Q Match] -> ExpQ
    forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
    caseE ExpQ
    yQ ([ConstructorInfo] -> [Q Match]
    constructorNumberMatches (DatatypeInfo -> [ConstructorInfo]
    datatypeCons DatatypeInfo
    d)))
                              in $(Maybe ExpQ -> ExpQ
    k (ExpQ -> Maybe ExpQ
    forall a. a -> Maybe a
    Just [| yn |])) |]

      if null (datatypeCons d)
        then [| \x -> case x of {} |]
        else [| \x y -> $(withNumber [|y|] $ \Maybe ExpQ
    mbYn -> ExpQ -> [Q Match] -> ExpQ
    forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
    caseE [| x |] (DatatypeInfo -> ExpQ -> Maybe ExpQ -> [Q Match]
    outerOrdMatches DatatypeInfo
    d [|y|] Maybe ExpQ
    mbYn)) |]
      where
        constructorNumberMatches :: [ConstructorInfo] -> [MatchQ]
        constructorNumberMatches :: [ConstructorInfo] -> [Q Match]
    constructorNumberMatches [ConstructorInfo]
    cons =
          [ Q Pat -> Q Body -> [Q Dec] -> Q Match
    forall (m :: * -> *).
    Quote m =>
    m Pat -> m Body -> [m Dec] -> m Match
    match (Name -> [Q FieldPat] -> Q Pat
    forall (m :: * -> *). Quote m => Name -> [m FieldPat] -> m Pat
    recP (ConstructorInfo -> Name
    constructorName ConstructorInfo
    con) [])
                  (ExpQ -> Q Body
    forall (m :: * -> *). Quote m => m Exp -> m Body
    normalB (Lit -> ExpQ
    forall (m :: * -> *). Quote m => Lit -> m Exp
    litE (Integer -> Lit
    integerL Integer
    i)))
                  []
          | (Integer
    i,ConstructorInfo
    con) <- [Integer] -> [ConstructorInfo] -> [(Integer, ConstructorInfo)]
    forall a b. [a] -> [b] -> [(a, b)]
    zip [Integer
    0..] [ConstructorInfo]
    cons ]

        outerOrdMatches :: DatatypeInfo -> ExpQ -> Maybe ExpQ -> [MatchQ]
        outerOrdMatches :: DatatypeInfo -> ExpQ -> Maybe ExpQ -> [Q Match]
    outerOrdMatches DatatypeInfo
    d ExpQ
    yExp Maybe ExpQ
    mbYn =
          [ do (pat,xv) <- ConstructorInfo -> String -> Q (Pat, [Name])
    conPat ConstructorInfo
    con String
    "x"
               match (pure pat)
                     (normalB (do xs <- mkOrdF d l con i mbYn xv
                                  caseE yExp xs))
                     []
          | (Integer
    i,ConstructorInfo
    con) <- [Integer] -> [ConstructorInfo] -> [(Integer, ConstructorInfo)]
    forall a b. [a] -> [b] -> [(a, b)]
    zip [Integer
    0..] (DatatypeInfo -> [ConstructorInfo]
    datatypeCons DatatypeInfo
    d) ]

    -- | Generate a list of fresh names using the base name
    -- and numbered 1 to @n@ to make them useful in conjunction with
    -- @-dsuppress-uniques@.
    newNames ::
      String   {- ^ base name                     -} ->
      Int      {- ^ quantity                      -} ->
      Q [Name] {- ^ list of names: @base1@, @base2@, ... -}
    newNames :: String -> Int -> Q [Name]
    newNames String
    base Int
    n = (Int -> Q Name) -> [Int] -> Q [Name]
    forall (t :: * -> *) (f :: * -> *) a b.
    (Traversable t, Applicative f) =>
    (a -> f b) -> t a -> f (t b)
    forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> [a] -> f [b]
    traverse (\Int
    i -> String -> Q Name
    forall (m :: * -> *). Quote m => String -> m Name
    newName (String
    base String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Int -> String
    forall a. Show a => a -> String
    show Int
    i)) [Int
    1..Int
    n]

    joinCompareF :: ExpQ -> Name -> Name -> ExpQ -> ExpQ
    joinCompareF :: ExpQ -> Name -> Name -> ExpQ -> ExpQ
    joinCompareF ExpQ
    f Name
    x Name
    y ExpQ
    r = do
      [| case $(ExpQ
    f) $(Name -> ExpQ
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE Name
    x) $(Name -> ExpQ
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE Name
    y) of
          LTF -> LTF
          GTF -> GTF
          EQF -> $(ExpQ
    r)
       |]

    -- | Compare two variables, returning the third argument if they are equal.
    --
    -- This returns an 'OrdF' instance.
    joinCompareToOrdF :: Name -> Name -> ExpQ -> ExpQ
    joinCompareToOrdF :: Name -> Name -> ExpQ -> ExpQ
    joinCompareToOrdF Name
    x Name
    y ExpQ
    r =
      [| case compare $(Name -> ExpQ
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE Name
    x) $(Name -> ExpQ
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE Name
    y) of
          LT -> LTF
          GT -> GTF
          EQ -> $(ExpQ
    r)
       |]

    -- | Match expression with given type to variables
    matchOrdArguments :: [Type]
                         -- ^ Types bound by data arguments
                      -> [(TypePat,ExpQ)] -- ^ Patterns for matching arguments
                      -> Name
                         -- ^ Name of constructor.
                      -> Set Name
                        -- ^ Names bound in data declaration
                      -> [Type]
                         -- ^ Types for constructors
                      -> [Name]
                         -- ^ Variables bound in first pattern
                      -> [Name]
                         -- ^ Variables bound in second pattern
                      -> ExpQ
    matchOrdArguments :: [Type]
    -> [(TypePat, ExpQ)]
    -> Name
    -> Set Name
    -> [Type]
    -> [Name]
    -> [Name]
    -> ExpQ
    matchOrdArguments [Type]
    dTypes [(TypePat, ExpQ)]
    pats Name
    cnm Set Name
    bnd (Type
    tp : [Type]
    tpl) (Name
    x:[Name]
    xl) (Name
    y:[Name]
    yl) = do
      doesMatch <- [Type] -> [(TypePat, ExpQ)] -> Type -> Q (Maybe ExpQ)
    forall v. [Type] -> [(TypePat, v)] -> Type -> Q (Maybe v)
    assocTypePats [Type]
    dTypes [(TypePat, ExpQ)]
    pats Type
    tp
      case doesMatch of
        Just ExpQ
    f -> do
          let bnd' :: Set Name
    bnd' = case Type
    tp of
                       AppT Type
    _ (VarT Name
    nm) -> Name -> Set Name -> Set Name
    forall a. Ord a => a -> Set a -> Set a
    Set.insert Name
    nm Set Name
    bnd
                       Type
    _ -> Set Name
    bnd
          ExpQ -> Name -> Name -> ExpQ -> ExpQ
    joinCompareF ExpQ
    f Name
    x Name
    y ([Type]
    -> [(TypePat, ExpQ)]
    -> Name
    -> Set Name
    -> [Type]
    -> [Name]
    -> [Name]
    -> ExpQ
    matchOrdArguments [Type]
    dTypes [(TypePat, ExpQ)]
    pats Name
    cnm Set Name
    bnd' [Type]
    tpl [Name]
    xl [Name]
    yl)
        Maybe ExpQ
    Nothing | Type -> Set Name
    forall a. TypeSubstitution a => a -> Set Name
    typeVars Type
    tp Set Name -> Set Name -> Bool
    forall a. Ord a => Set a -> Set a -> Bool
    `Set.isSubsetOf` Set Name
    bnd -> do
          Name -> Name -> ExpQ -> ExpQ
    joinCompareToOrdF Name
    x Name
    y ([Type]
    -> [(TypePat, ExpQ)]
    -> Name
    -> Set Name
    -> [Type]
    -> [Name]
    -> [Name]
    -> ExpQ
    matchOrdArguments [Type]
    dTypes [(TypePat, ExpQ)]
    pats Name
    cnm Set Name
    bnd [Type]
    tpl [Name]
    xl [Name]
    yl)
        Maybe ExpQ
    Nothing ->
          String -> ExpQ
    forall a. String -> Q a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> ExpQ) -> String -> ExpQ
    forall a b. (a -> b) -> a -> b
    $ String
    "Unsupported argument type " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Doc -> String
    forall a. Show a => a -> String
    show (Type -> Doc
    forall a. Ppr a => a -> Doc
    ppr Type
    tp)
                 String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    " in " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Doc -> String
    forall a. Show a => a -> String
    show (Name -> Doc
    forall a. Ppr a => a -> Doc
    ppr Name
    cnm) String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "."
    matchOrdArguments [Type]
    _ [(TypePat, ExpQ)]
    _ Name
    _ Set Name
    _ [] [] [] = [| EQF |]
    matchOrdArguments [Type]
    _ [(TypePat, ExpQ)]
    _ Name
    _ Set Name
    _ [] [Name]
    _  [Name]
    _  = String -> ExpQ
    forall a. HasCallStack => String -> a
    error String
    "Unexpected end of types."
    matchOrdArguments [Type]
    _ [(TypePat, ExpQ)]
    _ Name
    _ Set Name
    _ [Type]
    _  [] [Name]
    _  = String -> ExpQ
    forall a. HasCallStack => String -> a
    error String
    "Unexpected end of names."
    matchOrdArguments [Type]
    _ [(TypePat, ExpQ)]
    _ Name
    _ Set Name
    _ [Type]
    _  [Name]
    _  [] = String -> ExpQ
    forall a. HasCallStack => String -> a
    error String
    "Unexpected end of names."

    mkSimpleOrdF :: [Type] -- ^ Data declaration types
                 -> [(TypePat,ExpQ)] -- ^ Patterns for matching arguments
                 -> ConstructorInfo -- ^ Information about the second constructor
                 -> Integer -- ^ First constructor's index
                 -> Maybe ExpQ -- ^ Optional second constructor's index
                 -> [Name]  -- ^ Name from first pattern
                 -> Q [MatchQ]
    mkSimpleOrdF :: [Type]
    -> [(TypePat, ExpQ)]
    -> ConstructorInfo
    -> Integer
    -> Maybe ExpQ
    -> [Name]
    -> Q [Q Match]
    mkSimpleOrdF [Type]
    dTypes [(TypePat, ExpQ)]
    pats ConstructorInfo
    con Integer
    xnum Maybe ExpQ
    mbYn [Name]
    xv = do
      (yp,yv) <- ConstructorInfo -> String -> Q (Pat, [Name])
    conPat ConstructorInfo
    con String
    "y"
      let rv = [Type]
    -> [(TypePat, ExpQ)]
    -> Name
    -> Set Name
    -> [Type]
    -> [Name]
    -> [Name]
    -> ExpQ
    matchOrdArguments [Type]
    dTypes [(TypePat, ExpQ)]
    pats (ConstructorInfo -> Name
    constructorName ConstructorInfo
    con) Set Name
    forall a. Set a
    Set.empty (ConstructorInfo -> [Type]
    constructorFields ConstructorInfo
    con) [Name]
    xv [Name]
    yv
      -- Return match expression
      return $ match (pure yp) (normalB rv) []
             : case mbYn of
                 Maybe ExpQ
    Nothing -> []
                 Just ExpQ
    yn -> [Q Pat -> Q Body -> [Q Dec] -> Q Match
    forall (m :: * -> *).
    Quote m =>
    m Pat -> m Body -> [m Dec] -> m Match
    match Q Pat
    forall (m :: * -> *). Quote m => m Pat
    wildP (ExpQ -> Q Body
    forall (m :: * -> *). Quote m => m Exp -> m Body
    normalB [| if xnum < $ExpQ
    yn then LTF else GTF |]) []]

    -- | Match equational form.
    mkOrdF :: DatatypeInfo -- ^ Data declaration.
           -> [(TypePat,ExpQ)] -- ^ Patterns for matching arguments
           -> ConstructorInfo
           -> Integer
           -> Maybe ExpQ -- ^ optional right constructr index
           -> [Name]
           -> Q [MatchQ]
    mkOrdF :: DatatypeInfo
    -> [(TypePat, ExpQ)]
    -> ConstructorInfo
    -> Integer
    -> Maybe ExpQ
    -> [Name]
    -> Q [Q Match]
    mkOrdF DatatypeInfo
    d [(TypePat, ExpQ)]
    pats = [Type]
    -> [(TypePat, ExpQ)]
    -> ConstructorInfo
    -> Integer
    -> Maybe ExpQ
    -> [Name]
    -> Q [Q Match]
    mkSimpleOrdF (DatatypeInfo -> [Type]
    datatypeInstTypes DatatypeInfo
    d) [(TypePat, ExpQ)]
    pats

    -- | @genTraverseOfType f var tp@ applies @f@ to @var@ where @var@ has type @tp@.
    genTraverseOfType :: [Type]
                        -- ^ Argument types for the data declaration.
                     -> [(TypePat, ExpQ)]
                        -- ^ Patterrns the user provided for overriding type lookup.
                      -> ExpQ -- ^ Function to apply
                      -> ExpQ -- ^ Expression denoting value of this constructor field.
                      -> Type -- ^ Type bound for this constructor field.
                      -> Q (Maybe Exp)
    genTraverseOfType :: [Type]
    -> [(TypePat, ExpQ)] -> ExpQ -> ExpQ -> Type -> Q (Maybe Exp)
    genTraverseOfType [Type]
    dataArgs [(TypePat, ExpQ)]
    pats ExpQ
    f ExpQ
    v Type
    tp = do
      mr <- [Type] -> [(TypePat, ExpQ)] -> Type -> Q (Maybe ExpQ)
    forall v. [Type] -> [(TypePat, v)] -> Type -> Q (Maybe v)
    assocTypePats [Type]
    dataArgs [(TypePat, ExpQ)]
    pats Type
    tp
      case mr of
        Just ExpQ
    g ->  Exp -> Maybe Exp
    forall a. a -> Maybe a
    Just (Exp -> Maybe Exp) -> ExpQ -> Q (Maybe Exp)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> [| $(ExpQ
    g) $(ExpQ
    f) $(ExpQ
    v) |]
        Maybe ExpQ
    Nothing ->
          case Type
    tp of
            AppT (ConT Name
    _) (AppT (VarT Name
    _) Type
    _) -> Exp -> Maybe Exp
    forall a. a -> Maybe a
    Just (Exp -> Maybe Exp) -> ExpQ -> Q (Maybe Exp)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> [| traverse $(ExpQ
    f) $(ExpQ
    v) |]
            AppT (VarT Name
    _) Type
    _ -> Exp -> Maybe Exp
    forall a. a -> Maybe a
    Just (Exp -> Maybe Exp) -> ExpQ -> Q (Maybe Exp)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> [| $(ExpQ
    f) $(ExpQ
    v) |]
            Type
    _ -> Maybe Exp -> Q (Maybe Exp)
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Maybe Exp
    forall a. Maybe a
    Nothing

    -- | @traverseAppMatch patMatch cexp @ builds a case statement that matches a term with
    -- the constructor @c@ and applies @f@ to each argument.
    traverseAppMatch :: [Type]
                        -- ^ Argument types for the data declaration.
                     -> [(TypePat, ExpQ)]
                        -- ^ Patterrns the user provided for overriding type lookup.
                     -> ExpQ -- ^ Function @f@ given to `traverse`
                     -> ConstructorInfo -- ^ Constructor to match.
                     -> MatchQ
    traverseAppMatch :: [Type] -> [(TypePat, ExpQ)] -> ExpQ -> ConstructorInfo -> Q Match
    traverseAppMatch [Type]
    dataArgs [(TypePat, ExpQ)]
    pats ExpQ
    fv ConstructorInfo
    c0 = do
      (pat,patArgs) <- ConstructorInfo -> String -> Q (Pat, [Name])
    conPat ConstructorInfo
    c0 String
    "p"
      exprs <- zipWithM (genTraverseOfType dataArgs pats fv) (varE <$> patArgs) (constructorFields c0)
      let mkRes :: ExpQ -> [(Name, Maybe Exp)] -> ExpQ
          mkRes ExpQ
    e [] = ExpQ
    e
          mkRes ExpQ
    e ((Name
    v,Maybe Exp
    Nothing):[(Name, Maybe Exp)]
    r) =
            ExpQ -> [(Name, Maybe Exp)] -> ExpQ
    mkRes (ExpQ -> ExpQ -> ExpQ
    forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
    appE ExpQ
    e (Name -> ExpQ
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE Name
    v)) [(Name, Maybe Exp)]
    r
          mkRes ExpQ
    e ((Name
    _,Just{}):[(Name, Maybe Exp)]
    r) = do
            v <- String -> Q Name
    forall (m :: * -> *). Quote m => String -> m Name
    newName String
    "r"
            lamE [varP v] (mkRes (appE e (varE v)) r)

      -- Apply the remaining argument to the expression in list.
      let applyRest :: ExpQ -> [Exp] -> ExpQ
          applyRest ExpQ
    e [] = ExpQ
    e
          applyRest ExpQ
    e (Exp
    a:[Exp]
    r) = ExpQ -> [Exp] -> ExpQ
    applyRest [| $(ExpQ
    e) <*> $(Exp -> ExpQ
    forall a. a -> Q a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Exp
    a) |] [Exp]
    r

      -- Apply the first argument to the list
      let applyFirst :: ExpQ -> [Exp] -> ExpQ
          applyFirst ExpQ
    e [] = [| pure $(ExpQ
    e) |]
          applyFirst ExpQ
    e (Exp
    a:[Exp]
    r) = ExpQ -> [Exp] -> ExpQ
    applyRest [| $(ExpQ
    e) <$> $(Exp -> ExpQ
    forall a. a -> Q a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Exp
    a) |] [Exp]
    r

      let pargs = [Name]
    patArgs [Name] -> [Maybe Exp] -> [(Name, Maybe Exp)]
    forall a b. [a] -> [b] -> [(a, b)]
    `zip` [Maybe Exp]
    exprs
      let rhs = ExpQ -> [Exp] -> ExpQ
    applyFirst (ExpQ -> [(Name, Maybe Exp)] -> ExpQ
    mkRes (Exp -> ExpQ
    forall a. a -> Q a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (ConstructorInfo -> Exp
    conExpr ConstructorInfo
    c0)) [(Name, Maybe Exp)]
    pargs) ([Maybe Exp] -> [Exp]
    forall a. [Maybe a] -> [a]
    catMaybes [Maybe Exp]
    exprs)
      match (pure pat) (normalB rhs) []

    -- | @structuralTraversal tp@ generates a function that applies
    -- a traversal @f@ to the subterms with free variables in @tp@.
    structuralTraversal :: TypeQ -> [(TypePat, ExpQ)] -> ExpQ
    structuralTraversal :: TypeQ -> [(TypePat, ExpQ)] -> ExpQ
    structuralTraversal TypeQ
    tpq [(TypePat, ExpQ)]
    pats0 = do
      d <- Name -> Q DatatypeInfo
    reifyDatatype (Name -> Q DatatypeInfo) -> Q Name -> Q DatatypeInfo
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
    =<< String -> Type -> Q Name
    asTypeCon String
    "structuralTraversal" (Type -> Q Name) -> TypeQ -> Q Name
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
    =<< TypeQ
    tpq
      f <- newName "f"
      a <- newName "a"
      lamE [varP f, varP a] $
          caseE (varE a)
          (traverseAppMatch (datatypeInstTypes d) pats0 (varE f) <$> datatypeCons d)

    asTypeCon :: String -> Type -> Q Name
    asTypeCon :: String -> Type -> Q Name
    asTypeCon String
    _ (ConT Name
    nm) = Name -> Q Name
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Name
    nm
    asTypeCon String
    fn Type
    _ = String -> Q Name
    forall a. String -> Q a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String
    fn String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    " expected type constructor.")

    -- | @structuralHash tp@ generates a function with the type
    -- @Int -> tp -> Int@ that hashes type.
    --
    -- All arguments use `hashable`, and `structuralHashWithSalt` can be
    -- used instead as it allows user-definable patterns to be used at
    -- specific types.
    structuralHash :: TypeQ -> ExpQ
    structuralHash :: TypeQ -> ExpQ
    structuralHash TypeQ
    tpq = TypeQ -> [(TypePat, ExpQ)] -> ExpQ
    structuralHashWithSalt TypeQ
    tpq []
    {-# DEPRECATED structuralHash "Use structuralHashWithSalt" #-}

    -- | @structuralHashWithSalt tp@ generates a function with the type
    -- @Int -> tp -> Int@ that hashes type.
    --
    -- The second arguments is for generating user-defined patterns to replace
    -- `hashWithSalt` for specific types.
    structuralHashWithSalt :: TypeQ -> [(TypePat, ExpQ)] -> ExpQ
    structuralHashWithSalt :: TypeQ -> [(TypePat, ExpQ)] -> ExpQ
    structuralHashWithSalt TypeQ
    tpq [(TypePat, ExpQ)]
    pats = do
      d <- Name -> Q DatatypeInfo
    reifyDatatype (Name -> Q DatatypeInfo) -> Q Name -> Q DatatypeInfo
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
    =<< String -> Type -> Q Name
    asTypeCon String
    "structuralHash" (Type -> Q Name) -> TypeQ -> Q Name
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
    =<< TypeQ
    tpq
      s <- newName "s"
      a <- newName "a"
      lamE [varP s, varP a] $
        caseE (varE a) (zipWith (matchHashCtor d pats (varE s)) [0..] (datatypeCons d))

    -- | This matches one of the constructors in a datatype when generating
    -- a `hashWithSalt` function.
    matchHashCtor :: DatatypeInfo
                     -- ^ Data declaration of type we are hashing.
                  -> [(TypePat, ExpQ)]
                     -- ^ User provide type patterns
                  -> ExpQ -- ^ Initial salt expression
                  -> Integer -- ^ Index of constructor
                  -> ConstructorInfo -- ^ Constructor information
                  -> MatchQ
    matchHashCtor :: DatatypeInfo
    -> [(TypePat, ExpQ)]
    -> ExpQ
    -> Integer
    -> ConstructorInfo
    -> Q Match
    matchHashCtor DatatypeInfo
    d [(TypePat, ExpQ)]
    pats ExpQ
    s0 Integer
    i ConstructorInfo
    c = do
      (pat,vars) <- ConstructorInfo -> String -> Q (Pat, [Name])
    conPat ConstructorInfo
    c String
    "x"
      let go ExpQ
    s (ExpQ
    e, Type
    tp) = do
            mr <- [Type] -> [(TypePat, ExpQ)] -> Type -> Q (Maybe ExpQ)
    forall v. [Type] -> [(TypePat, v)] -> Type -> Q (Maybe v)
    assocTypePats (DatatypeInfo -> [Type]
    datatypeInstTypes DatatypeInfo
    d) [(TypePat, ExpQ)]
    pats Type
    tp
            case mr of
              Just ExpQ
    f -> do
                [| $(ExpQ
    f) $(ExpQ
    s) $(ExpQ
    e) |]
              Maybe ExpQ
    Nothing ->
                [| hashWithSalt $(ExpQ
    s) $(ExpQ
    e) |]
      let s1 = [| hashWithSalt $(ExpQ
    s0) ($(Lit -> ExpQ
    forall (m :: * -> *). Quote m => Lit -> m Exp
    litE (Integer -> Lit
    IntegerL Integer
    i)) :: Int) |]
      let rhs = (ExpQ -> (ExpQ, Type) -> ExpQ) -> ExpQ -> [(ExpQ, Type)] -> ExpQ
    forall b a. (b -> a -> b) -> b -> [a] -> b
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl ExpQ -> (ExpQ, Type) -> ExpQ
    go ExpQ
    s1 ([ExpQ] -> [Type] -> [(ExpQ, Type)]
    forall a b. [a] -> [b] -> [(a, b)]
    zip (Name -> ExpQ
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE (Name -> ExpQ) -> [Name] -> [ExpQ]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> [Name]
    vars) (ConstructorInfo -> [Type]
    constructorFields ConstructorInfo
    c))
      match (pure pat) (normalB rhs) []

    -- | @structuralShow tp@ generates a function with the type
    -- @tp -> ShowS@ that shows the constructor.
    structuralShowsPrec :: TypeQ -> ExpQ
    structuralShowsPrec :: TypeQ -> ExpQ
    structuralShowsPrec TypeQ
    tpq = do
      d <- Name -> Q DatatypeInfo
    reifyDatatype (Name -> Q DatatypeInfo) -> Q Name -> Q DatatypeInfo
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
    =<< String -> Type -> Q Name
    asTypeCon String
    "structuralShowPrec" (Type -> Q Name) -> TypeQ -> Q Name
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
    =<< TypeQ
    tpq
      p <- newName "_p"
      a <- newName "a"
      lamE [varP p, varP a] $
        caseE (varE a) (matchShowCtor (varE p) <$> datatypeCons d)

    showCon :: ExpQ -> Name -> Int -> MatchQ
    showCon :: ExpQ -> Name -> Int -> Q Match
    showCon ExpQ
    p Name
    nm Int
    n = do
      vars <- String -> Int -> Q [Name]
    newNames String
    "x" Int
    n
      let pat = Name -> [Pat] -> Pat
    conPCompat Name
    nm (Name -> Pat
    VarP (Name -> Pat) -> [Name] -> [Pat]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> [Name]
    vars)
      let go m Exp
    s Name
    e = [| $(m Exp
    s) . showChar ' ' . showsPrec 11 $(Name -> m Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE Name
    e) |]
      let ctor = [| showString $(Exp -> ExpQ
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Lit -> Exp
    LitE (String -> Lit
    StringL (Name -> String
    nameBase Name
    nm)))) |]
      let rhs | [Name] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [Name]
    vars = ExpQ
    ctor
              | Bool
    otherwise = [| showParen ($(ExpQ
    p) >= 11) $((ExpQ -> Name -> ExpQ) -> ExpQ -> [Name] -> ExpQ
    forall b a. (b -> a -> b) -> b -> [a] -> b
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl ExpQ -> Name -> ExpQ
    forall {m :: * -> *}. Quote m => m Exp -> Name -> m Exp
    go ExpQ
    ctor [Name]
    vars) |]
      match (pure pat) (normalB rhs) []

    matchShowCtor :: ExpQ -> ConstructorInfo -> MatchQ
    matchShowCtor :: ExpQ -> ConstructorInfo -> Q Match
    matchShowCtor ExpQ
    p ConstructorInfo
    con = ExpQ -> Name -> Int -> Q Match
    showCon ExpQ
    p (ConstructorInfo -> Name
    constructorName ConstructorInfo
    con) ([Type] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length (ConstructorInfo -> [Type]
    constructorFields ConstructorInfo
    con))

    -- | Generate a \"repr\" or singleton type from a data kind. For nullary
    -- constructors, this works as follows:
    --
    -- @
    -- data T1 = A | B | C
    -- \$(mkRepr ''T1)
    -- ======>
    -- data T1Repr (tp :: T1)
    --   where
    --     ARepr :: T1Repr 'A
    --     BRepr :: T1Repr 'B
    --     CRepr :: T1Repr 'C
    -- @
    --
    -- For constructors with fields, we assume each field type @T@ already has a
    -- corresponding repr type @TRepr :: T -> *@.
    --
    -- @
    -- data T2 = T2_1 T1 | T2_2 T1
    -- \$(mkRepr ''T2)
    -- ======>
    -- data T2Repr (tp :: T2)
    --   where
    --     T2_1Repr :: T1Repr tp -> T2Repr ('T2_1 tp)
    --     T2_2Repr :: T1Repr tp -> T2Repr ('T2_2 tp)
    -- @
    --
    -- Constructors with multiple fields work fine as well:
    --
    -- @
    -- data T3 = T3 T1 T2
    -- \$(mkRepr ''T3)
    -- ======>
    -- data T3Repr (tp :: T3)
    --   where
    --     T3Repr :: T1Repr tp1 -> T2Repr tp2 -> T3Repr ('T3 tp1 tp2)
    -- @
    --
    -- This is generally compatible with other \"repr\" types provided by
    -- @parameterized-utils@, such as @NatRepr@ and @PeanoRepr@:
    --
    -- @
    -- data T4 = T4_1 Nat | T4_2 Peano
    -- \$(mkRepr ''T4)
    -- ======>
    -- data T4Repr (tp :: T4)
    --   where
    --     T4Repr :: NatRepr tp1 -> PeanoRepr tp2 -> T4Repr ('T4 tp1 tp2)
    -- @
    --
    -- The data kind must be \"simple\", i.e. it must be monomorphic and only
    -- contain user-defined data constructors (no lists, tuples, etc.). For example,
    -- the following will not work:
    --
    -- @
    -- data T5 a = T5 a
    -- \$(mkRepr ''T5)
    -- ======>
    -- Foo.hs:1:1: error:
    --     Exception when trying to run compile-time code:
    --       mkRepr cannot be used on polymorphic data kinds.
    -- @
    --
    -- Similarly, this will not work:
    --
    -- @
    -- data T5 = T5 [Nat]
    -- \$(mkRepr ''T5)
    -- ======>
    -- Foo.hs:1:1: error:
    --     Exception when trying to run compile-time code:
    --       mkRepr cannot be used on this data kind.
    -- @
    --
    -- Note that at a minimum, you will need the following extensions to use this macro:
    --
    -- @
    -- {-\# LANGUAGE DataKinds \#-}
    -- {-\# LANGUAGE GADTs \#-}
    -- {-\# LANGUAGE KindSignatures \#-}
    -- {-\# LANGUAGE TemplateHaskell \#-}
    -- @
    mkRepr :: Name -> DecsQ
    mkRepr :: Name -> DecsQ
    mkRepr Name
    typeName = do
      let reprTypeName :: Name
    reprTypeName = Name -> Name
    mkReprName Name
    typeName
          varName :: Name
    varName = String -> Name
    mkName String
    "tp"
      info <- Name -> Q DatatypeInfo
    lookupDataType' Name
    typeName
      let gc ConstructorInfo
    ci = do
            let ctorName :: Name
    ctorName = ConstructorInfo -> Name
    constructorName ConstructorInfo
    ci
                reprCtorName :: Name
    reprCtorName = Name -> Name
    mkReprName Name
    ctorName
                ctorFieldTypeNames :: [Name]
    ctorFieldTypeNames = Type -> Name
    getCtorName (Type -> Name) -> [Type] -> [Name]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> ConstructorInfo -> [Type]
    constructorFields ConstructorInfo
    ci
                ctorFieldReprNames :: [Name]
    ctorFieldReprNames = Name -> Name
    mkReprName (Name -> Name) -> [Name] -> [Name]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> [Name]
    ctorFieldTypeNames
            -- Generate a list of type variables to be supplied as type arguments
            -- for each repr argument.
            tvars <- Int -> Q Name -> Q [Name]
    forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
    replicateM ([Type] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length (ConstructorInfo -> [Type]
    constructorFields ConstructorInfo
    ci)) (String -> Q Name
    forall (m :: * -> *). Quote m => String -> m Name
    newName String
    "tp")
            let appliedType =
                  (Type -> Type -> Type) -> Type -> [Type] -> Type
    forall b a. (b -> a -> b) -> b -> [a] -> b
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl Type -> Type -> Type
    AppT (Name -> Type
    PromotedT (ConstructorInfo -> Name
    constructorName ConstructorInfo
    ci)) (Name -> Type
    VarT (Name -> Type) -> [Name] -> [Type]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> [Name]
    tvars)
                ctorType = Type -> Type -> Type
    AppT (Name -> Type
    ConT Name
    reprTypeName) Type
    appliedType
                ctorArgTypes =
                  (Name -> Name -> (Bang, Type))
    -> [Name] -> [Name] -> [(Bang, Type)]
    forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
    zipWith (\Name
    n Name
    v -> (SourceUnpackedness -> SourceStrictness -> Bang
    Bang SourceUnpackedness
    NoSourceUnpackedness SourceStrictness
    NoSourceStrictness, Type -> Type -> Type
    AppT (Name -> Type
    ConT Name
    n) (Name -> Type
    VarT Name
    v))) [Name]
    ctorFieldReprNames [Name]
    tvars
            return $ GadtC
              [reprCtorName]
              ctorArgTypes
              ctorType
      ctors <- mapM gc (datatypeCons info)
      return $ [ DataD [] reprTypeName
                 [kindedTV varName (ConT typeName)]
                 Nothing
                 ctors
                 []
               ]
      where getCtorName :: Type -> Name
            getCtorName :: Type -> Name
    getCtorName Type
    c = case Type
    c of
              ConT Name
    nm -> Name
    nm
              VarT Name
    _ -> String -> Name
    forall a. HasCallStack => String -> a
    error (String -> Name) -> String -> Name
    forall a b. (a -> b) -> a -> b
    $ String
    "mkRepr cannot be used on polymorphic data kinds."
              Type
    _ -> String -> Name
    forall a. HasCallStack => String -> a
    error (String -> Name) -> String -> Name
    forall a b. (a -> b) -> a -> b
    $ String
    "mkRepr cannot be used on this data kind."

    -- | Generate @KnownRepr@ instances for each constructor of a data kind. Given a
    -- data kind @T@, we assume a repr type @TRepr (t :: T)@ is in scope with
    -- structure that perfectly matches @T@ (using 'mkRepr' to generate the repr
    -- type will guarantee this).
    --
    -- Given data kinds @T1@, @T2@, and @T3@ from the documentation of 'mkRepr', and
    -- the associated repr types @T1Repr@, @T2Repr@, and @T3Repr@, we can use
    -- 'mkKnownReprs' to generate these instances like so:
    --
    -- @
    -- \$(mkKnownReprs ''T1)
    -- ======>
    -- instance KnownRepr T1Repr 'A where
    --   knownRepr = ARepr
    -- instance KnownRepr T1Repr 'B where
    --   knownRepr = BRepr
    -- instance KnownRepr T1Repr 'C where
    --   knownRepr = CRepr
    -- @
    --
    -- @
    -- \$(mkKnownReprs ''T2)
    -- ======>
    -- instance KnownRepr T1Repr tp =>
    --          KnownRepr T2Repr ('T2_1 tp) where
    --   knownRepr = T2_1Repr knownRepr
    -- @
    --
    -- @
    -- \$(mkKnownReprs ''T3)
    -- ======>
    -- instance (KnownRepr T1Repr tp1, KnownRepr T2Repr tp2) =>
    --          KnownRepr T3Repr ('T3_1 tp1 tp2) where
    --   knownRepr = T3_1Repr knownRepr knownRepr
    -- @
    --
    -- The same restrictions that apply to 'mkRepr' also apply to 'mkKnownReprs'.
    -- The data kind must be \"simple\", i.e. it must be monomorphic and only
    -- contain user-defined data constructors (no lists, tuples, etc.).
    --
    -- Note that at a minimum, you will need the following extensions to use this macro:
    --
    -- @
    -- {-\# LANGUAGE DataKinds \#-}
    -- {-\# LANGUAGE GADTs \#-}
    -- {-\# LANGUAGE KindSignatures \#-}
    -- {-\# LANGUAGE MultiParamTypeClasses \#-}
    -- {-\# LANGUAGE TemplateHaskell \#-}
    -- @
    --
    -- Also, 'mkKnownReprs' must be used in the same module as the definition of
    -- the repr type (not necessarily for the data kind).
    mkKnownReprs :: Name -> DecsQ
    mkKnownReprs :: Name -> DecsQ
    mkKnownReprs Name
    typeName = do
      kr <- [t|KnownRepr|]
      let krFName = String -> Name
    mkName String
    "knownRepr"
          reprTypeName = Name -> Name
    mkReprName Name
    typeName
      typeInfo <- lookupDataType' typeName
      reprInfo <- lookupDataType' reprTypeName
      forM (zip (datatypeCons typeInfo) (datatypeCons reprInfo)) $ \(ConstructorInfo
    tci, ConstructorInfo
    rci) -> do
        vars <- Int -> Q Name -> Q [Name]
    forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
    replicateM ([Type] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length (ConstructorInfo -> [Type]
    constructorFields ConstructorInfo
    tci)) (String -> Q Name
    forall (m :: * -> *). Quote m => String -> m Name
    newName String
    "tp")
        krReqs <- forM (zip (constructorFields tci) vars) $ \(Type
    tfld, Name
    v) -> do
          let fldReprName :: Name
    fldReprName = Name -> Name
    mkReprName (Type -> Name
    getCtorName Type
    tfld)
          Type -> TypeQ
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Type -> TypeQ) -> Type -> TypeQ
    forall a b. (a -> b) -> a -> b
    $ Type -> Type -> Type
    AppT (Type -> Type -> Type
    AppT Type
    kr (Name -> Type
    ConT Name
    fldReprName)) (Name -> Type
    VarT Name
    v)
        let appliedType =
              (Type -> Type -> Type) -> Type -> [Type] -> Type
    forall b a. (b -> a -> b) -> b -> [a] -> b
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl Type -> Type -> Type
    AppT (Name -> Type
    PromotedT (ConstructorInfo -> Name
    constructorName ConstructorInfo
    tci)) (Name -> Type
    VarT (Name -> Type) -> [Name] -> [Type]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> [Name]
    vars)
            krConstraint = Type -> Type -> Type
    AppT (Type -> Type -> Type
    AppT Type
    kr (Name -> Type
    ConT Name
    reprTypeName)) Type
    appliedType
            krExp = (Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
    forall b a. (b -> a -> b) -> b -> [a] -> b
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl Exp -> Exp -> Exp
    AppE (Name -> Exp
    ConE (ConstructorInfo -> Name
    constructorName ConstructorInfo
    rci)) ([Exp] -> Exp) -> [Exp] -> Exp
    forall a b. (a -> b) -> a -> b
    $
              (Name -> Exp) -> [Name] -> [Exp]
    forall a b. (a -> b) -> [a] -> [b]
    map (Exp -> Name -> Exp
    forall a b. a -> b -> a
    const (Name -> Exp
    VarE Name
    krFName)) [Name]
    vars
            krDec = Name -> [Clause] -> Dec
    FunD Name
    krFName [[Pat] -> Body -> [Dec] -> Clause
    Clause [] (Exp -> Body
    NormalB Exp
    krExp) []]

        return $ InstanceD Nothing krReqs krConstraint [krDec]
      where getCtorName :: Type -> Name
            getCtorName :: Type -> Name
    getCtorName Type
    c = case Type
    c of
              ConT Name
    nm -> Name
    nm
              VarT Name
    _ -> String -> Name
    forall a. HasCallStack => String -> a
    error (String -> Name) -> String -> Name
    forall a b. (a -> b) -> a -> b
    $ String
    "mkKnownReprs cannot be used on polymorphic data kinds."
              Type
    _ -> String -> Name
    forall a. HasCallStack => String -> a
    error (String -> Name) -> String -> Name
    forall a b. (a -> b) -> a -> b
    $ String
    "mkKnownReprs cannot be used on this data kind."

    mkReprName :: Name -> Name
    mkReprName :: Name -> Name
    mkReprName Name
    nm = String -> Name
    mkName (Name -> String
    nameBase Name
    nm String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "Repr")

    conPCompat :: Name -> [Pat] -> Pat
    conPCompat :: Name -> [Pat] -> Pat
    conPCompat Name
    n [Pat]
    pats = Name -> [Type] -> [Pat] -> Pat
    ConP Name
    n
    #if MIN_VERSION_template_haskell(2,18,0)
                               []
    #endif
                               [Pat]
    pats

    -- $typePatterns
    --
    -- The Template Haskell instance generators 'structuralEquality',
    -- 'structuralTypeEquality', 'structuralTypeOrd', and 'structuralTraversal'
    -- employ heuristics to generate valid instances in the majority of cases.  Most
    -- failures in the heuristics occur on sub-terms that are type indexed.  To
    -- handle cases where these functions fail to produce a valid instance, they
    -- take a list of exceptions in the form of their second parameter, which has
    -- type @[('TypePat', 'ExpQ')]@.  Each 'TypePat' is a /matcher/ that tells the
    -- TH generator to use the 'ExpQ' to process the matched sub-term.  Consider the
    -- following example:
    --
    -- > data T a b where
    -- >   C1 :: NatRepr n -> T () n
    -- >
    -- > instance TestEquality (T a) where
    -- >   testEquality = $(structuralTypeEquality [t|T|]
    -- >                    [ (ConType [t|NatRepr|] `TypeApp` AnyType, [|testEquality|])
    -- >                    ])
    --
    -- The exception list says that 'structuralTypeEquality' should use
    -- 'testEquality' to compare any sub-terms of type @'NatRepr' n@ in a value of
    -- type @T@.
    --
    -- * 'AnyType' means that the type parameter in that position can be instantiated as any type
    --
    -- * @'DataArg' n@ means that the type parameter in that position is the @n@-th
    --   type parameter of the GADT being traversed (@T@ in the example)
    --
    -- * 'TypeApp' is type application
    --
    -- * 'ConType' specifies a base type
    --
    -- The exception list could have equivalently (and more precisely) have been specified as:
    --
    -- > [(ConType [t|NatRepr|] `TypeApp` DataArg 1, [|testEquality|])]
    --
    -- The use of 'DataArg' says that the type parameter of the 'NatRepr' must
    -- be the same as the second type parameter of @T@.

    -- $reprs
    --
    -- When working with data kinds with run-time representatives, we encourage
    -- users of @parameterized-utils@ to use the following convention. Given a data
    -- kind defined by
    --
    -- @
    -- data T = ...
    -- @
    --
    -- users should also supply a GADT @TRepr@ parameterized by @T@, e.g.
    --
    -- @
    -- data TRepr (t :: T) where ...
    -- @
    --
    -- Each constructor of @TRepr@ should correspond to a constructor of @T@. If @T@
    -- is defined by
    --
    -- @
    -- data T = A | B Nat
    -- @
    --
    -- we have a corresponding
    --
    -- @
    -- data TRepr (t :: T) where
    --   ARepr :: TRepr 'A
    --   BRepr :: NatRepr w -> TRepr ('B w)
    -- @
    --
    -- Assuming the user of @parameterized-utils@ follows this convention, we
    -- provide the Template Haskell construct 'mkRepr' to automate the creation of
    -- the @TRepr@ GADT. We also provide 'mkKnownReprs', which generates 'KnownRepr'
    -- instances for that GADT type. See the documentation for those two functions
    -- for more detailed explanations.
    --
    -- NB: These macros are inspired by the corresponding macros provided by
    -- @singletons-th@, and the \"repr\" programming idiom is very similar to the one
    -- used by @singletons@.