    {-# LANGUAGE CPP #-}
    {-# LANGUAGE TupleSections #-}

    #if __GLASGOW_HASKELL__ >= 800
    {-# LANGUAGE TemplateHaskellQuotes #-}
    #endif

    {-|
    Module:      Data.Deriving.Via.Internal
    Copyright:   (C) 2015-2017 Ryan Scott
    License:     BSD-style (see the file LICENSE)
    Maintainer:  Ryan Scott
    Portability: Template Haskell

    On @template-haskell-2.12@ or later (i.e., GHC 8.2 or later), this module
    exports functionality which emulates the @GeneralizedNewtypeDeriving@ and
    @DerivingVia@ GHC extensions (the latter of which was introduced in GHC 8.6).

    On older versions of @template-haskell@/GHC, this module does not export
    anything.

    Note: this is an internal module, and as such, the API presented here is not
    guaranteed to be stable, even between minor releases of this library.
    -}
    module Data.Deriving.Via.Internal where

    #if MIN_VERSION_template_haskell(2,12,0)
    import           Control.Monad ((<=<), unless)

    import           Data.Deriving.Internal
    import qualified Data.List as L
    import qualified Data.Map as M
    import           Data.Map (Map)
    import           Data.Maybe (catMaybes)

    import           GHC.Exts (Any)

    import           Language.Haskell.TH
    import           Language.Haskell.TH.Datatype
    import           Language.Haskell.TH.Datatype.TyVarBndr

    -------------------------------------------------------------------------------
    -- Code generation
    -------------------------------------------------------------------------------

    {- | Generates an instance for a type class at a newtype by emulating the
    behavior of the @GeneralizedNewtypeDeriving@ extension. For example:

    @
    newtype Foo a = MkFoo a
    $('deriveGND' [t| forall a. 'Eq' a => 'Eq' (Foo a) |])
    @
    -}
    deriveGND :: Q Type -> Q [Dec]
    deriveGND :: Q Type -> Q [Dec]
    deriveGND Q Type
    qty = do
      Type
    ty <- Q Type
    qty
      let ([TyVarBndrSpec]
    _instanceTvbs, Cxt
    instanceCxt, Type
    instanceTy) = Type -> ([TyVarBndrSpec], Cxt, Type)
    decomposeType Type
    ty
      Type
    instanceTy' <- (Type -> Q Type
    resolveTypeSynonyms (Type -> Q Type) -> (Type -> Q Type) -> Type -> Q Type
    forall (m :: * -> *) b c a.
    Monad m =>
    (b -> m c) -> (a -> m b) -> a -> m c
    <=< Type -> Q Type
    resolveInfixT) Type
    instanceTy
      [Dec]
    decs <- Type -> Maybe Type -> Q [Dec]
    deriveViaDecs Type
    instanceTy' Maybe Type
    forall a. Maybe a
    Nothing
      (Dec -> [Dec] -> [Dec]
    forall a. a -> [a] -> [a]
    :[]) (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` Q Cxt -> Q Type -> [Q Dec] -> Q Dec
    forall (m :: * -> *).
    Quote m =>
    m Cxt -> m Type -> [m Dec] -> m Dec
    instanceD (Cxt -> Q Cxt
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Cxt
    instanceCxt)
                             (Type -> Q Type
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Type
    instanceTy)
                             ((Dec -> Q Dec) -> [Dec] -> [Q Dec]
    forall a b. (a -> b) -> [a] -> [b]
    map Dec -> Q Dec
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return [Dec]
    decs)

    {- | Generates an instance for a type class by emulating the behavior of the
    @DerivingVia@ extension. For example:

    @
    newtype Foo a = MkFoo a
    $('deriveVia' [t| forall a. 'Ord' a => 'Ord' (Foo a) ``Via`` Down a |])
    @

    As shown in the example above, the syntax is a tad strange. One must specify
    the type by which to derive the instance using the 'Via' type. This
    requirement is in place to ensure that the type variables are scoped
    correctly across all the types being used (e.g., to make sure that the same
    @a@ is used in @'Ord' a@, @'Ord' (Foo a)@, and @Down a@).
    -}
    deriveVia :: Q Type -> Q [Dec]
    deriveVia :: Q Type -> Q [Dec]
    deriveVia Q Type
    qty = do
      Type
    ty <- Q Type
    qty
      let ([TyVarBndrSpec]
    _instanceTvbs, Cxt
    instanceCxt, Type
    viaApp) = Type -> ([TyVarBndrSpec], Cxt, Type)
    decomposeType Type
    ty
      Type
    viaApp' <- (Type -> Q Type
    resolveTypeSynonyms (Type -> Q Type) -> (Type -> Q Type) -> Type -> Q Type
    forall (m :: * -> *) b c a.
    Monad m =>
    (b -> m c) -> (a -> m b) -> a -> m c
    <=< Type -> Q Type
    resolveInfixT) Type
    viaApp
      (Type
    instanceTy, Type
    viaTy)
        <- case Type -> (Type, Cxt)
    unapplyTy Type
    viaApp' of
             (Type
    via, [Type
    instanceTy,Type
    viaTy])
               | Type
    via Type -> Type -> Bool
    forall a. Eq a => a -> a -> Bool
    == Name -> Type
    ConT Name
    viaTypeName
              -> (Type, Type) -> Q (Type, Type)
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Type
    instanceTy, Type
    viaTy)
             (Type, Cxt)
    _ -> String -> Q (Type, Type)
    forall a. String -> Q a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> Q (Type, Type)) -> String -> Q (Type, Type)
    forall a b. (a -> b) -> a -> b
    $ [String] -> String
    unlines
                    [ String
    "Failure to meet ‘deriveVia‘ specification"
                    , String
    "\tThe ‘Via‘ type must be used, e.g."
                    , String
    "\t[t| forall a. C (T a) `Via` V a |]"
                    ]
      -- This is a stronger requirement than what GHC's implementation of
      -- DerivingVia imposes, but due to Template Haskell restrictions, we
      -- currently can't do better. See #27.
      let viaTyFVs :: [Name]
    viaTyFVs           = Type -> [Name]
    forall a. TypeSubstitution a => a -> [Name]
    freeVariables Type
    viaTy
          otherFVs :: [Name]
    otherFVs           = [[Name]] -> [Name]
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat [Cxt -> [Name]
    forall a. TypeSubstitution a => a -> [Name]
    freeVariables Cxt
    instanceCxt, Type -> [Name]
    forall a. TypeSubstitution a => a -> [Name]
    freeVariables Type
    instanceTy]
          floatingViaTyFVs :: [Name]
    floatingViaTyFVs   = [Name]
    viaTyFVs [Name] -> [Name] -> [Name]
    forall a. Eq a => [a] -> [a] -> [a]
    L.\\ [Name]
    otherFVs
          floatingViaTySubst :: Map Name Type
    floatingViaTySubst = [(Name, Type)] -> Map Name Type
    forall k a. Ord k => [(k, a)] -> Map k a
    M.fromList ([(Name, Type)] -> Map Name Type)
    -> [(Name, Type)] -> Map Name Type
    forall a b. (a -> b) -> a -> b
    $ (Name -> (Name, Type)) -> [Name] -> [(Name, Type)]
    forall a b. (a -> b) -> [a] -> [b]
    map (, Name -> Type
    ConT ''Any) [Name]
    floatingViaTyFVs
          viaTy' :: Type
    viaTy'             = Map Name Type -> Type -> Type
    forall a. TypeSubstitution a => Map Name Type -> a -> a
    applySubstitution Map Name Type
    floatingViaTySubst Type
    viaTy
      [Dec]
    decs <- Type -> Maybe Type -> Q [Dec]
    deriveViaDecs Type
    instanceTy (Type -> Maybe Type
    forall a. a -> Maybe a
    Just Type
    viaTy')
      (Dec -> [Dec] -> [Dec]
    forall a. a -> [a] -> [a]
    :[]) (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` Q Cxt -> Q Type -> [Q Dec] -> Q Dec
    forall (m :: * -> *).
    Quote m =>
    m Cxt -> m Type -> [m Dec] -> m Dec
    instanceD (Cxt -> Q Cxt
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Cxt
    instanceCxt)
                             (Type -> Q Type
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Type
    instanceTy)
                             ((Dec -> Q Dec) -> [Dec] -> [Q Dec]
    forall a b. (a -> b) -> [a] -> [b]
    map Dec -> Q Dec
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return [Dec]
    decs)

    deriveViaDecs :: Type       -- ^ The instance head (e.g., @Eq (Foo a)@)
                  -> Maybe Type -- ^ If using 'deriveGND', this is 'Nothing.
                                --   If using 'deriveVia', this is 'Just' the @via@ type.
                  -> Q [Dec]
    deriveViaDecs :: Type -> Maybe Type -> Q [Dec]
    deriveViaDecs Type
    instanceTy Maybe Type
    mbViaTy = do
      let (Type
    clsTy, Cxt
    clsArgs) = Type -> (Type, Cxt)
    unapplyTy Type
    instanceTy
      case Type
    clsTy of
        ConT Name
    clsName -> do
          Info
    clsInfo <- Name -> Q Info
    reify Name
    clsName
          case Info
    clsInfo of
            ClassI (ClassD Cxt
    _ Name
    _ [TyVarBndr ()]
    clsTvbs [FunDep]
    _ [Dec]
    clsDecs) [Dec]
    _ ->
              case (Cxt -> Maybe (Cxt, Type)
    forall a. [a] -> Maybe ([a], a)
    unsnoc Cxt
    clsArgs, [TyVarBndr ()] -> Maybe ([TyVarBndr ()], TyVarBndr ())
    forall a. [a] -> Maybe ([a], a)
    unsnoc [TyVarBndr ()]
    clsTvbs) of
                (Just (Cxt
    _, Type
    dataApp), Just ([TyVarBndr ()]
    _, TyVarBndr ()
    clsLastTvb)) -> do
                  let (Type
    dataTy, Cxt
    dataArgs) = Type -> (Type, Cxt)
    unapplyTy Type
    dataApp
                      clsLastTvbKind :: Type
    clsLastTvbKind     = TyVarBndr () -> Type
    forall flag. TyVarBndr_ flag -> Type
    tvbKind TyVarBndr ()
    clsLastTvb
                      (Cxt
    _, Cxt
    kindList)      = Type -> (Cxt, Cxt)
    uncurryTy Type
    clsLastTvbKind
                      numArgsToEtaReduce :: Int
    numArgsToEtaReduce = Cxt -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length Cxt
    kindList Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    1
                  Type
    repTy <-
                    case Maybe Type
    mbViaTy of
                      Just Type
    viaTy -> Type -> Q Type
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Type
    viaTy
                      Maybe Type
    Nothing ->
                        case Type
    dataTy of
                          ConT Name
    dataName -> do
                            DatatypeInfo {
                                           datatypeInstTypes :: DatatypeInfo -> Cxt
    datatypeInstTypes = Cxt
    dataInstTypes
                                         , datatypeVariant :: DatatypeInfo -> DatatypeVariant
    datatypeVariant   = DatatypeVariant
    dv
                                         , datatypeCons :: DatatypeInfo -> [ConstructorInfo]
    datatypeCons      = [ConstructorInfo]
    cons
                                         } <- Name -> Q DatatypeInfo
    reifyDatatype Name
    dataName
                            case DatatypeVariant -> [ConstructorInfo] -> Maybe Type
    newtypeRepType DatatypeVariant
    dv [ConstructorInfo]
    cons of
                              Just Type
    newtypeRepTy ->
                                case Int -> Type -> Maybe Type
    etaReduce Int
    numArgsToEtaReduce Type
    newtypeRepTy of
                                  Just Type
    etaRepTy ->
                                    let repTySubst :: Map Name Type
    repTySubst =
                                          [(Name, Type)] -> Map Name Type
    forall k a. Ord k => [(k, a)] -> Map k a
    M.fromList ([(Name, Type)] -> Map Name Type)
    -> [(Name, Type)] -> Map Name Type
    forall a b. (a -> b) -> a -> b
    $
                                          (Type -> Type -> (Name, Type)) -> Cxt -> Cxt -> [(Name, Type)]
    forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
    zipWith (\Type
    var Type
    arg -> (Type -> Name
    varTToName Type
    var, Type
    arg))
                                                  Cxt
    dataInstTypes Cxt
    dataArgs
                                    in Type -> Q Type
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Type -> Q Type) -> Type -> Q Type
    forall a b. (a -> b) -> a -> b
    $ Map Name Type -> Type -> Type
    forall a. TypeSubstitution a => Map Name Type -> a -> a
    applySubstitution Map Name Type
    repTySubst Type
    etaRepTy
                                  Maybe Type
    Nothing -> Type -> Q Type
    forall a. Type -> Q a
    etaReductionError Type
    instanceTy
                              Maybe Type
    Nothing -> String -> Q Type
    forall a. String -> Q a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> Q Type) -> String -> Q Type
    forall a b. (a -> b) -> a -> b
    $ String
    "Not a newtype: " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Name -> String
    nameBase Name
    dataName
                          Type
    _ -> String -> Q Type
    forall a. String -> Q a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> Q Type) -> String -> Q Type
    forall a b. (a -> b) -> a -> b
    $ String
    "Not a data type: " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Type -> String
    forall a. Ppr a => a -> String
    pprint Type
    dataTy
                  [[Dec]] -> [Dec]
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat ([[Dec]] -> [Dec])
    -> ([Maybe [Dec]] -> [[Dec]]) -> [Maybe [Dec]] -> [Dec]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [Maybe [Dec]] -> [[Dec]]
    forall a. [Maybe a] -> [a]
    catMaybes ([Maybe [Dec]] -> [Dec]) -> Q [Maybe [Dec]] -> Q [Dec]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> (Dec -> Q (Maybe [Dec])) -> [Dec] -> Q [Maybe [Dec]]
    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 (Name -> [TyVarBndr ()] -> Cxt -> Type -> Dec -> Q (Maybe [Dec])
    forall flag.
    Name -> [TyVarBndr_ flag] -> Cxt -> Type -> Dec -> Q (Maybe [Dec])
    deriveViaDecs' Name
    clsName [TyVarBndr ()]
    clsTvbs Cxt
    clsArgs Type
    repTy) [Dec]
    clsDecs
                (Maybe (Cxt, Type)
    _, Maybe ([TyVarBndr ()], TyVarBndr ())
    _) -> 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
    $ String
    "Cannot derive instance for nullary class " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Type -> String
    forall a. Ppr a => a -> String
    pprint Type
    clsTy
            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
    $ String
    "Not a type class: " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Type -> String
    forall a. Ppr a => a -> String
    pprint Type
    clsTy
        Type
    _ -> 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
    $ String
    "Malformed instance: " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Type -> String
    forall a. Ppr a => a -> String
    pprint Type
    instanceTy

    deriveViaDecs' :: Name -> [TyVarBndr_ flag] -> [Type] -> Type -> Dec -> Q (Maybe [Dec])
    deriveViaDecs' :: forall flag.
    Name -> [TyVarBndr_ flag] -> Cxt -> Type -> Dec -> Q (Maybe [Dec])
    deriveViaDecs' Name
    clsName [TyVarBndr_ flag]
    clsTvbs Cxt
    clsArgs Type
    repTy Dec
    dec = do
        let numExpectedArgs :: Int
    numExpectedArgs = [TyVarBndr_ flag] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [TyVarBndr_ flag]
    clsTvbs
            numActualArgs :: Int
    numActualArgs   = Cxt -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length Cxt
    clsArgs
        Bool -> Q () -> Q ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    unless (Int
    numExpectedArgs Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    == Int
    numActualArgs) (Q () -> Q ()) -> Q () -> Q ()
    forall a b. (a -> b) -> a -> b
    $
          String -> Q ()
    forall a. String -> Q a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> Q ()) -> String -> Q ()
    forall a b. (a -> b) -> a -> b
    $ String
    "Mismatched number of class arguments"
              String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "\n\tThe class " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Name -> String
    nameBase Name
    clsName String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    " expects " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Int -> String
    forall a. Show a => a -> String
    show Int
    numExpectedArgs String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    " argument(s),"
              String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "\n\tbut was provided " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Int -> String
    forall a. Show a => a -> String
    show Int
    numActualArgs String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    " argument(s)."
        Dec -> Q (Maybe [Dec])
    go Dec
    dec
      where
        go :: Dec -> Q (Maybe [Dec])

        go :: Dec -> Q (Maybe [Dec])
    go (OpenTypeFamilyD (TypeFamilyHead Name
    tfName [TyVarBndr ()]
    tfTvbs FamilyResultSig
    _ Maybe InjectivityAnn
    _)) = do
          let lhsSubst :: Map Name Type
    lhsSubst = [TyVarBndr_ flag] -> Cxt -> Map Name Type
    forall flag. [TyVarBndr_ flag] -> Cxt -> Map Name Type
    zipTvbSubst [TyVarBndr_ flag]
    clsTvbs Cxt
    clsArgs
              rhsSubst :: Map Name Type
    rhsSubst = [TyVarBndr_ flag] -> Cxt -> Map Name Type
    forall flag. [TyVarBndr_ flag] -> Cxt -> Map Name Type
    zipTvbSubst [TyVarBndr_ flag]
    clsTvbs (Cxt -> Map Name Type) -> Cxt -> Map Name Type
    forall a b. (a -> b) -> a -> b
    $ Cxt -> Type -> Cxt
    forall a. [a] -> a -> [a]
    changeLast Cxt
    clsArgs Type
    repTy
              tfTvbTys :: Cxt
    tfTvbTys = (TyVarBndr () -> Type) -> [TyVarBndr ()] -> Cxt
    forall a b. (a -> b) -> [a] -> [b]
    map TyVarBndr () -> Type
    forall flag. TyVarBndr_ flag -> Type
    tvbToType [TyVarBndr ()]
    tfTvbs
              tfLHSTys :: Cxt
    tfLHSTys = (Type -> Type) -> Cxt -> Cxt
    forall a b. (a -> b) -> [a] -> [b]
    map (Map Name Type -> Type -> Type
    forall a. TypeSubstitution a => Map Name Type -> a -> a
    applySubstitution Map Name Type
    lhsSubst) Cxt
    tfTvbTys
              tfRHSTys :: Cxt
    tfRHSTys = (Type -> Type) -> Cxt -> Cxt
    forall a b. (a -> b) -> [a] -> [b]
    map (Map Name Type -> Type -> Type
    forall a. TypeSubstitution a => Map Name Type -> a -> a
    applySubstitution Map Name Type
    rhsSubst) Cxt
    tfTvbTys
              tfRHSTy :: Type
    tfRHSTy  = Type -> Cxt -> Type
    applyTy (Name -> Type
    ConT Name
    tfName) Cxt
    tfRHSTys
          Dec
    tfInst <- Name -> Maybe [Q (TyVarBndr ())] -> [Q Type] -> Q Type -> Q Dec
    tySynInstDCompat Name
    tfName Maybe [Q (TyVarBndr ())]
    forall a. Maybe a
    Nothing
                                     ((Type -> Q Type) -> Cxt -> [Q Type]
    forall a b. (a -> b) -> [a] -> [b]
    map Type -> Q Type
    forall a. a -> Q a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Cxt
    tfLHSTys) (Type -> Q Type
    forall a. a -> Q a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Type
    tfRHSTy)
          Maybe [Dec] -> Q (Maybe [Dec])
    forall a. a -> Q a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure ([Dec] -> Maybe [Dec]
    forall a. a -> Maybe a
    Just [Dec
    tfInst])

        go (SigD Name
    methName Type
    methTy) =
          let (Type
    fromTy, Type
    toTy) = [TyVarBndr_ flag] -> Cxt -> Type -> Type -> (Type, Type)
    forall flag.
    [TyVarBndr_ flag] -> Cxt -> Type -> Type -> (Type, Type)
    mkCoerceClassMethEqn [TyVarBndr_ flag]
    clsTvbs Cxt
    clsArgs Type
    repTy (Type -> (Type, Type)) -> Type -> (Type, Type)
    forall a b. (a -> b) -> a -> b
    $
                               Type -> Type
    stripOuterForallT Type
    methTy
              fromTau :: Type
    fromTau = Type -> Type
    stripOuterForallT Type
    fromTy
              toTau :: Type
    toTau   = Type -> Type
    stripOuterForallT Type
    toTy
              rhsExpr :: Exp
    rhsExpr = Name -> Exp
    VarE Name
    coerceValName Exp -> Type -> Exp
    `AppTypeE` Type
    fromTau
                                           Exp -> Type -> Exp
    `AppTypeE` Type
    toTau
                                           Exp -> Exp -> Exp
    `AppE`     Name -> Exp
    VarE Name
    methName
              sig :: Dec
    sig  = Name -> Type -> Dec
    SigD Name
    methName Type
    toTy
              meth :: Dec
    meth = Pat -> Body -> [Dec] -> Dec
    ValD (Name -> Pat
    VarP Name
    methName)
                          (Exp -> Body
    NormalB Exp
    rhsExpr)
                          []
          in Maybe [Dec] -> Q (Maybe [Dec])
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([Dec] -> Maybe [Dec]
    forall a. a -> Maybe a
    Just [Dec
    sig, Dec
    meth])

        go Dec
    _ = Maybe [Dec] -> Q (Maybe [Dec])
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Maybe [Dec]
    forall a. Maybe a
    Nothing

    mkCoerceClassMethEqn :: [TyVarBndr_ flag] -> [Type] -> Type -> Type -> (Type, Type)
    mkCoerceClassMethEqn :: forall flag.
    [TyVarBndr_ flag] -> Cxt -> Type -> Type -> (Type, Type)
    mkCoerceClassMethEqn [TyVarBndr_ flag]
    clsTvbs Cxt
    clsArgs Type
    repTy Type
    methTy
      = ( Map Name Type -> Type -> Type
    forall a. TypeSubstitution a => Map Name Type -> a -> a
    applySubstitution Map Name Type
    rhsSubst Type
    methTy
        , Map Name Type -> Type -> Type
    forall a. TypeSubstitution a => Map Name Type -> a -> a
    applySubstitution Map Name Type
    lhsSubst Type
    methTy
        )
      where
        lhsSubst :: Map Name Type
    lhsSubst = [TyVarBndr_ flag] -> Cxt -> Map Name Type
    forall flag. [TyVarBndr_ flag] -> Cxt -> Map Name Type
    zipTvbSubst [TyVarBndr_ flag]
    clsTvbs Cxt
    clsArgs
        rhsSubst :: Map Name Type
    rhsSubst = [TyVarBndr_ flag] -> Cxt -> Map Name Type
    forall flag. [TyVarBndr_ flag] -> Cxt -> Map Name Type
    zipTvbSubst [TyVarBndr_ flag]
    clsTvbs (Cxt -> Map Name Type) -> Cxt -> Map Name Type
    forall a b. (a -> b) -> a -> b
    $ Cxt -> Type -> Cxt
    forall a. [a] -> a -> [a]
    changeLast Cxt
    clsArgs Type
    repTy

    zipTvbSubst :: [TyVarBndr_ flag] -> [Type] -> Map Name Type
    zipTvbSubst :: forall flag. [TyVarBndr_ flag] -> Cxt -> Map Name Type
    zipTvbSubst [TyVarBndr_ flag]
    tvbs = [(Name, Type)] -> Map Name Type
    forall k a. Ord k => [(k, a)] -> Map k a
    M.fromList ([(Name, Type)] -> Map Name Type)
    -> (Cxt -> [(Name, Type)]) -> Cxt -> Map Name Type
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (TyVarBndr_ flag -> Type -> (Name, Type))
    -> [TyVarBndr_ flag] -> Cxt -> [(Name, Type)]
    forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
    zipWith (\TyVarBndr_ flag
    tvb Type
    ty -> (TyVarBndr_ flag -> Name
    forall flag. TyVarBndr_ flag -> Name
    tvName TyVarBndr_ flag
    tvb, Type
    ty)) [TyVarBndr_ flag]
    tvbs

    -- | Replace the last element of a list with another element.
    changeLast :: [a] -> a -> [a]
    changeLast :: forall a. [a] -> a -> [a]
    changeLast []     a
    _  = String -> [a]
    forall a. HasCallStack => String -> a
    error String
    "changeLast"
    changeLast [a
    _]    a
    x  = [a
    x]
    changeLast (a
    x:[a]
    xs) a
    x' = a
    x a -> [a] -> [a]
    forall a. a -> [a] -> [a]
    : [a] -> a -> [a]
    forall a. [a] -> a -> [a]
    changeLast [a]
    xs a
    x'

    stripOuterForallT :: Type -> Type
    #if __GLASGOW_HASKELL__ < 807
    -- Before GHC 8.7, TH-reified classes would put a redundant forall/class
    -- context in front of each method's type signature, so we have to strip them
    -- off here.
    stripOuterForallT (ForallT _ _ ty) = ty
    #endif
    stripOuterForallT :: Type -> Type
    stripOuterForallT Type
    ty               = Type
    ty

    decomposeType :: Type -> ([TyVarBndrSpec], Cxt, Type)
    decomposeType :: Type -> ([TyVarBndrSpec], Cxt, Type)
    decomposeType (ForallT [TyVarBndrSpec]
    tvbs Cxt
    ctxt Type
    ty) = ([TyVarBndrSpec]
    tvbs, Cxt
    ctxt, Type
    ty)
    decomposeType Type
    ty                     = ([],   [],   Type
    ty)

    newtypeRepType :: DatatypeVariant -> [ConstructorInfo] -> Maybe Type
    newtypeRepType :: DatatypeVariant -> [ConstructorInfo] -> Maybe Type
    newtypeRepType DatatypeVariant
    dv [ConstructorInfo]
    cons = do
        Maybe ()
    checkIfNewtype
        case [ConstructorInfo]
    cons of
          [ConstructorInfo { constructorVars :: ConstructorInfo -> [TyVarBndr ()]
    constructorVars    = []
                           , constructorContext :: ConstructorInfo -> Cxt
    constructorContext = []
                           , constructorFields :: ConstructorInfo -> Cxt
    constructorFields  = [Type
    repTy]
                           }] -> Type -> Maybe Type
    forall a. a -> Maybe a
    Just Type
    repTy
          [ConstructorInfo]
    _ -> Maybe Type
    forall a. Maybe a
    Nothing
      where
        checkIfNewtype :: Maybe ()
        checkIfNewtype :: Maybe ()
    checkIfNewtype
          | DatatypeVariant
    Newtype         <- DatatypeVariant
    dv = () -> Maybe ()
    forall a. a -> Maybe a
    Just ()
          | DatatypeVariant
    NewtypeInstance <- DatatypeVariant
    dv = () -> Maybe ()
    forall a. a -> Maybe a
    Just ()
          | Bool
    otherwise             = Maybe ()
    forall a. Maybe a
    Nothing

    etaReduce :: Int -> Type -> Maybe Type
    etaReduce :: Int -> Type -> Maybe Type
    etaReduce Int
    num Type
    ty =
      let (Type
    tyHead, Cxt
    tyArgs) = Type -> (Type, Cxt)
    unapplyTy Type
    ty
          (Cxt
    tyArgsRemaining, Cxt
    tyArgsDropped) = Int -> Cxt -> (Cxt, Cxt)
    forall a. Int -> [a] -> ([a], [a])
    splitAt (Cxt -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length Cxt
    tyArgs Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    num) Cxt
    tyArgs
      in if Cxt -> Cxt -> Bool
    canEtaReduce Cxt
    tyArgsRemaining Cxt
    tyArgsDropped
            then Type -> Maybe Type
    forall a. a -> Maybe a
    Just (Type -> Maybe Type) -> Type -> Maybe Type
    forall a b. (a -> b) -> a -> b
    $ Type -> Cxt -> Type
    applyTy Type
    tyHead Cxt
    tyArgsRemaining
            else Maybe Type
    forall a. Maybe a
    Nothing
    #endif