    {-
    (c) The University of Glasgow 2006
    (c) The GRASP/AQUA Project, Glasgow University, 1992-1998

    -}

    {-# LANGUAGE TypeFamilies #-}

    {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}

    -- | Typechecking class declarations
    module GHC.Tc.TyCl.Class
       ( tcClassSigs
       , tcClassDecl2
       , findMethodBind
       , instantiateMethod
       , tcClassMinimalDef
       , HsSigFun
       , mkHsSigFun
       , instDeclCtxt1
       , instDeclCtxt2
       , instDeclCtxt3
       , tcATDefault
       , substATBndrs
       )
    where

    import GHC.Prelude

    import GHC.Hs
    import GHC.Tc.Errors.Types
    import GHC.Tc.Gen.Sig
    import GHC.Tc.Types.Evidence ( idHsWrapper )
    import GHC.Tc.Gen.Bind
    import GHC.Tc.Utils.Env
    import GHC.Tc.Utils.Unify
    import GHC.Tc.Utils.Instantiate( newFamInst, tcSuperSkolTyVars )
    import GHC.Tc.Gen.HsType
    import GHC.Tc.Utils.TcMType
    import GHC.Tc.Types.Origin
    import GHC.Tc.Utils.TcType
    import GHC.Tc.Utils.Monad
    import GHC.Tc.TyCl.Build( TcMethInfo )

    import GHC.Core.Type     ( extendTvSubstWithClone, piResultTys )
    import GHC.Core.Predicate
    import GHC.Core.Multiplicity
    import GHC.Core.Class
    import GHC.Core.Coercion ( pprCoAxiom )
    import GHC.Core.FamInstEnv
    import GHC.Core.TyCon

    import GHC.Driver.DynFlags

    import GHC.Types.Id
    import GHC.Types.Name
    import GHC.Types.Name.Env
    import GHC.Types.Name.Set
    import GHC.Types.Var
    import GHC.Types.Var.Env ( lookupVarEnv )
    import GHC.Types.SourceFile (HscSource(..))
    import GHC.Types.SrcLoc
    import GHC.Types.Basic

    import GHC.Utils.Outputable
    import GHC.Utils.Panic

    import GHC.Data.Maybe
    import GHC.Data.BooleanFormula

    import Control.Monad
    import Data.List ( mapAccumL, partition )
    import qualified Data.List.NonEmpty as NE

    {-
    Dictionary handling
    ~~~~~~~~~~~~~~~~~~~
    Every class implicitly declares a new data type, corresponding to dictionaries
    of that class. So, for example:

            class (D a) => C a where
              op1 :: a -> a
              op2 :: forall b. Ord b => a -> b -> b

    would implicitly declare

            data CDict a = CDict (D a)
                                 (a -> a)
                                 (forall b. Ord b => a -> b -> b)

    (We could use a record decl, but that means changing more of the existing apparatus.
    One step at a time!)

    For classes with just one superclass+method, we use a newtype decl instead:

            class C a where
              op :: forallb. a -> b -> b

    generates

            newtype CDict a = CDict (forall b. a -> b -> b)

    Now DictTy in Type is just a form of type synonym:
            DictTy c t = TyConTy CDict `AppTy` t

    Death to "ExpandingDicts".

    ************************************************************************
    *                                                                      *
                    Type-checking the class op signatures
    *                                                                      *
    ************************************************************************
    -}

    tcClassSigs :: Name                -- Name of the class
                -> [LSig GhcRn]
                -> LHsBinds GhcRn
                -> TcM [TcMethInfo]    -- Exactly one for each method
    tcClassSigs :: Name -> [LSig GhcRn] -> LHsBinds GhcRn -> TcM [TcMethInfo]
    tcClassSigs Name
    clas [LSig GhcRn]
    sigs LHsBinds GhcRn
    def_methods
      = do { String -> SDoc -> TcRn ()
    traceTc String
    "tcClassSigs 1" (Name -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Name
    clas)

           ; gen_dm_prs <- (GenLocated
       SrcSpan
       ([GenLocated SrcSpanAnnN Name],
        GenLocated SrcSpanAnnA (HsSigType GhcRn))
     -> IOEnv (Env TcGblEnv TcLclEnv) [(Name, (SrcSpan, Type))])
    -> [GenLocated
          SrcSpan
          ([GenLocated SrcSpanAnnN Name],
           GenLocated SrcSpanAnnA (HsSigType GhcRn))]
    -> IOEnv (Env TcGblEnv TcLclEnv) [(Name, (SrcSpan, Type))]
    forall (m :: * -> *) (f :: * -> *) a b.
    (Monad m, Traversable f) =>
    (a -> m [b]) -> f a -> m [b]
    concatMapM ((([GenLocated SrcSpanAnnN Name],
      GenLocated SrcSpanAnnA (HsSigType GhcRn))
     -> IOEnv (Env TcGblEnv TcLclEnv) [(Name, (SrcSpan, Type))])
    -> GenLocated
         SrcSpan
         ([GenLocated SrcSpanAnnN Name],
          GenLocated SrcSpanAnnA (HsSigType GhcRn))
    -> IOEnv (Env TcGblEnv TcLclEnv) [(Name, (SrcSpan, Type))]
    forall t a b. HasLoc t => (a -> TcM b) -> GenLocated t a -> TcM b
    addLocM ([GenLocated SrcSpanAnnN Name], LHsSigType GhcRn)
    -> IOEnv (Env TcGblEnv TcLclEnv) [(Name, (SrcSpan, Type))]
    ([GenLocated SrcSpanAnnN Name],
     GenLocated SrcSpanAnnA (HsSigType GhcRn))
    -> IOEnv (Env TcGblEnv TcLclEnv) [(Name, (SrcSpan, Type))]
    tc_gen_sig) [Located ([GenLocated SrcSpanAnnN Name], LHsSigType GhcRn)]
    [GenLocated
       SrcSpan
       ([GenLocated SrcSpanAnnN Name],
        GenLocated SrcSpanAnnA (HsSigType GhcRn))]
    gen_sigs
           ; let gen_dm_env :: NameEnv (SrcSpan, Type)
                 gen_dm_env = [(Name, (SrcSpan, Type))] -> NameEnv (SrcSpan, Type)
    forall a. [(Name, a)] -> NameEnv a
    mkNameEnv [(Name, (SrcSpan, Type))]
    gen_dm_prs

           ; op_info <- concatMapM (addLocM (tc_sig gen_dm_env)) vanilla_sigs

           ; let op_names = [Name] -> NameSet
    mkNameSet [ Name
    n | (Name
    n,Type
    _,Maybe (DefMethSpec (SrcSpan, Type))
    _) <- [TcMethInfo]
    op_info ]
           ; sequence_ [ failWithTc (TcRnBadMethodErr clas n)
                       | n <- dm_bind_names, not (n `elemNameSet` op_names) ]
                       -- Value binding for non class-method (ie no TypeSig)

           ; tcg_env <- getGblEnv
           ; if tcg_src tcg_env == HsigFile
                then
                   -- Error if we have value bindings
                   -- (Generic signatures without value bindings indicate
                   -- that a default of this form is expected to be
                   -- provided.)
                   case def_methods of
                     []           -> () -> TcRn ()
    forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
                     LHsBindLR GhcRn GhcRn
    meth : LHsBinds GhcRn
    meths -> TcRnMessage -> TcRn ()
    forall a. TcRnMessage -> TcM a
    failWithTc (Name -> NonEmpty (LHsBindLR GhcRn GhcRn) -> TcRnMessage
    TcRnIllegalHsigDefaultMethods Name
    clas (LHsBindLR GhcRn GhcRn
    GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)
    meth GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)
    -> [GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)]
    -> NonEmpty (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn))
    forall a. a -> [a] -> NonEmpty a
    NE.:| LHsBinds GhcRn
    [GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)]
    meths))
                else
                   -- Error for each generic signature without value binding
                   sequence_ [ failWithTc (TcRnBadGenericMethod clas n)
                             | (n,_) <- gen_dm_prs, not (n `elem` dm_bind_names) ]

           ; traceTc "tcClassSigs 2" (ppr clas)
           ; return op_info }
      where
        vanilla_sigs :: [Located ([LocatedN Name], LHsSigType GhcRn)] -- AZ temp
        vanilla_sigs :: [Located ([GenLocated SrcSpanAnnN Name], LHsSigType GhcRn)]
    vanilla_sigs = [SrcSpan
    -> ([GenLocated SrcSpanAnnN Name],
        GenLocated SrcSpanAnnA (HsSigType GhcRn))
    -> GenLocated
         SrcSpan
         ([GenLocated SrcSpanAnnN Name],
          GenLocated SrcSpanAnnA (HsSigType GhcRn))
    forall l e. l -> e -> GenLocated l e
    L (SrcSpanAnnA -> SrcSpan
    forall a. HasLoc a => a -> SrcSpan
    locA SrcSpanAnnA
    loc) ([LIdP GhcRn]
    [GenLocated SrcSpanAnnN Name]
    nm,LHsSigType GhcRn
    GenLocated SrcSpanAnnA (HsSigType GhcRn)
    ty) | L SrcSpanAnnA
    loc (ClassOpSig XClassOpSig GhcRn
    _ Bool
    False [LIdP GhcRn]
    nm LHsSigType GhcRn
    ty) <- [LSig GhcRn]
    [GenLocated SrcSpanAnnA (Sig GhcRn)]
    sigs]
        gen_sigs :: [Located ([LocatedN Name], LHsSigType GhcRn)] -- AZ temp
        gen_sigs :: [Located ([GenLocated SrcSpanAnnN Name], LHsSigType GhcRn)]
    gen_sigs     = [SrcSpan
    -> ([GenLocated SrcSpanAnnN Name],
        GenLocated SrcSpanAnnA (HsSigType GhcRn))
    -> GenLocated
         SrcSpan
         ([GenLocated SrcSpanAnnN Name],
          GenLocated SrcSpanAnnA (HsSigType GhcRn))
    forall l e. l -> e -> GenLocated l e
    L (SrcSpanAnnA -> SrcSpan
    forall a. HasLoc a => a -> SrcSpan
    locA SrcSpanAnnA
    loc) ([LIdP GhcRn]
    [GenLocated SrcSpanAnnN Name]
    nm,LHsSigType GhcRn
    GenLocated SrcSpanAnnA (HsSigType GhcRn)
    ty) | L SrcSpanAnnA
    loc (ClassOpSig XClassOpSig GhcRn
    _ Bool
    True  [LIdP GhcRn]
    nm LHsSigType GhcRn
    ty) <- [LSig GhcRn]
    [GenLocated SrcSpanAnnA (Sig GhcRn)]
    sigs]
        dm_bind_names :: [Name] -- These ones have a value binding in the class decl
        dm_bind_names :: [Name]
    dm_bind_names = [Name
    op | L SrcSpanAnnA
    _ (FunBind {fun_id :: forall idL idR. HsBindLR idL idR -> LIdP idL
    fun_id = L SrcSpanAnnN
    _ Name
    op}) <- LHsBinds GhcRn
    [GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)]
    def_methods]

        tc_sig :: NameEnv (SrcSpan, Type) -> ([LocatedN Name], LHsSigType GhcRn)
               -> TcM [TcMethInfo]
        tc_sig :: NameEnv (SrcSpan, Type)
    -> ([GenLocated SrcSpanAnnN Name], LHsSigType GhcRn)
    -> TcM [TcMethInfo]
    tc_sig NameEnv (SrcSpan, Type)
    gen_dm_env ([GenLocated SrcSpanAnnN Name]
    op_names, LHsSigType GhcRn
    op_hs_ty)
          = do { String -> SDoc -> TcRn ()
    traceTc String
    "ClsSig 1" ([GenLocated SrcSpanAnnN Name] -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr [GenLocated SrcSpanAnnN Name]
    op_names)
               ; op_ty <- [GenLocated SrcSpanAnnN Name] -> LHsSigType GhcRn -> TcM Type
    tcClassSigType [GenLocated SrcSpanAnnN Name]
    op_names LHsSigType GhcRn
    op_hs_ty
                       -- Class tyvars already in scope

               ; traceTc "ClsSig 2" (ppr op_names $$ ppr op_ty)
               ; return [ (op_name, op_ty, f op_name) | L _ op_name <- op_names ] }
               where
                 f :: Name -> Maybe (DefMethSpec (SrcSpan, Type))
    f Name
    nm | Just (SrcSpan, Type)
    lty <- NameEnv (SrcSpan, Type) -> Name -> Maybe (SrcSpan, Type)
    forall a. NameEnv a -> Name -> Maybe a
    lookupNameEnv NameEnv (SrcSpan, Type)
    gen_dm_env Name
    nm = DefMethSpec (SrcSpan, Type) -> Maybe (DefMethSpec (SrcSpan, Type))
    forall a. a -> Maybe a
    Just ((SrcSpan, Type) -> DefMethSpec (SrcSpan, Type)
    forall ty. ty -> DefMethSpec ty
    GenericDM (SrcSpan, Type)
    lty)
                      | Name
    nm Name -> [Name] -> Bool
    forall a. Eq a => a -> [a] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem` [Name]
    dm_bind_names                 = DefMethSpec (SrcSpan, Type) -> Maybe (DefMethSpec (SrcSpan, Type))
    forall a. a -> Maybe a
    Just DefMethSpec (SrcSpan, Type)
    forall ty. DefMethSpec ty
    VanillaDM
                      | Bool
    otherwise                               = Maybe (DefMethSpec (SrcSpan, Type))
    forall a. Maybe a
    Nothing

        tc_gen_sig :: ([LocatedN Name], LHsSigType GhcRn)
                          -> IOEnv (Env TcGblEnv TcLclEnv) [(Name, (SrcSpan, Type))] -- AZ temp
        tc_gen_sig :: ([GenLocated SrcSpanAnnN Name], LHsSigType GhcRn)
    -> IOEnv (Env TcGblEnv TcLclEnv) [(Name, (SrcSpan, Type))]
    tc_gen_sig ([GenLocated SrcSpanAnnN Name]
    op_names, LHsSigType GhcRn
    gen_hs_ty)
          = do { gen_op_ty <- [GenLocated SrcSpanAnnN Name] -> LHsSigType GhcRn -> TcM Type
    tcClassSigType [GenLocated SrcSpanAnnN Name]
    op_names LHsSigType GhcRn
    gen_hs_ty
               ; return [ (op_name, (locA loc, gen_op_ty))
                                                     | L loc op_name <- op_names ] }

    {-
    ************************************************************************
    *                                                                      *
                    Class Declarations
    *                                                                      *
    ************************************************************************
    -}

    tcClassDecl2 :: LTyClDecl GhcRn          -- The class declaration
                 -> TcM (LHsBinds GhcTc)

    tcClassDecl2 :: LTyClDecl GhcRn -> TcM (LHsBinds GhcTc)
    tcClassDecl2 (L SrcSpanAnnA
    _ (ClassDecl {tcdLName :: forall pass. TyClDecl pass -> LIdP pass
    tcdLName = LIdP GhcRn
    class_name, tcdSigs :: forall pass. TyClDecl pass -> [LSig pass]
    tcdSigs = [LSig GhcRn]
    sigs,
                                    tcdMeths :: forall pass. TyClDecl pass -> LHsBinds pass
    tcdMeths = LHsBinds GhcRn
    default_binds}))
      = TcM (LHsBinds GhcTc)
    -> TcM (LHsBinds GhcTc) -> TcM (LHsBinds GhcTc)
    forall r. TcRn r -> TcRn r -> TcRn r
    recoverM ([GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
    -> IOEnv
         (Env TcGblEnv TcLclEnv)
         [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
    forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return LHsBinds GhcTc
    [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
    forall (idL :: Pass) idR. LHsBindsLR (GhcPass idL) idR
    emptyLHsBinds) (TcM (LHsBinds GhcTc) -> TcM (LHsBinds GhcTc))
    -> TcM (LHsBinds GhcTc) -> TcM (LHsBinds GhcTc)
    forall a b. (a -> b) -> a -> b
    $
        SrcSpan -> TcM (LHsBinds GhcTc) -> TcM (LHsBinds GhcTc)
    forall a. SrcSpan -> TcRn a -> TcRn a
    setSrcSpan (GenLocated SrcSpanAnnN Name -> SrcSpan
    forall a e. HasLoc a => GenLocated a e -> SrcSpan
    getLocA LIdP GhcRn
    GenLocated SrcSpanAnnN Name
    class_name) (TcM (LHsBinds GhcTc) -> TcM (LHsBinds GhcTc))
    -> TcM (LHsBinds GhcTc) -> TcM (LHsBinds GhcTc)
    forall a b. (a -> b) -> a -> b
    $
        do  { clas <- LocatedA Name -> TcM Class
    tcLookupLocatedClass (GenLocated SrcSpanAnnN Name -> LocatedA Name
    forall l l2 a.
    (HasLoc l, HasAnnotation l2) =>
    GenLocated l a -> GenLocated l2 a
    la2la LIdP GhcRn
    GenLocated SrcSpanAnnN Name
    class_name)

            -- We make a separate binding for each default method.
            -- At one time I used a single AbsBinds for all of them, thus
            -- AbsBind [d] [dm1, dm2, dm3] { dm1 = ...; dm2 = ...; dm3 = ... }
            -- But that desugars into
            --      ds = \d -> (..., ..., ...)
            --      dm1 = \d -> case ds d of (a,b,c) -> a
            -- And since ds is big, it doesn't get inlined, so we don't get good
            -- default methods.  Better to make separate AbsBinds for each

            ; skol_info <- mkSkolemInfo (TyConSkol ClassFlavour (getName class_name))
            ; tc_lvl    <- getTcLevel
            ; let (tyvars, _, _, op_items) = classBigSig clas
                  prag_fn = [LSig GhcRn] -> LHsBinds GhcRn -> TcPragEnv
    mkPragEnv [LSig GhcRn]
    sigs LHsBinds GhcRn
    default_binds
                  sig_fn  = [LSig GhcRn] -> HsSigFun
    mkHsSigFun [LSig GhcRn]
    sigs
                  (_skol_subst, clas_tyvars) = tcSuperSkolTyVars tc_lvl skol_info tyvars
                        -- This make skolemTcTyVars, but does not clone,
                        -- so we can put them in scope with tcExtendTyVarEnv
                  pred = Class -> [Type] -> Type
    mkClassPred Class
    clas ([TcId] -> [Type]
    mkTyVarTys [TcId]
    clas_tyvars)
            ; this_dict <- newEvVar pred

            ; let tc_item = Class
    -> [TcId]
    -> TcId
    -> LHsBinds GhcRn
    -> HsSigFun
    -> TcPragEnv
    -> ClassOpItem
    -> TcM (LHsBinds GhcTc)
    tcDefMeth Class
    clas [TcId]
    clas_tyvars TcId
    this_dict
                                      LHsBinds GhcRn
    default_binds HsSigFun
    sig_fn TcPragEnv
    prag_fn
            ; dm_binds <- tcExtendTyVarEnv clas_tyvars $
                          mapM tc_item op_items

            ; return (concat dm_binds) }

    tcClassDecl2 LTyClDecl GhcRn
    d = String
    -> SDoc
    -> IOEnv
         (Env TcGblEnv TcLclEnv)
         [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
    forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "tcClassDecl2" (GenLocated SrcSpanAnnA (TyClDecl GhcRn) -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LTyClDecl GhcRn
    GenLocated SrcSpanAnnA (TyClDecl GhcRn)
    d)

    tcDefMeth :: Class -> [TyVar] -> EvVar -> LHsBinds GhcRn
              -> HsSigFun -> TcPragEnv -> ClassOpItem
              -> TcM (LHsBinds GhcTc)
    -- Generate code for default methods
    -- This is incompatible with Hugs, which expects a polymorphic
    -- default method for every class op, regardless of whether or not
    -- the programmer supplied an explicit default decl for the class.
    -- (If necessary we can fix that, but we don't have a convenient Id to hand.)

    tcDefMeth :: Class
    -> [TcId]
    -> TcId
    -> LHsBinds GhcRn
    -> HsSigFun
    -> TcPragEnv
    -> ClassOpItem
    -> TcM (LHsBinds GhcTc)
    tcDefMeth Class
    _ [TcId]
    _ TcId
    _ LHsBinds GhcRn
    _ HsSigFun
    _ TcPragEnv
    prag_fn (TcId
    sel_id, Maybe (Name, DefMethSpec Type)
    Nothing)
      = do { -- No default method
             (GenLocated SrcSpanAnnA (Sig GhcRn) -> TcRn ())
    -> [GenLocated SrcSpanAnnA (Sig GhcRn)] -> TcRn ()
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    (a -> m b) -> t a -> m ()
    mapM_ ((Sig GhcRn -> TcRn ())
    -> GenLocated SrcSpanAnnA (Sig GhcRn) -> TcRn ()
    forall t a b. HasLoc t => (a -> TcM b) -> GenLocated t a -> TcM b
    addLocM (TcId -> Sig GhcRn -> TcRn ()
    badDmPrag TcId
    sel_id ))
                   (TcPragEnv -> Name -> [LSig GhcRn]
    lookupPragEnv TcPragEnv
    prag_fn (TcId -> Name
    idName TcId
    sel_id))
           ; [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
    -> IOEnv
         (Env TcGblEnv TcLclEnv)
         [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
    forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return [] }

    tcDefMeth Class
    clas [TcId]
    tyvars TcId
    this_dict LHsBinds GhcRn
    binds_in HsSigFun
    hs_sig_fn TcPragEnv
    prag_fn
              (TcId
    sel_id, Just (Name
    dm_name, DefMethSpec Type
    dm_spec))
      | Just (L SrcSpanAnnA
    bind_loc HsBindLR GhcRn GhcRn
    dm_bind, SrcSpan
    bndr_loc, [LSig GhcRn]
    prags) <- Name
    -> LHsBinds GhcRn
    -> TcPragEnv
    -> Maybe (LHsBindLR GhcRn GhcRn, SrcSpan, [LSig GhcRn])
    findMethodBind Name
    sel_name LHsBinds GhcRn
    binds_in TcPragEnv
    prag_fn
      = do { -- First look up the default method; it should be there!
             -- It can be the ordinary default method
             -- or the generic-default method.  E.g of the latter
             --      class C a where
             --        op :: a -> a -> Bool
             --        default op :: Eq a => a -> a -> Bool
             --        op x y = x==y
             -- The default method we generate is
             --    $gm :: (C a, Eq a) => a -> a -> Bool
             --    $gm x y = x==y

             global_dm_id  <- Name -> TcRnIf TcGblEnv TcLclEnv TcId
    tcLookupId Name
    dm_name
           ; global_dm_id  <- addInlinePrags global_dm_id prags
           ; local_dm_name <- newNameAt (getOccName sel_name) bndr_loc
                -- Base the local_dm_name on the selector name, because
                -- type errors from tcInstanceMethodBody come from here

           ; spec_prags <- discardConstraints $
                           tcSpecPrags global_dm_id prags
           ; let dia = Name -> TcRnMessage
    TcRnIgnoreSpecialisePragmaOnDefMethod Name
    sel_name

           ; diagnosticTc (not (null spec_prags)) dia

           ; let hs_ty = HsSigFun
    hs_sig_fn Name
    sel_name
                         Maybe (GenLocated SrcSpanAnnA (HsSigType GhcRn))
    -> GenLocated SrcSpanAnnA (HsSigType GhcRn)
    -> GenLocated SrcSpanAnnA (HsSigType GhcRn)
    forall a. Maybe a -> a -> a
    `orElse` String -> SDoc -> GenLocated SrcSpanAnnA (HsSigType GhcRn)
    forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "tc_dm" (Name -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Name
    sel_name)
                 -- We need the HsType so that we can bring the right
                 -- type variables into scope
                 --
                 -- Eg.   class C a where
                 --          op :: forall b. Eq b => a -> [b] -> a
                 --          gen_op :: a -> a
                 --          generic gen_op :: D a => a -> a
                 -- The "local_dm_ty" is precisely the type in the above
                 -- type signatures, ie with no "forall a. C a =>" prefix

                 local_dm_ty = Class -> TcId -> [Type] -> Type
    instantiateMethod Class
    clas TcId
    global_dm_id ([TcId] -> [Type]
    mkTyVarTys [TcId]
    tyvars)

                 lm_bind     = HsBindLR GhcRn GhcRn
    dm_bind { fun_id = L (l2l bind_loc) local_dm_name }
                                 -- Substitute the local_meth_name for the binder
                                 -- NB: the binding is always a FunBind

                 warn_redundant = case DefMethSpec Type
    dm_spec of
                                    GenericDM {} -> LHsSigType GhcRn -> ReportRedundantConstraints
    lhsSigTypeContextSpan LHsSigType GhcRn
    GenLocated SrcSpanAnnA (HsSigType GhcRn)
    hs_ty
                                    DefMethSpec Type
    VanillaDM    -> ReportRedundantConstraints
    NoRRC
                    -- For GenericDM, warn if the user specifies a signature
                    -- with redundant constraints; but not for VanillaDM, where
                    -- the default method may well be 'error' or something

                 ctxt = Name -> ReportRedundantConstraints -> UserTypeCtxt
    FunSigCtxt Name
    sel_name ReportRedundantConstraints
    warn_redundant

           ; let local_dm_id = HasDebugCallStack => Name -> Type -> Type -> TcId
    Name -> Type -> Type -> TcId
    mkLocalId Name
    local_dm_name Type
    ManyTy Type
    local_dm_ty
                 local_dm_sig = CSig { sig_bndr :: TcId
    sig_bndr = TcId
    local_dm_id
                                     , sig_ctxt :: UserTypeCtxt
    sig_ctxt = UserTypeCtxt
    ctxt
                                     , sig_loc :: SrcSpan
    sig_loc  = GenLocated SrcSpanAnnA (HsSigType GhcRn) -> SrcSpan
    forall a e. HasLoc a => GenLocated a e -> SrcSpan
    getLocA GenLocated SrcSpanAnnA (HsSigType GhcRn)
    hs_ty }

           ; (ev_binds, (tc_bind, _))
                   <- checkConstraints skol_info tyvars [this_dict] $
                      tcPolyCheck no_prag_fn local_dm_sig
                                  (L bind_loc lm_bind)

           ; let export = ABE { abe_poly :: TcId
    abe_poly  = TcId
    global_dm_id
                              , abe_mono :: TcId
    abe_mono  = TcId
    local_dm_id
                              , abe_wrap :: HsWrapper
    abe_wrap  = HsWrapper
    idHsWrapper
                              , abe_prags :: TcSpecPrags
    abe_prags = TcSpecPrags
    IsDefaultMethod }
                 full_bind = XXHsBindsLR GhcTc GhcTc -> HsBindLR GhcTc GhcTc
    forall idL idR. XXHsBindsLR idL idR -> HsBindLR idL idR
    XHsBindsLR (XXHsBindsLR GhcTc GhcTc -> HsBindLR GhcTc GhcTc)
    -> XXHsBindsLR GhcTc GhcTc -> HsBindLR GhcTc GhcTc
    forall a b. (a -> b) -> a -> b
    $
                             AbsBinds { abs_tvs :: [TcId]
    abs_tvs      = [TcId]
    tyvars
                                      , abs_ev_vars :: [TcId]
    abs_ev_vars  = [TcId
    this_dict]
                                      , abs_exports :: [ABExport]
    abs_exports  = [ABExport
    export]
                                      , abs_ev_binds :: [TcEvBinds]
    abs_ev_binds = [TcEvBinds
    ev_binds]
                                      , abs_binds :: LHsBinds GhcTc
    abs_binds    = LHsBinds GhcTc
    tc_bind
                                      , abs_sig :: Bool
    abs_sig      = Bool
    True }

           ; return [L bind_loc full_bind] }

      | Bool
    otherwise = String
    -> SDoc
    -> IOEnv
         (Env TcGblEnv TcLclEnv)
         [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
    forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "tcDefMeth" (TcId -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr TcId
    sel_id)
      where
        skol_info :: SkolemInfoAnon
    skol_info = TyConFlavour TyCon -> Name -> SkolemInfoAnon
    TyConSkol TyConFlavour TyCon
    forall tc. TyConFlavour tc
    ClassFlavour (Class -> Name
    forall a. NamedThing a => a -> Name
    getName Class
    clas)
        sel_name :: Name
    sel_name = TcId -> Name
    idName TcId
    sel_id
        no_prag_fn :: TcPragEnv
    no_prag_fn = TcPragEnv
    emptyPragEnv   -- No pragmas for local_meth_id;
                                    -- they are all for meth_id

    ---------------
    tcClassMinimalDef :: Name -> [LSig GhcRn] -> [TcMethInfo] -> TcM ClassMinimalDef
    tcClassMinimalDef :: Name -> [LSig GhcRn] -> [TcMethInfo] -> TcM (BooleanFormula GhcRn)
    tcClassMinimalDef Name
    _clas [LSig GhcRn]
    sigs [TcMethInfo]
    op_info
      = case [LSig GhcRn] -> Maybe (BooleanFormula GhcRn)
    findMinimalDef [LSig GhcRn]
    sigs of
          Maybe (BooleanFormula GhcRn)
    Nothing -> BooleanFormula GhcRn -> TcM (BooleanFormula GhcRn)
    forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return BooleanFormula GhcRn
    defMindef
          Just BooleanFormula GhcRn
    mindef -> do
            -- Warn if the given mindef does not imply the default one
            -- That is, the given mindef should at least ensure that the
            -- class ops without default methods are required, since we
            -- have no way to fill them in otherwise
            tcg_env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
    forall gbl lcl. TcRnIf gbl lcl gbl
    getGblEnv
            -- However, only do this test when it's not an hsig file,
            -- since you can't write a default implementation.
            when (tcg_src tcg_env /= HsigFile) $
                whenIsJust (isUnsatisfied (mindef `impliesAtom`) defMindef) $
                           (\BooleanFormula GhcRn
    bf -> TcRnMessage -> TcRn ()
    addDiagnosticTc (BooleanFormula GhcRn -> TcRnMessage
    TcRnWarningMinimalDefIncomplete BooleanFormula GhcRn
    bf))
            return mindef
      where
        -- By default require all methods without a default implementation
        defMindef :: ClassMinimalDef
        defMindef :: BooleanFormula GhcRn
    defMindef = [LBooleanFormula GhcRn] -> BooleanFormula GhcRn
    forall p.
    (UnXRec p, Eq (LIdP p), Eq (LBooleanFormula p)) =>
    [LBooleanFormula p] -> BooleanFormula p
    mkAnd [ BooleanFormula GhcRn
    -> GenLocated SrcSpanAnnL (BooleanFormula GhcRn)
    forall e a. HasAnnotation e => a -> GenLocated e a
    noLocA (LIdP GhcRn -> BooleanFormula GhcRn
    forall p. LIdP p -> BooleanFormula p
    mkVar (Name -> GenLocated SrcSpanAnnN Name
    forall e a. HasAnnotation e => a -> GenLocated e a
    noLocA Name
    name))
                          | (Name
    name, Type
    _, Maybe (DefMethSpec (SrcSpan, Type))
    Nothing) <- [TcMethInfo]
    op_info ]

    instantiateMethod :: Class -> TcId -> [TcType] -> TcType
    -- Take a class operation, say
    --      op :: forall ab. C a => forall c. Ix c => (b,c) -> a
    -- Instantiate it at [ty1,ty2]
    -- Return the "local method type":
    --      forall c. Ix x => (ty2,c) -> ty1
    instantiateMethod :: Class -> TcId -> [Type] -> Type
    instantiateMethod Class
    clas TcId
    sel_id [Type]
    inst_tys
      = Bool -> Type -> Type
    forall a. HasCallStack => Bool -> a -> a
    assert Bool
    ok_first_pred Type
    local_meth_ty
      where
        rho_ty :: Type
    rho_ty = HasDebugCallStack => Type -> [Type] -> Type
    Type -> [Type] -> Type
    piResultTys (TcId -> Type
    idType TcId
    sel_id) [Type]
    inst_tys
        (Type
    first_pred, Type
    local_meth_ty) = Type -> Maybe (Type, Type)
    tcSplitPredFunTy_maybe Type
    rho_ty
                    Maybe (Type, Type) -> (Type, Type) -> (Type, Type)
    forall a. Maybe a -> a -> a
    `orElse` String -> SDoc -> (Type, Type)
    forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "tcInstanceMethod" (TcId -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr TcId
    sel_id)

        ok_first_pred :: Bool
    ok_first_pred = case Type -> Maybe (Class, [Type])
    getClassPredTys_maybe Type
    first_pred of
                          Just (Class
    clas1, [Type]
    _tys) -> Class
    clas Class -> Class -> Bool
    forall a. Eq a => a -> a -> Bool
    == Class
    clas1
                          Maybe (Class, [Type])
    Nothing -> Bool
    False
                  -- The first predicate should be of form (C a b)
                  -- where C is the class in question

    ---------------------------
    type HsSigFun = Name -> Maybe (LHsSigType GhcRn)

    mkHsSigFun :: [LSig GhcRn] -> HsSigFun
    mkHsSigFun :: [LSig GhcRn] -> HsSigFun
    mkHsSigFun [LSig GhcRn]
    sigs = NameEnv (GenLocated SrcSpanAnnA (HsSigType GhcRn))
    -> Name -> Maybe (GenLocated SrcSpanAnnA (HsSigType GhcRn))
    forall a. NameEnv a -> Name -> Maybe a
    lookupNameEnv NameEnv (GenLocated SrcSpanAnnA (HsSigType GhcRn))
    env
      where
        env :: NameEnv (GenLocated SrcSpanAnnA (HsSigType GhcRn))
    env = (LSig GhcRn
     -> Maybe
          ([GenLocated SrcSpanAnnN Name],
           GenLocated SrcSpanAnnA (HsSigType GhcRn)))
    -> [LSig GhcRn]
    -> NameEnv (GenLocated SrcSpanAnnA (HsSigType GhcRn))
    forall a.
    (LSig GhcRn -> Maybe ([GenLocated SrcSpanAnnN Name], a))
    -> [LSig GhcRn] -> NameEnv a
    mkHsSigEnv LSig GhcRn
    -> Maybe ([GenLocated SrcSpanAnnN Name], LHsSigType GhcRn)
    LSig GhcRn
    -> Maybe
         ([GenLocated SrcSpanAnnN Name],
          GenLocated SrcSpanAnnA (HsSigType GhcRn))
    get_classop_sig [LSig GhcRn]
    sigs

        get_classop_sig :: LSig GhcRn -> Maybe ([LocatedN Name], LHsSigType GhcRn)
        get_classop_sig :: LSig GhcRn
    -> Maybe ([GenLocated SrcSpanAnnN Name], LHsSigType GhcRn)
    get_classop_sig  (L SrcSpanAnnA
    _ (ClassOpSig XClassOpSig GhcRn
    _ Bool
    _ [LIdP GhcRn]
    ns LHsSigType GhcRn
    hs_ty)) = ([GenLocated SrcSpanAnnN Name],
     GenLocated SrcSpanAnnA (HsSigType GhcRn))
    -> Maybe
         ([GenLocated SrcSpanAnnN Name],
          GenLocated SrcSpanAnnA (HsSigType GhcRn))
    forall a. a -> Maybe a
    Just ([LIdP GhcRn]
    [GenLocated SrcSpanAnnN Name]
    ns, LHsSigType GhcRn
    GenLocated SrcSpanAnnA (HsSigType GhcRn)
    hs_ty)
        get_classop_sig  LSig GhcRn
    _                               = Maybe ([GenLocated SrcSpanAnnN Name], LHsSigType GhcRn)
    Maybe
      ([GenLocated SrcSpanAnnN Name],
       GenLocated SrcSpanAnnA (HsSigType GhcRn))
    forall a. Maybe a
    Nothing

    ---------------------------
    findMethodBind  :: Name                 -- Selector
                    -> LHsBinds GhcRn       -- A group of bindings
                    -> TcPragEnv
                    -> Maybe (LHsBind GhcRn, SrcSpan, [LSig GhcRn])
                    -- Returns the binding, the binding
                    -- site of the method binder, and any inline or
                    -- specialisation pragmas
    findMethodBind :: Name
    -> LHsBinds GhcRn
    -> TcPragEnv
    -> Maybe (LHsBindLR GhcRn GhcRn, SrcSpan, [LSig GhcRn])
    findMethodBind Name
    sel_name LHsBinds GhcRn
    binds TcPragEnv
    prag_fn
      = (Maybe
       (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn), SrcSpan,
        [GenLocated SrcSpanAnnA (Sig GhcRn)])
     -> Maybe
          (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn), SrcSpan,
           [GenLocated SrcSpanAnnA (Sig GhcRn)])
     -> Maybe
          (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn), SrcSpan,
           [GenLocated SrcSpanAnnA (Sig GhcRn)]))
    -> Maybe
         (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn), SrcSpan,
          [GenLocated SrcSpanAnnA (Sig GhcRn)])
    -> [Maybe
          (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn), SrcSpan,
           [GenLocated SrcSpanAnnA (Sig GhcRn)])]
    -> Maybe
         (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn), SrcSpan,
          [GenLocated SrcSpanAnnA (Sig GhcRn)])
    forall b a. (b -> a -> b) -> b -> [a] -> b
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl' Maybe
      (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn), SrcSpan,
       [GenLocated SrcSpanAnnA (Sig GhcRn)])
    -> Maybe
         (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn), SrcSpan,
          [GenLocated SrcSpanAnnA (Sig GhcRn)])
    -> Maybe
         (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn), SrcSpan,
          [GenLocated SrcSpanAnnA (Sig GhcRn)])
    forall a. Maybe a -> Maybe a -> Maybe a
    forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
    mplus Maybe
      (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn), SrcSpan,
       [GenLocated SrcSpanAnnA (Sig GhcRn)])
    forall a. Maybe a
    Nothing ((GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)
     -> Maybe
          (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn), SrcSpan,
           [GenLocated SrcSpanAnnA (Sig GhcRn)]))
    -> [GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)]
    -> [Maybe
          (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn), SrcSpan,
           [GenLocated SrcSpanAnnA (Sig GhcRn)])]
    forall a b. (a -> b) -> [a] -> [b]
    map GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)
    -> Maybe
         (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn), SrcSpan,
          [GenLocated SrcSpanAnnA (Sig GhcRn)])
    f LHsBinds GhcRn
    [GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)]
    binds)
      where
        prags :: [LSig GhcRn]
    prags    = TcPragEnv -> Name -> [LSig GhcRn]
    lookupPragEnv TcPragEnv
    prag_fn Name
    sel_name

        f :: GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)
    -> Maybe
         (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn), SrcSpan,
          [GenLocated SrcSpanAnnA (Sig GhcRn)])
    f bind :: GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)
    bind@(L SrcSpanAnnA
    _ (FunBind { fun_id :: forall idL idR. HsBindLR idL idR -> LIdP idL
    fun_id = L SrcSpanAnnN
    bndr_loc Name
    op_name }))
          | Name
    op_name Name -> Name -> Bool
    forall a. Eq a => a -> a -> Bool
    == Name
    sel_name
                 = (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn), SrcSpan,
     [GenLocated SrcSpanAnnA (Sig GhcRn)])
    -> Maybe
         (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn), SrcSpan,
          [GenLocated SrcSpanAnnA (Sig GhcRn)])
    forall a. a -> Maybe a
    Just (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)
    bind, SrcSpanAnnN -> SrcSpan
    forall a. HasLoc a => a -> SrcSpan
    locA SrcSpanAnnN
    bndr_loc, [LSig GhcRn]
    [GenLocated SrcSpanAnnA (Sig GhcRn)]
    prags)
        f GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)
    _other = Maybe
      (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn), SrcSpan,
       [GenLocated SrcSpanAnnA (Sig GhcRn)])
    forall a. Maybe a
    Nothing

    ---------------------------
    findMinimalDef :: [LSig GhcRn] -> Maybe ClassMinimalDef
    findMinimalDef :: [LSig GhcRn] -> Maybe (BooleanFormula GhcRn)
    findMinimalDef = [Maybe (BooleanFormula GhcRn)] -> Maybe (BooleanFormula GhcRn)
    forall (f :: * -> *) a. Foldable f => f (Maybe a) -> Maybe a
    firstJusts ([Maybe (BooleanFormula GhcRn)] -> Maybe (BooleanFormula GhcRn))
    -> ([GenLocated SrcSpanAnnA (Sig GhcRn)]
        -> [Maybe (BooleanFormula GhcRn)])
    -> [GenLocated SrcSpanAnnA (Sig GhcRn)]
    -> Maybe (BooleanFormula GhcRn)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (GenLocated SrcSpanAnnA (Sig GhcRn)
     -> Maybe (BooleanFormula GhcRn))
    -> [GenLocated SrcSpanAnnA (Sig GhcRn)]
    -> [Maybe (BooleanFormula GhcRn)]
    forall a b. (a -> b) -> [a] -> [b]
    map LSig GhcRn -> Maybe (BooleanFormula GhcRn)
    GenLocated SrcSpanAnnA (Sig GhcRn) -> Maybe (BooleanFormula GhcRn)
    toMinimalDef
      where
        toMinimalDef :: LSig GhcRn -> Maybe ClassMinimalDef
        toMinimalDef :: LSig GhcRn -> Maybe (BooleanFormula GhcRn)
    toMinimalDef (L SrcSpanAnnA
    _ (MinimalSig XMinimalSig GhcRn
    _ (L SrcSpanAnnL
    _ BooleanFormula GhcRn
    bf))) = BooleanFormula GhcRn -> Maybe (BooleanFormula GhcRn)
    forall a. a -> Maybe a
    Just BooleanFormula GhcRn
    bf
        toMinimalDef LSig GhcRn
    _                             = Maybe (BooleanFormula GhcRn)
    forall a. Maybe a
    Nothing

    {-
    Note [Polymorphic methods]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~
    Consider
        class Foo a where
            op :: forall b. Ord b => a -> b -> b -> b
        instance Foo c => Foo [c] where
            op = e

    When typechecking the binding 'op = e', we'll have a meth_id for op
    whose type is
          op :: forall c. Foo c => forall b. Ord b => [c] -> b -> b -> b

    So tcPolyBinds must be capable of dealing with nested polytypes;
    and so it is. See GHC.Tc.Gen.Bind.tcMonoBinds (with type-sig case).

    Note [Silly default-method bind]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    When we pass the default method binding to the type checker, it must
    look like    op2 = e
    not          $dmop2 = e
    otherwise the "$dm" stuff comes out error messages.  But we want the
    "$dm" to come out in the interface file.  So we typecheck the former,
    and wrap it in a let, thus
              $dmop2 = let op2 = e in op2
    This makes the error messages right.

    ************************************************************************
    *                                                                      *
                    Error messages
    *                                                                      *
    ************************************************************************
    -}

    {-
    badGenericInstanceType :: LHsBinds Name -> SDoc
    badGenericInstanceType binds
      = vcat [text "Illegal type pattern in the generic bindings",
              nest 2 (ppr binds)]

    missingGenericInstances :: [Name] -> SDoc
    missingGenericInstances missing
      = text "Missing type patterns for" <+> pprQuotedList missing

    dupGenericInsts :: [(TyCon, InstInfo a)] -> SDoc
    dupGenericInsts tc_inst_infos
      = vcat [text "More than one type pattern for a single generic type constructor:",
              nest 2 (vcat (map ppr_inst_ty tc_inst_infos)),
              text "All the type patterns for a generic type constructor must be identical"
        ]
      where
        ppr_inst_ty (_,inst) = ppr (simpleInstInfoTy inst)
    -}

    badDmPrag :: TcId -> Sig GhcRn -> TcM ()
    badDmPrag :: TcId -> Sig GhcRn -> TcRn ()
    badDmPrag TcId
    sel_id Sig GhcRn
    prag
      = TcRnMessage -> TcRn ()
    addErrTc (TcId -> Sig GhcRn -> TcRnMessage
    TcRnDefaultMethodForPragmaLacksBinding TcId
    sel_id Sig GhcRn
    prag)

    instDeclCtxt1 :: LHsSigType GhcRn -> ErrCtxtMsg
    instDeclCtxt1 :: LHsSigType GhcRn -> ErrCtxtMsg
    instDeclCtxt1 LHsSigType GhcRn
    hs_inst_ty
      = Either (LHsType GhcRn) Type -> ErrCtxtMsg
    InstDeclErrCtxt (LHsType GhcRn -> Either (LHsType GhcRn) Type
    forall a b. a -> Either a b
    Left (LHsType GhcRn -> Either (LHsType GhcRn) Type)
    -> LHsType GhcRn -> Either (LHsType GhcRn) Type
    forall a b. (a -> b) -> a -> b
    $ LHsSigType GhcRn -> LHsType GhcRn
    forall (p :: Pass). LHsSigType (GhcPass p) -> LHsType (GhcPass p)
    getLHsInstDeclHead LHsSigType GhcRn
    hs_inst_ty)

    instDeclCtxt2 :: Type -> ErrCtxtMsg
    instDeclCtxt2 :: Type -> ErrCtxtMsg
    instDeclCtxt2 Type
    dfun_ty
      = Class -> [Type] -> ErrCtxtMsg
    instDeclCtxt3 Class
    cls [Type]
    tys
      where
        ([TcId]
    _,[Type]
    _,Class
    cls,[Type]
    tys) = Type -> ([TcId], [Type], Class, [Type])
    tcSplitDFunTy Type
    dfun_ty

    instDeclCtxt3 :: Class -> [Type] -> ErrCtxtMsg
    instDeclCtxt3 :: Class -> [Type] -> ErrCtxtMsg
    instDeclCtxt3 Class
    cls [Type]
    cls_tys
      = Either (LHsType GhcRn) Type -> ErrCtxtMsg
    InstDeclErrCtxt (Type -> Either (LHsType GhcRn) Type
    forall a b. b -> Either a b
    Right (Type -> Either (LHsType GhcRn) Type)
    -> Type -> Either (LHsType GhcRn) Type
    forall a b. (a -> b) -> a -> b
    $ Class -> [Type] -> Type
    mkClassPred Class
    cls [Type]
    cls_tys)

    tcATDefault :: SrcSpan
                -> Subst
                -> NameSet
                -> ClassATItem
                -> TcM [FamInst]
    -- ^ Construct default instances for any associated types that
    -- aren't given a user definition
    -- Returns [] or singleton
    tcATDefault :: SrcSpan -> Subst -> NameSet -> ClassATItem -> TcM [FamInst]
    tcATDefault SrcSpan
    loc Subst
    inst_subst NameSet
    defined_ats (ATI TyCon
    fam_tc Maybe (Type, TyFamEqnValidityInfo)
    defs)
      -- User supplied instances ==> everything is OK
      | TyCon -> Name
    tyConName TyCon
    fam_tc Name -> NameSet -> Bool
    `elemNameSet` NameSet
    defined_ats
      = [FamInst] -> TcM [FamInst]
    forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return []

      -- No user instance, have defaults ==> instantiate them
       -- Example:   class C a where { type F a b :: *; type F a b = () }
       --            instance C [x]
       -- Then we want to generate the decl:   type F [x] b = ()
      | Just (Type
    rhs_ty, TyFamEqnValidityInfo
    _loc) <- Maybe (Type, TyFamEqnValidityInfo)
    defs
      = do { let (Subst
    subst', [Type]
    pat_tys') = Subst -> [TcId] -> (Subst, [Type])
    substATBndrs Subst
    inst_subst (TyCon -> [TcId]
    tyConTyVars TyCon
    fam_tc)
                 rhs' :: Type
    rhs'     = Subst -> Type -> Type
    substTyUnchecked Subst
    subst' Type
    rhs_ty
                 tcv' :: [TcId]
    tcv' = [Type] -> [TcId]
    tyCoVarsOfTypesList [Type]
    pat_tys'
                 ([TcId]
    tv', [TcId]
    cv') = (TcId -> Bool) -> [TcId] -> ([TcId], [TcId])
    forall a. (a -> Bool) -> [a] -> ([a], [a])
    partition TcId -> Bool
    isTyVar [TcId]
    tcv'
                 tvs' :: [TcId]
    tvs'     = [TcId] -> [TcId]
    scopedSort [TcId]
    tv'
                 cvs' :: [TcId]
    cvs'     = [TcId] -> [TcId]
    scopedSort [TcId]
    cv'
           ; rep_tc_name <- GenLocated SrcSpanAnnN Name -> [Type] -> TcM Name
    newFamInstTyConName (SrcSpanAnnN -> Name -> GenLocated SrcSpanAnnN Name
    forall l e. l -> e -> GenLocated l e
    L (SrcSpan -> SrcSpanAnnN
    forall e. HasAnnotation e => SrcSpan -> e
    noAnnSrcSpan SrcSpan
    loc) (TyCon -> Name
    tyConName TyCon
    fam_tc)) [Type]
    pat_tys'
           ; let axiom = Role
    -> Name
    -> [TcId]
    -> [TcId]
    -> [TcId]
    -> TyCon
    -> [Type]
    -> Type
    -> CoAxiom Unbranched
    mkSingleCoAxiom Role
    Nominal Name
    rep_tc_name [TcId]
    tvs' [] [TcId]
    cvs'
                                         TyCon
    fam_tc [Type]
    pat_tys' Type
    rhs'
               -- NB: no validity check. We check validity of default instances
               -- in the class definition. Because type instance arguments cannot
               -- be type family applications and cannot be polytypes, the
               -- validity check is redundant.

           ; traceTc "mk_deflt_at_instance" (vcat [ ppr fam_tc, ppr rhs_ty
                                                  , pprCoAxiom axiom ])
           ; fam_inst <- newFamInst SynFamilyInst axiom
           ; return [fam_inst] }

       -- No defaults ==> generate a warning
      | Bool
    otherwise  -- defs = Nothing
      = do { Name -> TcRn ()
    warnMissingAT (TyCon -> Name
    tyConName TyCon
    fam_tc)
           ; [FamInst] -> TcM [FamInst]
    forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return [] }

    -- | Apply a substitution to the type variable binders of an associated type
    -- family. This is used to compute default instances for associated type
    -- families (see 'tcATDefault') as well as @newtype@-derived associated type
    -- family instances (see @gen_Newtype_fam_insts@ in "GHC.Tc.Deriv.Generate").
    --
    -- As a concrete example, consider the following class and associated type
    -- family:
    --
    -- @
    --   class C k (a :: k) where
    --     type F k a (b :: k) :: Type
    --     type F j p q = (Proxy @j p, Proxy @j (q :: j))
    -- @
    --
    -- If a user defines this instance:
    --
    -- @
    -- instance C (Type -> Type) Maybe where {}
    -- @
    --
    -- Then in order to typecheck the default @F@ instance, we must apply the
    -- substitution @[k :-> (Type -> Type), a :-> Maybe]@ to @F@'s binders, which
    -- are @[k, a, (b :: k)]@. The result should look like this:
    --
    -- @
    --   type F (Type -> Type) Maybe (b :: Type -> Type) =
    --     (Proxy @(Type -> Type) Maybe, Proxy @(Type -> Type) (b :: Type -> Type))
    -- @
    --
    -- Making this work requires some care. There are two cases:
    --
    -- 1. If we encounter a type variable in the domain of the substitution (e.g.,
    --    @k@ or @a@), then we apply the substitution directly.
    --
    -- 2. Otherwise, we substitute into the type variable's kind (e.g., turn
    --    @b :: k@ to @b :: Type -> Type@). We then return an extended substitution
    --    where the old @b@ (of kind @k@) maps to the new @b@ (of kind @Type -> Type@).
    --
    --    This step is important to do in case there are later occurrences of @b@,
    --    which we must ensure have the correct kind. Otherwise, we might end up
    --    with @Proxy \@(Type -> Type) (b :: k)@ on the right-hand side of the
    --    default instance, which would be completely wrong.
    --
    -- Contrast 'substATBndrs' function with similar substitution functions:
    --
    -- * 'substTyVars' does not substitute into the kinds of each type variable,
    --   nor does it extend the substitution. 'substTyVars' is meant for occurrences
    --   of type variables, whereas 'substATBndr's is meant for binders.
    --
    -- * 'substTyVarBndrs' does substitute into kinds and extends the substitution,
    --   but it does not apply the substitution to the variables themselves. As
    --   such, 'substTyVarBndrs' returns a list of 'TyVar's rather than a list of
    --   'Type's.
    substATBndrs :: Subst -> [TyVar] -> (Subst, [Type])
    substATBndrs :: Subst -> [TcId] -> (Subst, [Type])
    substATBndrs = (Subst -> TcId -> (Subst, Type))
    -> Subst -> [TcId] -> (Subst, [Type])
    forall (t :: * -> *) s a b.
    Traversable t =>
    (s -> a -> (s, b)) -> s -> t a -> (s, t b)
    mapAccumL Subst -> TcId -> (Subst, Type)
    substATBndr
      where
        substATBndr :: Subst -> TyVar -> (Subst, Type)
        substATBndr :: Subst -> TcId -> (Subst, Type)
    substATBndr Subst
    subst TcId
    tc_tv
            -- Case (1) in the Haddocks
          | Just Type
    ty <- VarEnv Type -> TcId -> Maybe Type
    forall a. VarEnv a -> TcId -> Maybe a
    lookupVarEnv (Subst -> VarEnv Type
    getTvSubstEnv Subst
    subst) TcId
    tc_tv
          = (Subst
    subst, Type
    ty)
            -- Case (2) in the Haddocks
          | Bool
    otherwise
          = (Subst -> TcId -> TcId -> Subst
    extendTvSubstWithClone Subst
    subst TcId
    tc_tv TcId
    tc_tv', TcId -> Type
    mkTyVarTy TcId
    tc_tv')
          where
            tc_tv' :: TcId
    tc_tv' = (Type -> Type) -> TcId -> TcId
    updateTyVarKind (HasDebugCallStack => Subst -> Type -> Type
    Subst -> Type -> Type
    substTy Subst
    subst) TcId
    tc_tv

    warnMissingAT :: Name -> TcM ()
    warnMissingAT :: Name -> TcRn ()
    warnMissingAT Name
    name
      = do { warn <- WarningFlag -> TcRnIf TcGblEnv TcLclEnv Bool
    forall gbl lcl. WarningFlag -> TcRnIf gbl lcl Bool
    woptM WarningFlag
    Opt_WarnMissingMethods
           ; traceTc "warn" (ppr name <+> ppr warn)
           ; hsc_src <- fmap tcg_src getGblEnv
           -- hs-boot and signatures never need to provide complete "definitions"
           -- of any sort, as they aren't really defining anything, but just
           -- constraining items which are defined elsewhere.
           ; let diag = IllegalInstanceReason -> TcRnMessage
    TcRnIllegalInstance (IllegalInstanceReason -> TcRnMessage)
    -> IllegalInstanceReason -> TcRnMessage
    forall a b. (a -> b) -> a -> b
    $ IllegalFamilyInstanceReason -> IllegalInstanceReason
    IllegalFamilyInstance
                      (IllegalFamilyInstanceReason -> IllegalInstanceReason)
    -> IllegalFamilyInstanceReason -> IllegalInstanceReason
    forall a b. (a -> b) -> a -> b
    $ InvalidAssoc -> IllegalFamilyInstanceReason
    InvalidAssoc (InvalidAssoc -> IllegalFamilyInstanceReason)
    -> InvalidAssoc -> IllegalFamilyInstanceReason
    forall a b. (a -> b) -> a -> b
    $ InvalidAssocInstance -> InvalidAssoc
    InvalidAssocInstance
                      (InvalidAssocInstance -> InvalidAssoc)
    -> InvalidAssocInstance -> InvalidAssoc
    forall a b. (a -> b) -> a -> b
    $ Name -> InvalidAssocInstance
    AssocInstanceMissing Name
    name
           ; diagnosticTc  (warn && hsc_src == HsSrcFile) diag
                           }