{-
(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.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 ( 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 (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)

       ; gen_dm_prs <- (GenLocated
   SrcSpan
   ([GenLocated SrcSpanAnnN Name],
    GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed)))
 -> IOEnv (Env TcGblEnv TcLclEnv) [(Name, (SrcSpan, Type))])
-> [GenLocated
      SrcSpan
      ([GenLocated SrcSpanAnnN Name],
       GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed)))]
-> 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 (GhcPass 'Renamed)))
 -> IOEnv (Env TcGblEnv TcLclEnv) [(Name, (SrcSpan, Type))])
-> GenLocated
     SrcSpan
     ([GenLocated SrcSpanAnnN Name],
      GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed)))
-> 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 (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))]
[GenLocated
   SrcSpan
   ([GenLocated SrcSpanAnnN Name],
    GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed)))]
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 (GhcPass 'Renamed) (GhcPass 'Renamed)
meth : LHsBinds (GhcPass 'Renamed)
meths -> TcRnMessage -> TcRn ()
forall a. TcRnMessage -> TcM a
failWithTc (Name
-> NonEmpty (LHsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed))
-> TcRnMessage
TcRnIllegalHsigDefaultMethods Name
clas (LHsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)
GenLocated
  SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed))
meth GenLocated
  SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed))
-> [GenLocated
      SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed))]
-> NonEmpty
     (GenLocated
        SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)))
forall a. a -> [a] -> NonEmpty a
NE.:| LHsBinds (GhcPass 'Renamed)
[GenLocated
   SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed))]
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 (GhcPass 'Renamed))]
vanilla_sigs = [SrcSpan
-> ([GenLocated SrcSpanAnnN Name],
    GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed)))
-> GenLocated
     SrcSpan
     ([GenLocated SrcSpanAnnN Name],
      GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed)))
forall l e. l -> e -> GenLocated l e
L (SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => 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)))
-> GenLocated
     SrcSpan
     ([GenLocated SrcSpanAnnN Name],
      GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed)))
forall l e. l -> e -> GenLocated l e
L (SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => 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}) <- LHsBinds (GhcPass 'Renamed)
[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)
           ; 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

           ; 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 (GhcPass 'Renamed))
-> IOEnv (Env TcGblEnv TcLclEnv) [(Name, (SrcSpan, Type))]
tc_gen_sig ([GenLocated SrcSpanAnnN Name]
op_names, LHsSigType (GhcPass 'Renamed)
gen_hs_ty)
      = do { gen_op_ty <- [GenLocated SrcSpanAnnN Name]
-> LHsSigType (GhcPass 'Renamed) -> TcM Type
tcClassSigType [GenLocated SrcSpanAnnN Name]
op_names LHsSigType (GhcPass 'Renamed)
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 (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 ([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 (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  { 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 (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

        ; skol_info <- mkSkolemInfo (TyConSkol ClassFlavour (getName class_name))
        ; tc_lvl    <- getTcLevel
        ; let (tyvars, _, _, op_items) = classBigSig clas
              prag_fn = [LSig (GhcPass 'Renamed)]
-> LHsBinds (GhcPass 'Renamed) -> TcPragEnv
mkPragEnv [LSig (GhcPass 'Renamed)]
sigs LHsBinds (GhcPass 'Renamed)
default_binds
              sig_fn  = [LSig (GhcPass 'Renamed)] -> HsSigFun
mkHsSigFun [LSig (GhcPass 'Renamed)]
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 (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
        ; dm_binds <- tcExtendTyVarEnv clas_tyvars $
                      mapM tc_item op_items

        ; return (concat dm_binds) }

tcClassDecl2 LTyClDecl (GhcPass 'Renamed)
d = String
-> SDoc
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     [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 t a b. HasLoc t => (a -> TcM b) -> GenLocated t a -> TcM b
addLocM (TcId -> Sig (GhcPass 'Renamed) -> TcRn ()
badDmPrag TcId
sel_id ))
               (TcPragEnv -> Name -> [LSig (GhcPass 'Renamed)]
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 (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
     (LHsBindLR (GhcPass 'Renamed) (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

         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 (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 = Class -> TcId -> [Type] -> Type
instantiateMethod Class
clas TcId
global_dm_id ([TcId] -> [Type]
mkTyVarTys [TcId]
tyvars)

             lm_bind     = HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)
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 (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 = 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 (GhcPass 'Renamed)) -> SrcSpan
forall a e. HasLoc a => GenLocated a e -> SrcSpan
getLocA GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed))
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 (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
        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) $
                       (\ClassMinimalDef
bf -> TcRnMessage -> TcRn ()
addDiagnosticTc (ClassMinimalDef -> TcRnMessage
TcRnWarningMinimalDefIncomplete ClassMinimalDef
bf))
        return 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 e a. HasAnnotation e => a -> GenLocated e 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 = 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 (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
     (LHsBindLR (GhcPass 'Renamed) (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))])
-> [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 -> [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))]))
-> [GenLocated
      SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed))]
-> [Maybe
      (GenLocated
         SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)),
       SrcSpan, [GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed))])]
forall a b. (a -> b) -> [a] -> [b]
map 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)
[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. HasLoc a => 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)
_ (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
*                                                                      *
************************************************************************
-}

{-
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 (TcId -> Sig (GhcPass 'Renamed) -> TcRnMessage
TcRnDefaultMethodForPragmaLacksBinding TcId
sel_id Sig (GhcPass 'Renamed)
prag)

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
forall doc. IsLine doc => String -> doc
text String
"In the instance declaration for")
                        Int
2 (SDoc -> SDoc
quotes SDoc
doc)

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
                       }