{-
(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
   , badMethodErr
   , instDeclCtxt1
   , instDeclCtxt2
   , instDeclCtxt3
   , tcATDefault
   )
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( tcSuperSkolTyVars )
import GHC.Tc.Gen.HsType
import GHC.Tc.Utils.TcMType
import GHC.Core.Type     ( piResultTys )
import GHC.Core.Predicate
import GHC.Core.Multiplicity
import GHC.Tc.Types.Origin
import GHC.Tc.Utils.TcType
import GHC.Tc.Utils.Monad
import GHC.Tc.TyCl.Build( TcMethInfo )
import GHC.Core.Class
import GHC.Core.Coercion ( pprCoAxiom )
import GHC.Driver.Session
import GHC.Tc.Instance.Family
import GHC.Core.FamInstEnv
import GHC.Types.Error
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
import GHC.Types.SourceFile (HscSource(..))
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import GHC.Types.SrcLoc
import GHC.Core.TyCon
import GHC.Data.Maybe
import GHC.Types.Basic
import GHC.Data.Bag
import GHC.Data.BooleanFormula

import Control.Monad
import Data.List ( mapAccumL, partition )

{-
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 synomym:
        DictTy c t = TyConTy CDict `AppTy` t

Death to "ExpandingDicts".


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

illegalHsigDefaultMethod :: Name -> TcRnMessage
illegalHsigDefaultMethod :: Name -> TcRnMessage
illegalHsigDefaultMethod Name
n = DiagnosticMessage -> TcRnMessage
forall a. (Diagnostic a, Typeable a) => a -> TcRnMessage
TcRnUnknownMessage (DiagnosticMessage -> TcRnMessage)
-> DiagnosticMessage -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints (SDoc -> DiagnosticMessage) -> SDoc -> DiagnosticMessage
forall a b. (a -> b) -> a -> b
$
    String -> SDoc
text String
"Illegal default method(s) in class definition of" SDoc -> SDoc -> SDoc
<+> Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
n SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"in hsig file"

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

       ; [(Name, (SrcSpan, Type))]
gen_dm_prs <- (Located
   ([GenLocated SrcSpanAnnN Name],
    GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed)))
 -> IOEnv (Env TcGblEnv TcLclEnv) [(Name, (SrcSpan, Type))])
-> [Located
      ([GenLocated SrcSpanAnnN Name],
       GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed)))]
-> IOEnv (Env TcGblEnv TcLclEnv) [(Name, (SrcSpan, Type))]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM ((([GenLocated SrcSpanAnnN Name],
  GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed)))
 -> IOEnv (Env TcGblEnv TcLclEnv) [(Name, (SrcSpan, Type))])
-> Located
     ([GenLocated SrcSpanAnnN Name],
      GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed)))
-> IOEnv (Env TcGblEnv TcLclEnv) [(Name, (SrcSpan, Type))]
forall a b. (a -> TcM b) -> Located a -> TcM b
addLocM ([GenLocated SrcSpanAnnN Name], LHsSigType (GhcPass 'Renamed))
-> IOEnv (Env TcGblEnv TcLclEnv) [(Name, (SrcSpan, Type))]
([GenLocated SrcSpanAnnN Name],
 GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed)))
-> IOEnv (Env TcGblEnv TcLclEnv) [(Name, (SrcSpan, Type))]
tc_gen_sig) [Located
   ([GenLocated SrcSpanAnnN Name], LHsSigType (GhcPass 'Renamed))]
[Located
   ([GenLocated SrcSpanAnnN Name],
    GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed)))]
gen_sigs
       ; let gen_dm_env :: NameEnv (SrcSpan, Type)
             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

       ; [TcMethInfo]
op_info <- (Located
   ([GenLocated SrcSpanAnnN Name],
    GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed)))
 -> TcM [TcMethInfo])
-> [Located
      ([GenLocated SrcSpanAnnN Name],
       GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed)))]
-> TcM [TcMethInfo]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM ((([GenLocated SrcSpanAnnN Name],
  GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed)))
 -> TcM [TcMethInfo])
-> Located
     ([GenLocated SrcSpanAnnN Name],
      GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed)))
-> TcM [TcMethInfo]
forall a b. (a -> TcM b) -> Located a -> TcM b
addLocM (NameEnv (SrcSpan, Type)
-> ([GenLocated SrcSpanAnnN Name], LHsSigType (GhcPass 'Renamed))
-> TcM [TcMethInfo]
tc_sig NameEnv (SrcSpan, Type)
gen_dm_env)) [Located
   ([GenLocated SrcSpanAnnN Name], LHsSigType (GhcPass 'Renamed))]
[Located
   ([GenLocated SrcSpanAnnN Name],
    GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed)))]
vanilla_sigs

       ; let op_names :: NameSet
op_names = [Name] -> NameSet
mkNameSet [ Name
n | (Name
n,Type
_,Maybe (DefMethSpec (SrcSpan, Type))
_) <- [TcMethInfo]
op_info ]
       ; [IOEnv (Env TcGblEnv TcLclEnv) Any] -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [ TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) Any
forall a. TcRnMessage -> TcM a
failWithTc (Name -> Name -> TcRnMessage
forall a. Outputable a => a -> Name -> TcRnMessage
badMethodErr Name
clas Name
n)
                   | Name
n <- [Name]
dm_bind_names, Bool -> Bool
not (Name
n Name -> NameSet -> Bool
`elemNameSet` NameSet
op_names) ]
                   -- Value binding for non class-method (ie no TypeSig)

       ; TcGblEnv
tcg_env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
       ; if TcGblEnv -> HscSource
tcg_src TcGblEnv
tcg_env HscSource -> HscSource -> Bool
forall a. Eq a => a -> a -> Bool
== HscSource
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.)
               Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bag
  (GenLocated
     SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)))
-> Bool
forall a. Bag a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null LHsBinds (GhcPass 'Renamed)
Bag
  (GenLocated
     SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)))
def_methods)) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
                TcRnMessage -> TcRn ()
forall a. TcRnMessage -> TcM a
failWithTc (Name -> TcRnMessage
illegalHsigDefaultMethod Name
clas)
            else
               -- Error for each generic signature without value binding
               [IOEnv (Env TcGblEnv TcLclEnv) Any] -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [ TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) Any
forall a. TcRnMessage -> TcM a
failWithTc (Name -> Name -> TcRnMessage
forall a. Outputable a => a -> Name -> TcRnMessage
badGenericMethod Name
clas Name
n)
                         | (Name
n,(SrcSpan, Type)
_) <- [(Name, (SrcSpan, Type))]
gen_dm_prs, Bool -> Bool
not (Name
n 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) ]

       ; String -> SDoc -> TcRn ()
traceTc String
"tcClassSigs 2" (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
clas)
       ; [TcMethInfo] -> TcM [TcMethInfo]
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return [TcMethInfo]
op_info }
  where
    vanilla_sigs :: [Located ([LocatedN Name], LHsSigType GhcRn)] -- AZ temp
    vanilla_sigs :: [Located
   ([GenLocated SrcSpanAnnN Name], LHsSigType (GhcPass 'Renamed))]
vanilla_sigs = [SrcSpan
-> ([GenLocated SrcSpanAnnN Name],
    GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed)))
-> Located
     ([GenLocated SrcSpanAnnN Name],
      GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed)))
forall l e. l -> e -> GenLocated l e
L (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc) ([LIdP (GhcPass 'Renamed)]
[GenLocated SrcSpanAnnN Name]
nm,LHsSigType (GhcPass 'Renamed)
GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed))
ty) | L SrcSpanAnnA
loc (ClassOpSig XClassOpSig (GhcPass 'Renamed)
_ Bool
False [LIdP (GhcPass 'Renamed)]
nm LHsSigType (GhcPass 'Renamed)
ty) <- [LSig (GhcPass 'Renamed)]
[GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed))]
sigs]
    gen_sigs :: [Located ([LocatedN Name], LHsSigType GhcRn)] -- AZ temp
    gen_sigs :: [Located
   ([GenLocated SrcSpanAnnN Name], LHsSigType (GhcPass 'Renamed))]
gen_sigs     = [SrcSpan
-> ([GenLocated SrcSpanAnnN Name],
    GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed)))
-> Located
     ([GenLocated SrcSpanAnnN Name],
      GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed)))
forall l e. l -> e -> GenLocated l e
L (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc) ([LIdP (GhcPass 'Renamed)]
[GenLocated SrcSpanAnnN Name]
nm,LHsSigType (GhcPass 'Renamed)
GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed))
ty) | L SrcSpanAnnA
loc (ClassOpSig XClassOpSig (GhcPass 'Renamed)
_ Bool
True  [LIdP (GhcPass 'Renamed)]
nm LHsSigType (GhcPass 'Renamed)
ty) <- [LSig (GhcPass 'Renamed)]
[GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed))]
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}) <- Bag
  (GenLocated
     SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)))
-> [GenLocated
      SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed))]
forall a. Bag a -> [a]
bagToList LHsBinds (GhcPass 'Renamed)
Bag
  (GenLocated
     SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)))
def_methods]

    tc_sig :: NameEnv (SrcSpan, Type) -> ([LocatedN Name], LHsSigType GhcRn)
           -> TcM [TcMethInfo]
    tc_sig :: NameEnv (SrcSpan, Type)
-> ([GenLocated SrcSpanAnnN Name], LHsSigType (GhcPass 'Renamed))
-> TcM [TcMethInfo]
tc_sig NameEnv (SrcSpan, Type)
gen_dm_env ([GenLocated SrcSpanAnnN Name]
op_names, LHsSigType (GhcPass 'Renamed)
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)
           ; Type
op_ty <- [GenLocated SrcSpanAnnN Name]
-> LHsSigType (GhcPass 'Renamed) -> TcM Type
tcClassSigType [GenLocated SrcSpanAnnN Name]
op_names LHsSigType (GhcPass 'Renamed)
op_hs_ty
                   -- Class tyvars already in scope

           ; String -> SDoc -> TcRn ()
traceTc String
"ClsSig 2" ([GenLocated SrcSpanAnnN Name] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [GenLocated SrcSpanAnnN Name]
op_names SDoc -> SDoc -> SDoc
$$ Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
op_ty)
           ; [TcMethInfo] -> TcM [TcMethInfo]
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return [ (Name
op_name, Type
op_ty, Name -> Maybe (DefMethSpec (SrcSpan, Type))
f Name
op_name) | L SrcSpanAnnN
_ Name
op_name <- [GenLocated SrcSpanAnnN 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 (GhcPass 'Renamed))
-> IOEnv (Env TcGblEnv TcLclEnv) [(Name, (SrcSpan, Type))]
tc_gen_sig ([GenLocated SrcSpanAnnN Name]
op_names, LHsSigType (GhcPass 'Renamed)
gen_hs_ty)
      = do { Type
gen_op_ty <- [GenLocated SrcSpanAnnN Name]
-> LHsSigType (GhcPass 'Renamed) -> TcM Type
tcClassSigType [GenLocated SrcSpanAnnN Name]
op_names LHsSigType (GhcPass 'Renamed)
gen_hs_ty
           ; [(Name, (SrcSpan, Type))]
-> IOEnv (Env TcGblEnv TcLclEnv) [(Name, (SrcSpan, Type))]
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return [ (Name
op_name, (SrcSpanAnnN -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnN
loc, Type
gen_op_ty))
                                                 | L SrcSpanAnnN
loc Name
op_name <- [GenLocated SrcSpanAnnN Name]
op_names ] }

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

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

tcClassDecl2 :: LTyClDecl (GhcPass 'Renamed) -> TcM (LHsBinds GhcTc)
tcClassDecl2 (L SrcSpanAnnA
_ (ClassDecl {tcdLName :: forall pass. TyClDecl pass -> LIdP pass
tcdLName = LIdP (GhcPass 'Renamed)
class_name, tcdSigs :: forall pass. TyClDecl pass -> [LSig pass]
tcdSigs = [LSig (GhcPass 'Renamed)]
sigs,
                                tcdMeths :: forall pass. TyClDecl pass -> LHsBinds pass
tcdMeths = LHsBinds (GhcPass 'Renamed)
default_binds}))
  = TcM (LHsBinds GhcTc)
-> TcM (LHsBinds GhcTc) -> TcM (LHsBinds GhcTc)
forall r. TcRn r -> TcRn r -> TcRn r
recoverM (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return LHsBinds GhcTc
Bag (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. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA LIdP (GhcPass 'Renamed)
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  { Class
clas <- LocatedA Name -> TcM Class
tcLookupLocatedClass (GenLocated SrcSpanAnnN Name -> LocatedA Name
forall a. LocatedN a -> LocatedA a
n2l LIdP (GhcPass 'Renamed)
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

        ; SkolemInfo
skol_info <- SkolemInfoAnon -> IOEnv (Env TcGblEnv TcLclEnv) SkolemInfo
forall (m :: * -> *). MonadIO m => SkolemInfoAnon -> m SkolemInfo
mkSkolemInfo (TyConFlavour -> Name -> SkolemInfoAnon
TyConSkol TyConFlavour
ClassFlavour (GenLocated SrcSpanAnnN Name -> Name
forall a. NamedThing a => a -> Name
getName LIdP (GhcPass 'Renamed)
GenLocated SrcSpanAnnN Name
class_name))
        ; TcLevel
tc_lvl    <- TcM TcLevel
getTcLevel
        ; let ([TcId]
tyvars, [Type]
_, [TcId]
_, [ClassOpItem]
op_items) = Class -> ([TcId], [Type], [TcId], [ClassOpItem])
classBigSig Class
clas
              prag_fn :: TcPragEnv
prag_fn = [LSig (GhcPass 'Renamed)]
-> LHsBinds (GhcPass 'Renamed) -> TcPragEnv
mkPragEnv [LSig (GhcPass 'Renamed)]
sigs LHsBinds (GhcPass 'Renamed)
default_binds
              sig_fn :: HsSigFun
sig_fn  = [LSig (GhcPass 'Renamed)] -> HsSigFun
mkHsSigFun [LSig (GhcPass 'Renamed)]
sigs
              (TCvSubst
_skol_subst, [TcId]
clas_tyvars) = TcLevel -> SkolemInfo -> [TcId] -> (TCvSubst, [TcId])
tcSuperSkolTyVars TcLevel
tc_lvl SkolemInfo
skol_info [TcId]
tyvars
                    -- This make skolemTcTyVars, but does not clone,
                    -- so we can put them in scope with tcExtendTyVarEnv
              pred :: Type
pred = Class -> [Type] -> Type
mkClassPred Class
clas ([TcId] -> [Type]
mkTyVarTys [TcId]
clas_tyvars)
        ; TcId
this_dict <- Type -> TcRnIf TcGblEnv TcLclEnv TcId
forall gbl lcl. Type -> TcRnIf gbl lcl TcId
newEvVar Type
pred

        ; let tc_item :: ClassOpItem -> TcM (LHsBinds GhcTc)
tc_item = Class
-> [TcId]
-> TcId
-> LHsBinds (GhcPass 'Renamed)
-> HsSigFun
-> TcPragEnv
-> ClassOpItem
-> TcM (LHsBinds GhcTc)
tcDefMeth Class
clas [TcId]
clas_tyvars TcId
this_dict
                                  LHsBinds (GhcPass 'Renamed)
default_binds HsSigFun
sig_fn TcPragEnv
prag_fn
        ; [Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))]
dm_binds <- [TcId]
-> TcM [Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))]
-> TcM [Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))]
forall r. [TcId] -> TcM r -> TcM r
tcExtendTyVarEnv [TcId]
clas_tyvars (TcM [Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))]
 -> TcM [Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))])
-> TcM [Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))]
-> TcM [Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))]
forall a b. (a -> b) -> a -> b
$
                      (ClassOpItem
 -> IOEnv
      (Env TcGblEnv TcLclEnv)
      (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))))
-> [ClassOpItem]
-> TcM [Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))]
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 ClassOpItem -> TcM (LHsBinds GhcTc)
ClassOpItem
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
tc_item [ClassOpItem]
op_items

        ; Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))]
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
forall a. [Bag a] -> Bag a
unionManyBags [Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))]
dm_binds) }

tcClassDecl2 LTyClDecl (GhcPass 'Renamed)
d = String
-> SDoc
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcClassDecl2" (GenLocated SrcSpanAnnA (TyClDecl (GhcPass 'Renamed)) -> SDoc
forall a. Outputable a => a -> SDoc
ppr LTyClDecl (GhcPass 'Renamed)
GenLocated SrcSpanAnnA (TyClDecl (GhcPass 'Renamed))
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 (GhcPass 'Renamed)
-> HsSigFun
-> TcPragEnv
-> ClassOpItem
-> TcM (LHsBinds GhcTc)
tcDefMeth Class
_ [TcId]
_ TcId
_ LHsBinds (GhcPass 'Renamed)
_ HsSigFun
_ TcPragEnv
prag_fn (TcId
sel_id, Maybe (Name, DefMethSpec Type)
Nothing)
  = do { -- No default method
         (GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed)) -> TcRn ())
-> [GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed))] -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((Sig (GhcPass 'Renamed) -> TcRn ())
-> GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed)) -> TcRn ()
forall a b ann.
(a -> TcM b) -> GenLocated (SrcSpanAnn' ann) a -> TcM b
addLocMA (TcId -> Sig (GhcPass 'Renamed) -> TcRn ()
badDmPrag TcId
sel_id))
               (TcPragEnv -> Name -> [LSig (GhcPass 'Renamed)]
lookupPragEnv TcPragEnv
prag_fn (TcId -> Name
idName TcId
sel_id))
       ; Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
forall a. Bag a
emptyBag }

tcDefMeth Class
clas [TcId]
tyvars TcId
this_dict LHsBinds (GhcPass 'Renamed)
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 (GhcPass 'Renamed) (GhcPass 'Renamed)
dm_bind, SrcSpan
bndr_loc, [LSig (GhcPass 'Renamed)]
prags) <- Name
-> LHsBinds (GhcPass 'Renamed)
-> TcPragEnv
-> Maybe
     (LHsBind (GhcPass 'Renamed), SrcSpan, [LSig (GhcPass 'Renamed)])
findMethodBind Name
sel_name LHsBinds (GhcPass 'Renamed)
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

         TcId
global_dm_id  <- Name -> TcRnIf TcGblEnv TcLclEnv TcId
tcLookupId Name
dm_name
       ; TcId
global_dm_id  <- TcId -> [LSig (GhcPass 'Renamed)] -> TcRnIf TcGblEnv TcLclEnv TcId
addInlinePrags TcId
global_dm_id [LSig (GhcPass 'Renamed)]
prags
       ; Name
local_dm_name <- OccName -> SrcSpan -> TcM Name
newNameAt (Name -> OccName
forall a. NamedThing a => a -> OccName
getOccName Name
sel_name) SrcSpan
bndr_loc
            -- Base the local_dm_name on the selector name, because
            -- type errors from tcInstanceMethodBody come from here

       ; [LTcSpecPrag]
spec_prags <- TcM [LTcSpecPrag] -> TcM [LTcSpecPrag]
forall a. TcM a -> TcM a
discardConstraints (TcM [LTcSpecPrag] -> TcM [LTcSpecPrag])
-> TcM [LTcSpecPrag] -> TcM [LTcSpecPrag]
forall a b. (a -> b) -> a -> b
$
                       TcId -> [LSig (GhcPass 'Renamed)] -> TcM [LTcSpecPrag]
tcSpecPrags TcId
global_dm_id [LSig (GhcPass 'Renamed)]
prags
       ; let dia :: TcRnMessage
dia = DiagnosticMessage -> TcRnMessage
forall a. (Diagnostic a, Typeable a) => a -> TcRnMessage
TcRnUnknownMessage (DiagnosticMessage -> TcRnMessage)
-> DiagnosticMessage -> TcRnMessage
forall a b. (a -> b) -> a -> b
$
               DiagnosticReason -> [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainDiagnostic DiagnosticReason
WarningWithoutFlag [GhcHint]
noHints (SDoc -> DiagnosticMessage) -> SDoc -> DiagnosticMessage
forall a b. (a -> b) -> a -> b
$
                (String -> SDoc
text String
"Ignoring SPECIALISE pragmas on default method" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
sel_name))
       ; Bool -> TcRnMessage -> TcRn ()
diagnosticTc (Bool -> Bool
not ([LTcSpecPrag] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LTcSpecPrag]
spec_prags)) TcRnMessage
dia

       ; let hs_ty :: GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed))
hs_ty = HsSigFun
hs_sig_fn Name
sel_name
                     Maybe (GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed)))
-> GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed))
-> GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed))
forall a. Maybe a -> a -> a
`orElse` String
-> SDoc -> GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed))
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 :: Type
local_dm_ty = Class -> TcId -> [Type] -> Type
instantiateMethod Class
clas TcId
global_dm_id ([TcId] -> [Type]
mkTyVarTys [TcId]
tyvars)

             lm_bind :: HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)
lm_bind     = HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)
dm_bind { fun_id :: LIdP (GhcPass 'Renamed)
fun_id = SrcSpanAnnN -> Name -> GenLocated SrcSpanAnnN Name
forall l e. l -> e -> GenLocated l e
L (SrcSpanAnnA -> SrcSpanAnnN
forall a. SrcSpanAnn' a -> SrcSpanAnnN
la2na SrcSpanAnnA
bind_loc) Name
local_dm_name }
                             -- Substitute the local_meth_name for the binder
                             -- NB: the binding is always a FunBind

             warn_redundant :: ReportRedundantConstraints
warn_redundant = case DefMethSpec Type
dm_spec of
                                GenericDM {} -> LHsSigType (GhcPass 'Renamed) -> ReportRedundantConstraints
lhsSigTypeContextSpan LHsSigType (GhcPass 'Renamed)
GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed))
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 :: UserTypeCtxt
ctxt = Name -> ReportRedundantConstraints -> UserTypeCtxt
FunSigCtxt Name
sel_name ReportRedundantConstraints
warn_redundant

       ; let local_dm_id :: TcId
local_dm_id = (() :: Constraint) => Name -> Type -> Type -> TcId
Name -> Type -> Type -> TcId
mkLocalId Name
local_dm_name Type
Many Type
local_dm_ty
             local_dm_sig :: TcIdSigInfo
local_dm_sig = CompleteSig { sig_bndr :: TcId
sig_bndr = TcId
local_dm_id
                                        , sig_ctxt :: UserTypeCtxt
sig_ctxt  = UserTypeCtxt
ctxt
                                        , sig_loc :: SrcSpan
sig_loc   = GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed)) -> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed))
hs_ty }

       ; (TcEvBinds
ev_binds, (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
tc_bind, [TcId]
_))
               <- SkolemInfoAnon
-> [TcId]
-> [TcId]
-> TcM (LHsBinds GhcTc, [TcId])
-> TcM (TcEvBinds, (LHsBinds GhcTc, [TcId]))
forall result.
SkolemInfoAnon
-> [TcId] -> [TcId] -> TcM result -> TcM (TcEvBinds, result)
checkConstraints SkolemInfoAnon
skol_info [TcId]
tyvars [TcId
this_dict] (TcM (LHsBinds GhcTc, [TcId])
 -> TcM (TcEvBinds, (LHsBinds GhcTc, [TcId])))
-> TcM (LHsBinds GhcTc, [TcId])
-> TcM (TcEvBinds, (LHsBinds GhcTc, [TcId]))
forall a b. (a -> b) -> a -> b
$
                  TcPragEnv
-> TcIdSigInfo
-> LHsBind (GhcPass 'Renamed)
-> TcM (LHsBinds GhcTc, [TcId])
tcPolyCheck TcPragEnv
NameEnv [GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed))]
no_prag_fn TcIdSigInfo
local_dm_sig
                              (SrcSpanAnnA
-> HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)
-> GenLocated
     SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed))
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
bind_loc HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)
lm_bind)

       ; let export :: ABExport
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 :: HsBindLR GhcTc GhcTc
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
Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
tc_bind
                                  , abs_sig :: Bool
abs_sig      = Bool
True }

       ; Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
forall a. a -> Bag a
unitBag (SrcSpanAnnA
-> HsBindLR GhcTc GhcTc
-> GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
bind_loc HsBindLR GhcTc GhcTc
full_bind)) }

  | Bool
otherwise = String
-> SDoc
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (Bag (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 -> Name -> SkolemInfoAnon
TyConSkol TyConFlavour
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 (GhcPass 'Renamed)] -> [TcMethInfo] -> TcM ClassMinimalDef
tcClassMinimalDef Name
_clas [LSig (GhcPass 'Renamed)]
sigs [TcMethInfo]
op_info
  = case [LSig (GhcPass 'Renamed)] -> Maybe ClassMinimalDef
findMinimalDef [LSig (GhcPass 'Renamed)]
sigs of
      Maybe ClassMinimalDef
Nothing -> ClassMinimalDef -> TcM ClassMinimalDef
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ClassMinimalDef
defMindef
      Just ClassMinimalDef
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
        TcGblEnv
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.
        Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TcGblEnv -> HscSource
tcg_src TcGblEnv
tcg_env HscSource -> HscSource -> Bool
forall a. Eq a => a -> a -> Bool
/= HscSource
HsigFile) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
            Maybe ClassMinimalDef -> (ClassMinimalDef -> TcRn ()) -> TcRn ()
forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenIsJust ((Name -> Bool) -> ClassMinimalDef -> Maybe ClassMinimalDef
forall a.
Eq a =>
(a -> Bool) -> BooleanFormula a -> Maybe (BooleanFormula a)
isUnsatisfied (ClassMinimalDef
mindef ClassMinimalDef -> Name -> Bool
forall a. Eq a => BooleanFormula a -> a -> Bool
`impliesAtom`) ClassMinimalDef
defMindef) ((ClassMinimalDef -> TcRn ()) -> TcRn ())
-> (ClassMinimalDef -> TcRn ()) -> TcRn ()
forall a b. (a -> b) -> a -> b
$
                       (\ClassMinimalDef
bf -> TcRnMessage -> TcRn ()
addDiagnosticTc (ClassMinimalDef -> TcRnMessage
warningMinimalDefIncomplete ClassMinimalDef
bf))
        ClassMinimalDef -> TcM ClassMinimalDef
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ClassMinimalDef
mindef
  where
    -- By default require all methods without a default implementation
    defMindef :: ClassMinimalDef
    defMindef :: ClassMinimalDef
defMindef = [LBooleanFormula Name] -> ClassMinimalDef
forall a. Eq a => [LBooleanFormula a] -> BooleanFormula a
mkAnd [ ClassMinimalDef -> LBooleanFormula Name
forall a an. a -> LocatedAn an a
noLocA (Name -> ClassMinimalDef
forall a. a -> BooleanFormula a
mkVar 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 = (() :: Constraint) => 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 (GhcPass 'Renamed)] -> HsSigFun
mkHsSigFun [LSig (GhcPass 'Renamed)]
sigs = NameEnv (GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed)))
-> Name
-> Maybe (GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed)))
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv NameEnv (GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed)))
env
  where
    env :: NameEnv (GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed)))
env = (LSig (GhcPass 'Renamed)
 -> Maybe
      ([GenLocated SrcSpanAnnN Name],
       GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed))))
-> [LSig (GhcPass 'Renamed)]
-> NameEnv (GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed)))
forall a.
(LSig (GhcPass 'Renamed)
 -> Maybe ([GenLocated SrcSpanAnnN Name], a))
-> [LSig (GhcPass 'Renamed)] -> NameEnv a
mkHsSigEnv LSig (GhcPass 'Renamed)
-> Maybe
     ([GenLocated SrcSpanAnnN Name], LHsSigType (GhcPass 'Renamed))
LSig (GhcPass 'Renamed)
-> Maybe
     ([GenLocated SrcSpanAnnN Name],
      GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed)))
get_classop_sig [LSig (GhcPass 'Renamed)]
sigs

    get_classop_sig :: LSig GhcRn -> Maybe ([LocatedN Name], LHsSigType GhcRn)
    get_classop_sig :: LSig (GhcPass 'Renamed)
-> Maybe
     ([GenLocated SrcSpanAnnN Name], LHsSigType (GhcPass 'Renamed))
get_classop_sig  (L SrcSpanAnnA
_ (ClassOpSig XClassOpSig (GhcPass 'Renamed)
_ Bool
_ [LIdP (GhcPass 'Renamed)]
ns LHsSigType (GhcPass 'Renamed)
hs_ty)) = ([GenLocated SrcSpanAnnN Name],
 GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed)))
-> Maybe
     ([GenLocated SrcSpanAnnN Name],
      GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed)))
forall a. a -> Maybe a
Just ([LIdP (GhcPass 'Renamed)]
[GenLocated SrcSpanAnnN Name]
ns, LHsSigType (GhcPass 'Renamed)
GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed))
hs_ty)
    get_classop_sig  LSig (GhcPass 'Renamed)
_                               = Maybe
  ([GenLocated SrcSpanAnnN Name], LHsSigType (GhcPass 'Renamed))
Maybe
  ([GenLocated SrcSpanAnnN Name],
   GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed)))
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 (GhcPass 'Renamed)
-> TcPragEnv
-> Maybe
     (LHsBind (GhcPass 'Renamed), SrcSpan, [LSig (GhcPass 'Renamed)])
findMethodBind Name
sel_name LHsBinds (GhcPass 'Renamed)
binds TcPragEnv
prag_fn
  = (Maybe
   (GenLocated
      SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)),
    SrcSpan, [GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed))])
 -> Maybe
      (GenLocated
         SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)),
       SrcSpan, [GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed))])
 -> Maybe
      (GenLocated
         SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)),
       SrcSpan, [GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed))]))
-> Maybe
     (GenLocated
        SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)),
      SrcSpan, [GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed))])
-> Bag
     (Maybe
        (GenLocated
           SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)),
         SrcSpan, [GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed))]))
-> Maybe
     (GenLocated
        SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)),
      SrcSpan, [GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed))])
forall b a. (b -> a -> b) -> b -> Bag a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Maybe
  (GenLocated
     SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)),
   SrcSpan, [GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed))])
-> Maybe
     (GenLocated
        SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)),
      SrcSpan, [GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed))])
-> Maybe
     (GenLocated
        SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)),
      SrcSpan, [GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed))])
forall a. Maybe a -> Maybe a -> Maybe a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus Maybe
  (GenLocated
     SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)),
   SrcSpan, [GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed))])
forall a. Maybe a
Nothing ((GenLocated
   SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed))
 -> Maybe
      (GenLocated
         SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)),
       SrcSpan, [GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed))]))
-> Bag
     (GenLocated
        SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)))
-> Bag
     (Maybe
        (GenLocated
           SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)),
         SrcSpan, [GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed))]))
forall a b. (a -> b) -> Bag a -> Bag b
mapBag GenLocated
  SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed))
-> Maybe
     (GenLocated
        SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)),
      SrcSpan, [GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed))])
f LHsBinds (GhcPass 'Renamed)
Bag
  (GenLocated
     SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)))
binds)
  where
    prags :: [LSig (GhcPass 'Renamed)]
prags    = TcPragEnv -> Name -> [LSig (GhcPass 'Renamed)]
lookupPragEnv TcPragEnv
prag_fn Name
sel_name

    f :: GenLocated
  SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed))
-> Maybe
     (GenLocated
        SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)),
      SrcSpan, [GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed))])
f bind :: GenLocated
  SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed))
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 (GhcPass 'Renamed) (GhcPass 'Renamed)),
 SrcSpan, [GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed))])
-> Maybe
     (GenLocated
        SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)),
      SrcSpan, [GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed))])
forall a. a -> Maybe a
Just (GenLocated
  SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed))
bind, SrcSpanAnnN -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnN
bndr_loc, [LSig (GhcPass 'Renamed)]
[GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed))]
prags)
    f GenLocated
  SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed))
_other = Maybe
  (GenLocated
     SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)),
   SrcSpan, [GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed))])
forall a. Maybe a
Nothing

---------------------------
findMinimalDef :: [LSig GhcRn] -> Maybe ClassMinimalDef
findMinimalDef :: [LSig (GhcPass 'Renamed)] -> Maybe ClassMinimalDef
findMinimalDef = [Maybe ClassMinimalDef] -> Maybe ClassMinimalDef
forall (f :: * -> *) a. Foldable f => f (Maybe a) -> Maybe a
firstJusts ([Maybe ClassMinimalDef] -> Maybe ClassMinimalDef)
-> ([GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed))]
    -> [Maybe ClassMinimalDef])
-> [GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed))]
-> Maybe ClassMinimalDef
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed))
 -> Maybe ClassMinimalDef)
-> [GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed))]
-> [Maybe ClassMinimalDef]
forall a b. (a -> b) -> [a] -> [b]
map LSig (GhcPass 'Renamed) -> Maybe ClassMinimalDef
GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed))
-> Maybe ClassMinimalDef
toMinimalDef
  where
    toMinimalDef :: LSig GhcRn -> Maybe ClassMinimalDef
    toMinimalDef :: LSig (GhcPass 'Renamed) -> Maybe ClassMinimalDef
toMinimalDef (L SrcSpanAnnA
_ (MinimalSig XMinimalSig (GhcPass 'Renamed)
_ SourceText
_ (L SrcSpanAnnL
_ BooleanFormula (LIdP (GhcPass 'Renamed))
bf))) = ClassMinimalDef -> Maybe ClassMinimalDef
forall a. a -> Maybe a
Just ((GenLocated SrcSpanAnnN Name -> Name)
-> BooleanFormula (GenLocated SrcSpanAnnN Name) -> ClassMinimalDef
forall a b. (a -> b) -> BooleanFormula a -> BooleanFormula b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GenLocated SrcSpanAnnN Name -> Name
forall l e. GenLocated l e -> e
unLoc BooleanFormula (LIdP (GhcPass 'Renamed))
BooleanFormula (GenLocated SrcSpanAnnN Name)
bf)
    toMinimalDef LSig (GhcPass 'Renamed)
_                               = Maybe ClassMinimalDef
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
*                                                                      *
************************************************************************
-}

badMethodErr :: Outputable a => a -> Name -> TcRnMessage
badMethodErr :: forall a. Outputable a => a -> Name -> TcRnMessage
badMethodErr a
clas Name
op
  = DiagnosticMessage -> TcRnMessage
forall a. (Diagnostic a, Typeable a) => a -> TcRnMessage
TcRnUnknownMessage (DiagnosticMessage -> TcRnMessage)
-> DiagnosticMessage -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints (SDoc -> DiagnosticMessage) -> SDoc -> DiagnosticMessage
forall a b. (a -> b) -> a -> b
$
    [SDoc] -> SDoc
hsep [String -> SDoc
text String
"Class", SDoc -> SDoc
quotes (a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
clas),
          String -> SDoc
text String
"does not have a method", SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
op)]

badGenericMethod :: Outputable a => a -> Name -> TcRnMessage
badGenericMethod :: forall a. Outputable a => a -> Name -> TcRnMessage
badGenericMethod a
clas Name
op
  = DiagnosticMessage -> TcRnMessage
forall a. (Diagnostic a, Typeable a) => a -> TcRnMessage
TcRnUnknownMessage (DiagnosticMessage -> TcRnMessage)
-> DiagnosticMessage -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints (SDoc -> DiagnosticMessage) -> SDoc -> DiagnosticMessage
forall a b. (a -> b) -> a -> b
$
    [SDoc] -> SDoc
hsep [String -> SDoc
text String
"Class", SDoc -> SDoc
quotes (a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
clas),
          String -> SDoc
text String
"has a generic-default signature without a binding", SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
op)]

{-
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 (GhcPass 'Renamed) -> TcRn ()
badDmPrag TcId
sel_id Sig (GhcPass 'Renamed)
prag
  = TcRnMessage -> TcRn ()
addErrTc (DiagnosticMessage -> TcRnMessage
forall a. (Diagnostic a, Typeable a) => a -> TcRnMessage
TcRnUnknownMessage (DiagnosticMessage -> TcRnMessage)
-> DiagnosticMessage -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints (SDoc -> DiagnosticMessage) -> SDoc -> DiagnosticMessage
forall a b. (a -> b) -> a -> b
$
    String -> SDoc
text String
"The" SDoc -> SDoc -> SDoc
<+> Sig (GhcPass 'Renamed) -> SDoc
forall name. Sig name -> SDoc
hsSigDoc Sig (GhcPass 'Renamed)
prag SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"for default method"
              SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (TcId -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcId
sel_id)
              SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"lacks an accompanying binding")

warningMinimalDefIncomplete :: ClassMinimalDef -> TcRnMessage
warningMinimalDefIncomplete :: ClassMinimalDef -> TcRnMessage
warningMinimalDefIncomplete ClassMinimalDef
mindef
  = DiagnosticMessage -> TcRnMessage
forall a. (Diagnostic a, Typeable a) => a -> TcRnMessage
TcRnUnknownMessage (DiagnosticMessage -> TcRnMessage)
-> DiagnosticMessage -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ DiagnosticReason -> [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainDiagnostic DiagnosticReason
WarningWithoutFlag [GhcHint]
noHints (SDoc -> DiagnosticMessage) -> SDoc -> DiagnosticMessage
forall a b. (a -> b) -> a -> b
$
  [SDoc] -> SDoc
vcat [ String -> SDoc
text String
"The MINIMAL pragma does not require:"
         , Int -> SDoc -> SDoc
nest Int
2 (ClassMinimalDef -> SDoc
forall a. Outputable a => BooleanFormula a -> SDoc
pprBooleanFormulaNice ClassMinimalDef
mindef)
         , String -> SDoc
text String
"but there is no default implementation." ]

instDeclCtxt1 :: LHsSigType GhcRn -> SDoc
instDeclCtxt1 :: LHsSigType (GhcPass 'Renamed) -> SDoc
instDeclCtxt1 LHsSigType (GhcPass 'Renamed)
hs_inst_ty
  = SDoc -> SDoc
inst_decl_ctxt (GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed)) -> SDoc
forall a. Outputable a => a -> SDoc
ppr (LHsSigType (GhcPass 'Renamed) -> LHsType (GhcPass 'Renamed)
forall (p :: Pass). LHsSigType (GhcPass p) -> LHsType (GhcPass p)
getLHsInstDeclHead LHsSigType (GhcPass 'Renamed)
hs_inst_ty))

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

instDeclCtxt3 :: Class -> [Type] -> SDoc
instDeclCtxt3 :: Class -> [Type] -> SDoc
instDeclCtxt3 Class
cls [Type]
cls_tys
  = SDoc -> SDoc
inst_decl_ctxt (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Class -> [Type] -> Type
mkClassPred Class
cls [Type]
cls_tys))

inst_decl_ctxt :: SDoc -> SDoc
inst_decl_ctxt :: SDoc -> SDoc
inst_decl_ctxt SDoc
doc = SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"In the instance declaration for")
                        Int
2 (SDoc -> SDoc
quotes SDoc
doc)

tcATDefault :: SrcSpan
            -> TCvSubst
            -> NameSet
            -> ClassATItem
            -> TcM [FamInst]
-- ^ Construct default instances for any associated types that
-- aren't given a user definition
-- Returns [] or singleton
tcATDefault :: SrcSpan -> TCvSubst -> NameSet -> ClassATItem -> TcM [FamInst]
tcATDefault SrcSpan
loc TCvSubst
inst_subst NameSet
defined_ats (ATI TyCon
fam_tc Maybe (Type, ATValidityInfo)
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, ATValidityInfo
_loc) <- Maybe (Type, ATValidityInfo)
defs
  = do { let (TCvSubst
subst', [Type]
pat_tys') = (TCvSubst -> TcId -> (TCvSubst, Type))
-> TCvSubst -> [TcId] -> (TCvSubst, [Type])
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL TCvSubst -> TcId -> (TCvSubst, Type)
subst_tv TCvSubst
inst_subst
                                            (TyCon -> [TcId]
tyConTyVars TyCon
fam_tc)
             rhs' :: Type
rhs'     = TCvSubst -> Type -> Type
substTyUnchecked TCvSubst
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'
       ; Name
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 ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc) (TyCon -> Name
tyConName TyCon
fam_tc)) [Type]
pat_tys'
       ; let axiom :: CoAxiom Unbranched
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.

       ; String -> SDoc -> TcRn ()
traceTc String
"mk_deflt_at_instance" ([SDoc] -> SDoc
vcat [ TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
fam_tc, Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
rhs_ty
                                              , CoAxiom Unbranched -> SDoc
forall (br :: BranchFlag). CoAxiom br -> SDoc
pprCoAxiom CoAxiom Unbranched
axiom ])
       ; FamInst
fam_inst <- FamFlavor -> CoAxiom Unbranched -> TcM FamInst
newFamInst FamFlavor
SynFamilyInst CoAxiom Unbranched
axiom
       ; [FamInst] -> TcM [FamInst]
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return [FamInst
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 [] }
  where
    subst_tv :: TCvSubst -> TcId -> (TCvSubst, Type)
subst_tv TCvSubst
subst TcId
tc_tv
      | Just Type
ty <- VarEnv Type -> TcId -> Maybe Type
forall a. VarEnv a -> TcId -> Maybe a
lookupVarEnv (TCvSubst -> VarEnv Type
getTvSubstEnv TCvSubst
subst) TcId
tc_tv
      = (TCvSubst
subst, Type
ty)
      | Bool
otherwise
      = (TCvSubst -> TcId -> Type -> TCvSubst
extendTvSubst TCvSubst
subst TcId
tc_tv Type
ty', Type
ty')
      where
        ty' :: Type
ty' = TcId -> Type
mkTyVarTy ((Type -> Type) -> TcId -> TcId
updateTyVarKind (TCvSubst -> Type -> Type
substTyUnchecked TCvSubst
subst) TcId
tc_tv)

warnMissingAT :: Name -> TcM ()
warnMissingAT :: Name -> TcRn ()
warnMissingAT Name
name
  = do { Bool
warn <- WarningFlag -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. WarningFlag -> TcRnIf gbl lcl Bool
woptM WarningFlag
Opt_WarnMissingMethods
       ; String -> SDoc -> TcRn ()
traceTc String
"warn" (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name SDoc -> SDoc -> SDoc
<+> Bool -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bool
warn)
       ; HscSource
hsc_src <- (TcGblEnv -> HscSource)
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
-> IOEnv (Env TcGblEnv TcLclEnv) HscSource
forall a b.
(a -> b)
-> IOEnv (Env TcGblEnv TcLclEnv) a
-> IOEnv (Env TcGblEnv TcLclEnv) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TcGblEnv -> HscSource
tcg_src TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
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 dia :: TcRnMessage
dia = DiagnosticMessage -> TcRnMessage
forall a. (Diagnostic a, Typeable a) => a -> TcRnMessage
TcRnUnknownMessage (DiagnosticMessage -> TcRnMessage)
-> DiagnosticMessage -> TcRnMessage
forall a b. (a -> b) -> a -> b
$
               DiagnosticReason -> [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainDiagnostic (WarningFlag -> DiagnosticReason
WarningWithFlag WarningFlag
Opt_WarnMissingMethods) [GhcHint]
noHints (SDoc -> DiagnosticMessage) -> SDoc -> DiagnosticMessage
forall a b. (a -> b) -> a -> b
$
                 (String -> SDoc
text String
"No explicit" SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"associated type"
                                     SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"or default declaration for"
                                     SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name))
       ; Bool -> TcRnMessage -> TcRn ()
diagnosticTc  (Bool
warn Bool -> Bool -> Bool
&& HscSource
hsc_src HscSource -> HscSource -> Bool
forall a. Eq a => a -> a -> Bool
== HscSource
HsSrcFile) TcRnMessage
dia
                       }