    {-# LANGUAGE CPP #-}
    {-# LANGUAGE FlexibleContexts #-}
    {-# LANGUAGE FlexibleInstances #-}
    {-# LANGUAGE GADTs #-}
    {-# LANGUAGE TemplateHaskell #-}
    {-# LANGUAGE TypeOperators #-}
    {-# LANGUAGE LambdaCase #-}
    {-# LANGUAGE PolyKinds #-}
    module Data.GADT.Compare.TH
        ( DeriveGEQ(..)
        , DeriveGCompare(..)
        , module Data.GADT.Compare.Monad
        ) where

    import Control.Monad
    import Control.Monad.Writer
    import Data.GADT.TH.Internal
    import Data.Functor.Identity
    import Data.GADT.Compare
    import Data.GADT.Compare.Monad
    import Data.Type.Equality ((:~:) (..))
    import qualified Data.Set as Set
    import Data.Set (Set)
    import qualified Data.Map as Map
    import qualified Data.Map.Merge.Lazy as Map
    import Data.Map (Map)
    import Language.Haskell.TH
    import Language.Haskell.TH.Datatype

    -- A type class purely for overloading purposes
    class DeriveGEQ t where
        deriveGEq :: t -> Q [Dec]

    instance DeriveGEQ Name where
      deriveGEq :: Name -> Q [Dec]
    deriveGEq Name
    typeName = do
        typeInfo <- Name -> Q DatatypeInfo
    reifyDatatype Name
    typeName
        let instTypes = DatatypeInfo -> Cxt
    datatypeInstTypes DatatypeInfo
    typeInfo
            paramVars = [Set Name] -> Set Name
    forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
    Set.unions [Type -> Set Name
    freeTypeVariables Type
    t | Type
    t <- Cxt
    instTypes]
            instTypes' = case Cxt -> Cxt
    forall a. [a] -> [a]
    reverse Cxt
    instTypes of
              [] -> String -> Cxt
    forall a. String -> [a]
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail String
    "deriveGEq: Not enough type parameters"
              (Type
    _:Cxt
    xs) -> Cxt -> Cxt
    forall a. [a] -> [a]
    reverse Cxt
    xs
            instanceHead = Type -> Type -> Type
    AppT (Name -> Type
    ConT ''GEq) ((Type -> Type -> Type) -> Type -> Cxt -> 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
    ConT Name
    typeName) Cxt
    instTypes')
        (clauses, cxt) <- runWriterT (mapM (geqClause paramVars) (datatypeCons typeInfo))

        return [InstanceD Nothing cxt instanceHead [geqFunction clauses]]

    instance DeriveGEQ Dec where
        deriveGEq :: Dec -> Q [Dec]
    deriveGEq = Name -> (DatatypeInfo -> WriterT Cxt Q Dec) -> Dec -> Q [Dec]
    deriveForDec ''GEq ((DatatypeInfo -> WriterT Cxt Q Dec) -> Dec -> Q [Dec])
    -> (DatatypeInfo -> WriterT Cxt Q Dec) -> Dec -> Q [Dec]
    forall a b. (a -> b) -> a -> b
    $ \DatatypeInfo
    typeInfo -> do
          let
            instTypes :: Cxt
    instTypes = DatatypeInfo -> Cxt
    datatypeInstTypes DatatypeInfo
    typeInfo
            paramVars :: Set Name
    paramVars = [Set Name] -> Set Name
    forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
    Set.unions [Type -> Set Name
    freeTypeVariables Type
    t | Type
    t <- Cxt
    instTypes]
          clauses <- (ConstructorInfo -> WriterT Cxt Q Clause)
    -> [ConstructorInfo] -> WriterT Cxt Q [Clause]
    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 (Set Name -> ConstructorInfo -> WriterT Cxt Q Clause
    geqClause Set Name
    paramVars) (DatatypeInfo -> [ConstructorInfo]
    datatypeCons DatatypeInfo
    typeInfo)
          return $ geqFunction clauses

    instance DeriveGEQ t => DeriveGEQ [t] where
      deriveGEq :: [t] -> Q [Dec]
    deriveGEq [t
    it] = t -> Q [Dec]
    forall t. DeriveGEQ t => t -> Q [Dec]
    deriveGEq t
    it
      deriveGEq [t]
    _ = String -> Q [Dec]
    forall a. String -> Q a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail String
    "deriveGEq: [] instance only applies to single-element lists"

    instance DeriveGEQ t => DeriveGEQ (Q t) where
      deriveGEq :: Q t -> Q [Dec]
    deriveGEq = (Q t -> (t -> 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
    >>= t -> Q [Dec]
    forall t. DeriveGEQ t => t -> Q [Dec]
    deriveGEq)

    geqFunction :: [Clause] -> Dec
    geqFunction :: [Clause] -> Dec
    geqFunction [Clause]
    clauses = Name -> [Clause] -> Dec
    FunD 'geq ([Clause] -> Dec) -> [Clause] -> Dec
    forall a b. (a -> b) -> a -> b
    $ [Clause]
    clauses [Clause] -> [Clause] -> [Clause]
    forall a. [a] -> [a] -> [a]
    ++ [ [Pat] -> Body -> [Dec] -> Clause
    Clause [Pat
    WildP, Pat
    WildP] (Exp -> Body
    NormalB (Name -> Exp
    ConE 'Nothing)) [] ]
     -- TODO: only include last clause if there's more than one constructor?

    geqClause :: Set Name -> ConstructorInfo -> WriterT Cxt Q Clause
    geqClause :: Set Name -> ConstructorInfo -> WriterT Cxt Q Clause
    geqClause Set Name
    paramVars ConstructorInfo
    con = do
      let conName :: Name
    conName = ConstructorInfo -> Name
    constructorName ConstructorInfo
    con
          argTypes :: Cxt
    argTypes = ConstructorInfo -> Cxt
    constructorFields ConstructorInfo
    con
          conTyVars :: Set Name
    conTyVars = [Name] -> Set Name
    forall a. Ord a => [a] -> Set a
    Set.fromList ((TyVarBndr_ () -> Name) -> [TyVarBndr_ ()] -> [Name]
    forall a b. (a -> b) -> [a] -> [b]
    map TyVarBndr_ () -> Name
    forall flag. TyVarBndr_ flag -> Name
    tvName (ConstructorInfo -> [TyVarBndr_ ()]
    constructorVars ConstructorInfo
    con))
          needsGEq :: Type -> Bool
    needsGEq Type
    argType = Bool -> Bool
    not (Bool -> Bool) -> (Set Name -> Bool) -> Set Name -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Set Name -> Bool
    forall a. Set a -> Bool
    Set.null (Set Name -> Bool) -> Set Name -> Bool
    forall a b. (a -> b) -> a -> b
    $
            Set Name -> Set Name -> Set Name
    forall a. Ord a => Set a -> Set a -> Set a
    Set.intersection (Type -> Set Name
    freeTypeVariables Type
    argType) (Set Name -> Set Name -> Set Name
    forall a. Ord a => Set a -> Set a -> Set a
    Set.union Set Name
    paramVars Set Name
    conTyVars)
      lArgNames <- Cxt -> (Type -> WriterT Cxt Q Name) -> WriterT Cxt Q [Name]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    t a -> (a -> m b) -> m (t b)
    forM Cxt
    argTypes ((Type -> WriterT Cxt Q Name) -> WriterT Cxt Q [Name])
    -> (Type -> WriterT Cxt Q Name) -> WriterT Cxt Q [Name]
    forall a b. (a -> b) -> a -> b
    $ \Type
    _ -> Q Name -> WriterT Cxt Q Name
    forall (m :: * -> *) a. Monad m => m a -> WriterT Cxt m a
    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
    (MonadTrans t, Monad m) =>
    m a -> t m a
    lift (Q Name -> WriterT Cxt Q Name) -> Q Name -> WriterT Cxt Q Name
    forall a b. (a -> b) -> a -> b
    $ String -> Q Name
    forall (m :: * -> *). Quote m => String -> m Name
    newName String
    "x"
      rArgNames <- forM argTypes $ \Type
    _ -> Q Name -> WriterT Cxt Q Name
    forall (m :: * -> *) a. Monad m => m a -> WriterT Cxt m a
    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
    (MonadTrans t, Monad m) =>
    m a -> t m a
    lift (Q Name -> WriterT Cxt Q Name) -> Q Name -> WriterT Cxt Q Name
    forall a b. (a -> b) -> a -> b
    $ String -> Q Name
    forall (m :: * -> *). Quote m => String -> m Name
    newName String
    "y"

      stmts <- forM (zip3 lArgNames rArgNames argTypes) $ \(Name
    l, Name
    r, Type
    t) -> do
        case Type
    t of
          AppT Type
    tyFun Type
    tyArg | Type -> Bool
    needsGEq Type
    t -> do
            u <- Q [Dec] -> WriterT Cxt Q [Dec]
    forall (m :: * -> *) a. Monad m => m a -> WriterT Cxt m a
    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
    (MonadTrans t, Monad m) =>
    m a -> t m a
    lift (Q [Dec] -> WriterT Cxt Q [Dec]) -> Q [Dec] -> WriterT Cxt Q [Dec]
    forall a b. (a -> b) -> a -> b
    $ Set Name -> Name -> Cxt -> Q [Dec]
    reifyInstancesWithRigids Set Name
    paramVars ''GEq [Type
    tyFun]
            case u of
              [] -> Cxt -> WriterT Cxt Q ()
    forall w (m :: * -> *). MonadWriter w m => w -> m ()
    tell [Type -> Type -> Type
    AppT (Name -> Type
    ConT ''GEq) Type
    tyFun]
              [(InstanceD Maybe Overlap
    _ Cxt
    cxt Type
    _ [Dec]
    _)] -> Cxt -> WriterT Cxt Q ()
    forall w (m :: * -> *). MonadWriter w m => w -> m ()
    tell Cxt
    cxt
              [Dec]
    _ -> String -> WriterT Cxt Q ()
    forall a. String -> WriterT Cxt Q a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> WriterT Cxt Q ()) -> String -> WriterT Cxt Q ()
    forall a b. (a -> b) -> a -> b
    $ String
    "More than one instance found for GEq (" 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
    tyFun) String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "), and unsure what to do. Please report this."
            lift $ bindS (conP 'Refl []) [| geq $(varE l) $(varE r) |]
          Type
    _ -> Q Stmt -> WriterT Cxt Q Stmt
    forall (m :: * -> *) a. Monad m => m a -> WriterT Cxt m a
    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
    (MonadTrans t, Monad m) =>
    m a -> t m a
    lift (Q Stmt -> WriterT Cxt Q Stmt) -> Q Stmt -> WriterT Cxt Q Stmt
    forall a b. (a -> b) -> a -> b
    $ Q Exp -> Q Stmt
    forall (m :: * -> *). Quote m => m Exp -> m Stmt
    noBindS [| guard ($(Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE Name
    l) == $(Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE Name
    r)) |]
      ret <- lift $ noBindS [| return Refl |]

      pats <- lift $ sequence
        [ conP conName (map varP lArgNames)
        , conP conName (map varP rArgNames)
        ]
      pure $ Clause pats
        (NormalB (doUnqualifiedE (stmts ++ [ret])))
        []

    class DeriveGCompare t where
        deriveGCompare :: t -> Q [Dec]

    instance DeriveGCompare Name where
        deriveGCompare :: Name -> Q [Dec]
    deriveGCompare Name
    typeName = do
          typeInfo <- Name -> Q DatatypeInfo
    reifyDatatype Name
    typeName
          let instTypes = DatatypeInfo -> Cxt
    datatypeInstTypes DatatypeInfo
    typeInfo
              paramVars = [Set Name] -> Set Name
    forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
    Set.unions [Type -> Set Name
    freeTypeVariables Type
    t | Type
    t <- Cxt
    instTypes]
              instTypes' = case Cxt -> Cxt
    forall a. [a] -> [a]
    reverse Cxt
    instTypes of
                [] -> String -> Cxt
    forall a. String -> [a]
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail String
    "deriveGCompare: Not enough type parameters"
                (Type
    _:Cxt
    xs) -> Cxt -> Cxt
    forall a. [a] -> [a]
    reverse Cxt
    xs
              instanceHead = Type -> Type -> Type
    AppT (Name -> Type
    ConT ''GCompare) ((Type -> Type -> Type) -> Type -> Cxt -> 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
    ConT Name
    typeName) Cxt
    instTypes')
          (clauses, cxt) <- runWriterT (fmap concat $ mapM (gcompareClauses paramVars) (datatypeCons typeInfo))
          dec <- gcompareFunction clauses
          return [InstanceD Nothing cxt instanceHead [dec]]

    instance DeriveGCompare Dec where
        deriveGCompare :: Dec -> Q [Dec]
    deriveGCompare = Name -> (DatatypeInfo -> WriterT Cxt Q Dec) -> Dec -> Q [Dec]
    deriveForDec ''GCompare ((DatatypeInfo -> WriterT Cxt Q Dec) -> Dec -> Q [Dec])
    -> (DatatypeInfo -> WriterT Cxt Q Dec) -> Dec -> Q [Dec]
    forall a b. (a -> b) -> a -> b
    $ \DatatypeInfo
    typeInfo -> do
          let
            instTypes :: Cxt
    instTypes = DatatypeInfo -> Cxt
    datatypeInstTypes DatatypeInfo
    typeInfo
            paramVars :: Set Name
    paramVars = [Set Name] -> Set Name
    forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
    Set.unions [Type -> Set Name
    freeTypeVariables Type
    t | Type
    t <- Cxt
    instTypes]
          clauses <- (ConstructorInfo -> WriterT Cxt Q [Clause])
    -> [ConstructorInfo] -> WriterT Cxt Q [[Clause]]
    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 (Set Name -> ConstructorInfo -> WriterT Cxt Q [Clause]
    gcompareClauses Set Name
    paramVars) (DatatypeInfo -> [ConstructorInfo]
    datatypeCons DatatypeInfo
    typeInfo)
          lift $ gcompareFunction (concat clauses)

    instance DeriveGCompare t => DeriveGCompare [t] where
        deriveGCompare :: [t] -> Q [Dec]
    deriveGCompare [t
    it] = t -> Q [Dec]
    forall t. DeriveGCompare t => t -> Q [Dec]
    deriveGCompare t
    it
        deriveGCompare [t]
    _ = String -> Q [Dec]
    forall a. String -> Q a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail String
    "deriveGCompare: [] instance only applies to single-element lists"

    instance DeriveGCompare t => DeriveGCompare (Q t) where
        deriveGCompare :: Q t -> Q [Dec]
    deriveGCompare = (Q t -> (t -> 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
    >>= t -> Q [Dec]
    forall t. DeriveGCompare t => t -> Q [Dec]
    deriveGCompare)

    gcompareFunction :: [Clause] -> Q Dec
    gcompareFunction :: [Clause] -> Q Dec
    gcompareFunction [] = Name -> [Q Clause] -> Q Dec
    forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
    funD 'gcompare [[Q Pat] -> Q Body -> [Q Dec] -> Q Clause
    forall (m :: * -> *).
    Quote m =>
    [m Pat] -> m Body -> [m Dec] -> m Clause
    clause [] (Q Exp -> Q Body
    forall (m :: * -> *). Quote m => m Exp -> m Body
    normalB [| \x y -> seq x (seq y undefined) |]) []]
    gcompareFunction [Clause]
    clauses = Dec -> Q Dec
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Dec -> Q Dec) -> Dec -> Q Dec
    forall a b. (a -> b) -> a -> b
    $ Name -> [Clause] -> Dec
    FunD 'gcompare [Clause]
    clauses

    gcompareClauses :: Set Name -> ConstructorInfo -> WriterT Cxt Q [Clause]
    gcompareClauses :: Set Name -> ConstructorInfo -> WriterT Cxt Q [Clause]
    gcompareClauses Set Name
    paramVars ConstructorInfo
    con = do
      let conName :: Name
    conName = ConstructorInfo -> Name
    constructorName ConstructorInfo
    con
          argTypes :: Cxt
    argTypes = ConstructorInfo -> Cxt
    constructorFields ConstructorInfo
    con
          conTyVars :: Set Name
    conTyVars = [Name] -> Set Name
    forall a. Ord a => [a] -> Set a
    Set.fromList ((TyVarBndr_ () -> Name) -> [TyVarBndr_ ()] -> [Name]
    forall a b. (a -> b) -> [a] -> [b]
    map TyVarBndr_ () -> Name
    forall flag. TyVarBndr_ flag -> Name
    tvName (ConstructorInfo -> [TyVarBndr_ ()]
    constructorVars ConstructorInfo
    con))
          needsGCompare :: Type -> Bool
    needsGCompare Type
    argType = Bool -> Bool
    not (Bool -> Bool) -> (Set Name -> Bool) -> Set Name -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Set Name -> Bool
    forall a. Set a -> Bool
    Set.null (Set Name -> Bool) -> Set Name -> Bool
    forall a b. (a -> b) -> a -> b
    $
            Set Name -> Set Name -> Set Name
    forall a. Ord a => Set a -> Set a -> Set a
    Set.intersection (Type -> Set Name
    freeTypeVariables Type
    argType) (Set Name -> Set Name -> Set Name
    forall a. Ord a => Set a -> Set a -> Set a
    Set.union Set Name
    paramVars Set Name
    conTyVars)

      lArgNames <- Cxt -> (Type -> WriterT Cxt Q Name) -> WriterT Cxt Q [Name]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    t a -> (a -> m b) -> m (t b)
    forM Cxt
    argTypes ((Type -> WriterT Cxt Q Name) -> WriterT Cxt Q [Name])
    -> (Type -> WriterT Cxt Q Name) -> WriterT Cxt Q [Name]
    forall a b. (a -> b) -> a -> b
    $ \Type
    _ -> Q Name -> WriterT Cxt Q Name
    forall (m :: * -> *) a. Monad m => m a -> WriterT Cxt m a
    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
    (MonadTrans t, Monad m) =>
    m a -> t m a
    lift (Q Name -> WriterT Cxt Q Name) -> Q Name -> WriterT Cxt Q Name
    forall a b. (a -> b) -> a -> b
    $ String -> Q Name
    forall (m :: * -> *). Quote m => String -> m Name
    newName String
    "x"
      rArgNames <- forM argTypes $ \Type
    _ -> Q Name -> WriterT Cxt Q Name
    forall (m :: * -> *) a. Monad m => m a -> WriterT Cxt m a
    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
    (MonadTrans t, Monad m) =>
    m a -> t m a
    lift (Q Name -> WriterT Cxt Q Name) -> Q Name -> WriterT Cxt Q Name
    forall a b. (a -> b) -> a -> b
    $ String -> Q Name
    forall (m :: * -> *). Quote m => String -> m Name
    newName String
    "y"

      stmts <- forM (zip3 lArgNames rArgNames argTypes) $ \(Name
    lArg, Name
    rArg, Type
    argType) ->
        case Type
    argType of
          AppT Type
    tyFun Type
    tyArg | Type -> Bool
    needsGCompare Type
    argType -> do
            u <- Q [Dec] -> WriterT Cxt Q [Dec]
    forall (m :: * -> *) a. Monad m => m a -> WriterT Cxt m a
    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
    (MonadTrans t, Monad m) =>
    m a -> t m a
    lift (Q [Dec] -> WriterT Cxt Q [Dec]) -> Q [Dec] -> WriterT Cxt Q [Dec]
    forall a b. (a -> b) -> a -> b
    $ Set Name -> Name -> Cxt -> Q [Dec]
    reifyInstancesWithRigids Set Name
    paramVars ''GCompare [Type
    tyFun]
            case u of
              [] -> Cxt -> WriterT Cxt Q ()
    forall w (m :: * -> *). MonadWriter w m => w -> m ()
    tell [Type -> Type -> Type
    AppT (Name -> Type
    ConT ''GCompare) Type
    tyFun]
              [(InstanceD Maybe Overlap
    _ Cxt
    cxt Type
    _ [Dec]
    _)] -> Cxt -> WriterT Cxt Q ()
    forall w (m :: * -> *). MonadWriter w m => w -> m ()
    tell Cxt
    cxt -- this might not be enough, may want to do full instance resolution.
              [Dec]
    _ -> String -> WriterT Cxt Q ()
    forall a. String -> WriterT Cxt Q a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> WriterT Cxt Q ()) -> String -> WriterT Cxt Q ()
    forall a b. (a -> b) -> a -> b
    $ String
    "More than one instance of GCompare (" 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
    tyFun) String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    ") found, and unsure what to do. Please report this."
            lift $ bindS (conP 'Refl []) [| geq' $(varE lArg) $(varE rArg) |]
          Type
    _ -> Q Stmt -> WriterT Cxt Q Stmt
    forall (m :: * -> *) a. Monad m => m a -> WriterT Cxt m a
    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
    (MonadTrans t, Monad m) =>
    m a -> t m a
    lift (Q Stmt -> WriterT Cxt Q Stmt) -> Q Stmt -> WriterT Cxt Q Stmt
    forall a b. (a -> b) -> a -> b
    $ Q Exp -> Q Stmt
    forall (m :: * -> *). Quote m => m Exp -> m Stmt
    noBindS [| compare' $(Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE Name
    lArg) $(Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE Name
    rArg) |]

      ret <- lift $ noBindS [| return GEQ |]

      pats <- lift $ sequence
            [ conP conName (map varP lArgNames)
            , conP conName (map varP rArgNames)
            ]
      let main = [Pat] -> Body -> [Dec] -> Clause
    Clause [Pat]
    pats
            (Exp -> Body
    NormalB (Exp -> Exp -> Exp
    AppE (Name -> Exp
    VarE 'runGComparing) ([Stmt] -> Exp
    doUnqualifiedE ([Stmt]
    stmts [Stmt] -> [Stmt] -> [Stmt]
    forall a. [a] -> [a] -> [a]
    ++ [Stmt
    ret]))))
            []
          lt = [Pat] -> Body -> [Dec] -> Clause
    Clause [Name -> [FieldPat] -> Pat
    RecP Name
    conName [], Pat
    WildP] (Exp -> Body
    NormalB (Name -> Exp
    ConE 'GLT)) []
          gt = [Pat] -> Body -> [Dec] -> Clause
    Clause [Pat
    WildP, Name -> [FieldPat] -> Pat
    RecP Name
    conName []] (Exp -> Body
    NormalB (Name -> Exp
    ConE 'GGT)) []
      return [main, lt, gt]

    #if MIN_VERSION_template_haskell(2,17,0)
    doUnqualifiedE :: [Stmt] -> Exp
    doUnqualifiedE = Maybe ModName -> [Stmt] -> Exp
    DoE Maybe ModName
    forall a. Maybe a
    Nothing
    #else
    doUnqualifiedE = DoE
    #endif