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


Typechecking class declarations
-}

{-# LANGUAGE CPP #-}
{-# LANGUAGE TypeFamilies #-}

module TcClassDcl ( tcClassSigs, tcClassDecl2,
                    findMethodBind, instantiateMethod,
                    tcClassMinimalDef,
                    HsSigFun, mkHsSigFun,
                    tcMkDeclCtxt, tcAddDeclCtxt, badMethodErr,
                    instDeclCtxt1, instDeclCtxt2, instDeclCtxt3,
                    tcATDefault
                  ) where

#include "HsVersions.h"

import GhcPrelude

import GHC.Hs
import TcEnv
import TcSigs
import TcEvidence ( idHsWrapper )
import TcBinds
import TcUnify
import TcHsType
import TcMType
import Type     ( piResultTys )
import Predicate
import TcOrigin
import TcType
import TcRnMonad
import DriverPhases (HscSource(..))
import BuildTyCl( TcMethInfo )
import Class
import Coercion ( pprCoAxiom )
import DynFlags
import FamInst
import FamInstEnv
import Id
import Name
import NameEnv
import NameSet
import Var
import VarEnv
import Outputable
import SrcLoc
import TyCon
import Maybes
import BasicTypes
import Bag
import FastString
import BooleanFormula
import Util

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 at 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 -> SDoc
illegalHsigDefaultMethod :: Name -> SDoc
illegalHsigDefaultMethod Name
n =
    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 GhcRn] -> LHsBinds GhcRn -> TcM [TcMethInfo]
tcClassSigs Name
clas [LSig GhcRn]
sigs LHsBinds GhcRn
def_methods
  = do { String -> SDoc -> TcRn ()
traceTc String
"tcClassSigs 1" (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
clas)

       ; [(Name, (SrcSpan, Type))]
gen_dm_prs <- [[(Name, (SrcSpan, Type))]] -> [(Name, (SrcSpan, Type))]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[(Name, (SrcSpan, Type))]] -> [(Name, (SrcSpan, Type))])
-> IOEnv (Env TcGblEnv TcLclEnv) [[(Name, (SrcSpan, Type))]]
-> IOEnv (Env TcGblEnv TcLclEnv) [(Name, (SrcSpan, Type))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (GenLocated SrcSpan ([Located Name], LHsSigType GhcRn)
 -> IOEnv (Env TcGblEnv TcLclEnv) [(Name, (SrcSpan, Type))])
-> [GenLocated SrcSpan ([Located Name], LHsSigType GhcRn)]
-> IOEnv (Env TcGblEnv TcLclEnv) [[(Name, (SrcSpan, Type))]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((SrcSpanLess
   (GenLocated SrcSpan ([Located Name], LHsSigType GhcRn))
 -> IOEnv (Env TcGblEnv TcLclEnv) [(Name, (SrcSpan, Type))])
-> GenLocated SrcSpan ([Located Name], LHsSigType GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) [(Name, (SrcSpan, Type))]
forall a b. HasSrcSpan a => (SrcSpanLess a -> TcM b) -> a -> TcM b
addLocM ([Located Name], LHsSigType GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) [(Name, (SrcSpan, Type))]
SrcSpanLess (GenLocated SrcSpan ([Located Name], LHsSigType GhcRn))
-> IOEnv (Env TcGblEnv TcLclEnv) [(Name, (SrcSpan, Type))]
tc_gen_sig) [GenLocated SrcSpan ([Located Name], LHsSigType GhcRn)]
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 <- [[TcMethInfo]] -> [TcMethInfo]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[TcMethInfo]] -> [TcMethInfo])
-> IOEnv (Env TcGblEnv TcLclEnv) [[TcMethInfo]] -> TcM [TcMethInfo]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (GenLocated SrcSpan ([Located Name], LHsSigType GhcRn)
 -> TcM [TcMethInfo])
-> [GenLocated SrcSpan ([Located Name], LHsSigType GhcRn)]
-> IOEnv (Env TcGblEnv TcLclEnv) [[TcMethInfo]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((SrcSpanLess
   (GenLocated SrcSpan ([Located Name], LHsSigType GhcRn))
 -> TcM [TcMethInfo])
-> GenLocated SrcSpan ([Located Name], LHsSigType GhcRn)
-> TcM [TcMethInfo]
forall a b. HasSrcSpan a => (SrcSpanLess a -> TcM b) -> a -> TcM b
addLocM (NameEnv (SrcSpan, Type)
-> ([Located Name], LHsSigType GhcRn) -> TcM [TcMethInfo]
tc_sig NameEnv (SrcSpan, Type)
gen_dm_env)) [GenLocated SrcSpan ([Located Name], LHsSigType GhcRn)]
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_ [ SDoc -> IOEnv (Env TcGblEnv TcLclEnv) Any
forall a. SDoc -> TcM a
failWithTc (Name -> Name -> SDoc
forall a. Outputable a => a -> Name -> SDoc
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 (LHsBinds GhcRn -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null LHsBinds GhcRn
def_methods)) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
                SDoc -> TcRn ()
forall a. SDoc -> TcM a
failWithTc (Name -> SDoc
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_ [ SDoc -> IOEnv (Env TcGblEnv TcLclEnv) Any
forall a. SDoc -> TcM a
failWithTc (Name -> Name -> SDoc
forall a. Outputable a => a -> Name -> SDoc
badGenericMethod Name
clas Name
n)
                         | (Name
n,(SrcSpan, Type)
_) <- [(Name, (SrcSpan, Type))]
gen_dm_prs, Bool -> Bool
not (Name
n Name -> [Name] -> 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 (m :: * -> *) a. Monad m => a -> m a
return [TcMethInfo]
op_info }
  where
    vanilla_sigs :: [GenLocated SrcSpan ([Located Name], LHsSigType GhcRn)]
vanilla_sigs = [SrcSpan
-> ([Located Name], LHsSigType GhcRn)
-> GenLocated SrcSpan ([Located Name], LHsSigType GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc ([Located Name]
[Located (IdP GhcRn)]
nm,LHsSigType GhcRn
ty) | L SrcSpan
loc (ClassOpSig XClassOpSig GhcRn
_ Bool
False [Located (IdP GhcRn)]
nm LHsSigType GhcRn
ty) <- [LSig GhcRn]
sigs]
    gen_sigs :: [GenLocated SrcSpan ([Located Name], LHsSigType GhcRn)]
gen_sigs     = [SrcSpan
-> ([Located Name], LHsSigType GhcRn)
-> GenLocated SrcSpan ([Located Name], LHsSigType GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc ([Located Name]
[Located (IdP GhcRn)]
nm,LHsSigType GhcRn
ty) | L SrcSpan
loc (ClassOpSig XClassOpSig GhcRn
_ Bool
True  [Located (IdP GhcRn)]
nm LHsSigType GhcRn
ty) <- [LSig GhcRn]
sigs]
    dm_bind_names :: [Name] -- These ones have a value binding in the class decl
    dm_bind_names :: [Name]
dm_bind_names = [Name
IdP GhcRn
op | L SrcSpan
_ (FunBind {fun_id :: forall idL idR. HsBindLR idL idR -> Located (IdP idL)
fun_id = L SrcSpan
_ IdP GhcRn
op}) <- LHsBinds GhcRn -> [GenLocated SrcSpan (HsBindLR GhcRn GhcRn)]
forall a. Bag a -> [a]
bagToList LHsBinds GhcRn
def_methods]

    skol_info :: SkolemInfo
skol_info = TyConFlavour -> Name -> SkolemInfo
TyConSkol TyConFlavour
ClassFlavour Name
clas

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

           ; String -> SDoc -> TcRn ()
traceTc String
"ClsSig 2" ([Located Name] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Located Name]
op_names)
           ; [TcMethInfo] -> TcM [TcMethInfo]
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 SrcSpan
_ Name
op_name <- [Located 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 (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 :: ([Located Name], LHsSigType GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) [(Name, (SrcSpan, Type))]
tc_gen_sig ([Located Name]
op_names, LHsSigType GhcRn
gen_hs_ty)
      = do { Type
gen_op_ty <- SkolemInfo -> [Located Name] -> LHsSigType GhcRn -> TcM Type
tcClassSigType SkolemInfo
skol_info [Located Name]
op_names LHsSigType GhcRn
gen_hs_ty
           ; [(Name, (SrcSpan, Type))]
-> IOEnv (Env TcGblEnv TcLclEnv) [(Name, (SrcSpan, Type))]
forall (m :: * -> *) a. Monad m => a -> m a
return [ (Name
op_name, (SrcSpan
loc, Type
gen_op_ty)) | L SrcSpan
loc Name
op_name <- [Located Name]
op_names ] }

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

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

tcClassDecl2 :: LTyClDecl GhcRn -> TcM (LHsBinds GhcTcId)
tcClassDecl2 (L SrcSpan
_ (ClassDecl {tcdLName :: forall pass. TyClDecl pass -> Located (IdP pass)
tcdLName = Located (IdP GhcRn)
class_name, tcdSigs :: forall pass. TyClDecl pass -> [LSig pass]
tcdSigs = [LSig GhcRn]
sigs,
                                tcdMeths :: forall pass. TyClDecl pass -> LHsBinds pass
tcdMeths = LHsBinds GhcRn
default_binds}))
  = TcM (LHsBinds GhcTcId)
-> TcM (LHsBinds GhcTcId) -> TcM (LHsBinds GhcTcId)
forall r. TcRn r -> TcRn r -> TcRn r
recoverM (LHsBinds GhcTcId -> TcM (LHsBinds GhcTcId)
forall (m :: * -> *) a. Monad m => a -> m a
return LHsBinds GhcTcId
forall idL idR. LHsBindsLR idL idR
emptyLHsBinds)     (TcM (LHsBinds GhcTcId) -> TcM (LHsBinds GhcTcId))
-> TcM (LHsBinds GhcTcId) -> TcM (LHsBinds GhcTcId)
forall a b. (a -> b) -> a -> b
$
    SrcSpan -> TcM (LHsBinds GhcTcId) -> TcM (LHsBinds GhcTcId)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (Located Name -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc Located Name
Located (IdP GhcRn)
class_name)      (TcM (LHsBinds GhcTcId) -> TcM (LHsBinds GhcTcId))
-> TcM (LHsBinds GhcTcId) -> TcM (LHsBinds GhcTcId)
forall a b. (a -> b) -> a -> b
$
    do  { Class
clas <- Located Name -> TcM Class
tcLookupLocatedClass Located Name
Located (IdP GhcRn)
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
        ; let ([TyVar]
tyvars, [Type]
_, [TyVar]
_, [ClassOpItem]
op_items) = Class -> ([TyVar], [Type], [TyVar], [ClassOpItem])
classBigSig Class
clas
              prag_fn :: TcPragEnv
prag_fn     = [LSig GhcRn] -> LHsBinds GhcRn -> TcPragEnv
mkPragEnv [LSig GhcRn]
sigs LHsBinds GhcRn
default_binds
              sig_fn :: HsSigFun
sig_fn      = [LSig GhcRn] -> HsSigFun
mkHsSigFun [LSig GhcRn]
sigs
              clas_tyvars :: [TyVar]
clas_tyvars = (TCvSubst, [TyVar]) -> [TyVar]
forall a b. (a, b) -> b
snd ([TyVar] -> (TCvSubst, [TyVar])
tcSuperSkolTyVars [TyVar]
tyvars)
              pred :: Type
pred        = Class -> [Type] -> Type
mkClassPred Class
clas ([TyVar] -> [Type]
mkTyVarTys [TyVar]
clas_tyvars)
        ; TyVar
this_dict <- Type -> TcRnIf TcGblEnv TcLclEnv TyVar
forall gbl lcl. Type -> TcRnIf gbl lcl TyVar
newEvVar Type
pred

        ; let tc_item :: ClassOpItem -> TcM (LHsBinds GhcTcId)
tc_item = Class
-> [TyVar]
-> TyVar
-> LHsBinds GhcRn
-> HsSigFun
-> TcPragEnv
-> ClassOpItem
-> TcM (LHsBinds GhcTcId)
tcDefMeth Class
clas [TyVar]
clas_tyvars TyVar
this_dict
                                  LHsBinds GhcRn
default_binds HsSigFun
sig_fn TcPragEnv
prag_fn
        ; [LHsBinds GhcTcId]
dm_binds <- [TyVar] -> TcM [LHsBinds GhcTcId] -> TcM [LHsBinds GhcTcId]
forall r. [TyVar] -> TcM r -> TcM r
tcExtendTyVarEnv [TyVar]
clas_tyvars (TcM [LHsBinds GhcTcId] -> TcM [LHsBinds GhcTcId])
-> TcM [LHsBinds GhcTcId] -> TcM [LHsBinds GhcTcId]
forall a b. (a -> b) -> a -> b
$
                      (ClassOpItem -> TcM (LHsBinds GhcTcId))
-> [ClassOpItem] -> TcM [LHsBinds GhcTcId]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ClassOpItem -> TcM (LHsBinds GhcTcId)
tc_item [ClassOpItem]
op_items

        ; LHsBinds GhcTcId -> TcM (LHsBinds GhcTcId)
forall (m :: * -> *) a. Monad m => a -> m a
return ([LHsBinds GhcTcId] -> LHsBinds GhcTcId
forall a. [Bag a] -> Bag a
unionManyBags [LHsBinds GhcTcId]
dm_binds) }

tcClassDecl2 LTyClDecl GhcRn
d = String -> SDoc -> TcM (LHsBinds GhcTcId)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcClassDecl2" (LTyClDecl GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr LTyClDecl GhcRn
d)

tcDefMeth :: Class -> [TyVar] -> EvVar -> LHsBinds GhcRn
          -> HsSigFun -> TcPragEnv -> ClassOpItem
          -> TcM (LHsBinds GhcTcId)
-- 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
-> [TyVar]
-> TyVar
-> LHsBinds GhcRn
-> HsSigFun
-> TcPragEnv
-> ClassOpItem
-> TcM (LHsBinds GhcTcId)
tcDefMeth Class
_ [TyVar]
_ TyVar
_ LHsBinds GhcRn
_ HsSigFun
_ TcPragEnv
prag_fn (TyVar
sel_id, Maybe (Name, DefMethSpec Type)
Nothing)
  = do { -- No default method
         (LSig GhcRn -> TcRn ()) -> [LSig GhcRn] -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((SrcSpanLess (LSig GhcRn) -> TcRn ()) -> LSig GhcRn -> TcRn ()
forall a b. HasSrcSpan a => (SrcSpanLess a -> TcM b) -> a -> TcM b
addLocM (TyVar -> Sig GhcRn -> TcRn ()
badDmPrag TyVar
sel_id))
               (TcPragEnv -> Name -> [LSig GhcRn]
lookupPragEnv TcPragEnv
prag_fn (TyVar -> Name
idName TyVar
sel_id))
       ; LHsBinds GhcTcId -> TcM (LHsBinds GhcTcId)
forall (m :: * -> *) a. Monad m => a -> m a
return LHsBinds GhcTcId
forall a. Bag a
emptyBag }

tcDefMeth Class
clas [TyVar]
tyvars TyVar
this_dict LHsBinds GhcRn
binds_in HsSigFun
hs_sig_fn TcPragEnv
prag_fn
          (TyVar
sel_id, Just (Name
dm_name, DefMethSpec Type
dm_spec))
  | Just (L SrcSpan
bind_loc HsBindLR GhcRn GhcRn
dm_bind, SrcSpan
bndr_loc, [LSig GhcRn]
prags) <- Name
-> LHsBinds GhcRn
-> TcPragEnv
-> Maybe
     (GenLocated SrcSpan (HsBindLR GhcRn GhcRn), SrcSpan, [LSig GhcRn])
findMethodBind Name
sel_name LHsBinds GhcRn
binds_in TcPragEnv
prag_fn
  = do { -- First look up the default method; it should be there!
         -- It can be the orinary 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

         TyVar
global_dm_id  <- Name -> TcRnIf TcGblEnv TcLclEnv TyVar
tcLookupId Name
dm_name
       ; TyVar
global_dm_id  <- TyVar -> [LSig GhcRn] -> TcRnIf TcGblEnv TcLclEnv TyVar
addInlinePrags TyVar
global_dm_id [LSig GhcRn]
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
$
                       TyVar -> [LSig GhcRn] -> TcM [LTcSpecPrag]
tcSpecPrags TyVar
global_dm_id [LSig GhcRn]
prags
       ; WarnReason -> Bool -> SDoc -> TcRn ()
warnTc WarnReason
NoReason
                (Bool -> Bool
not ([LTcSpecPrag] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LTcSpecPrag]
spec_prags))
                (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))

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

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

             lm_bind :: HsBindLR GhcRn GhcRn
lm_bind     = HsBindLR GhcRn GhcRn
dm_bind { fun_id :: Located (IdP GhcRn)
fun_id = SrcSpan -> Name -> Located Name
forall l e. l -> e -> GenLocated l e
L SrcSpan
bind_loc Name
local_dm_name }
                             -- Substitute the local_meth_name for the binder
                             -- NB: the binding is always a FunBind

             warn_redundant :: Bool
warn_redundant = case DefMethSpec Type
dm_spec of
                                GenericDM {} -> Bool
True
                                DefMethSpec Type
VanillaDM    -> Bool
False
                -- 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 -> Bool -> UserTypeCtxt
FunSigCtxt Name
sel_name Bool
warn_redundant

       ; let local_dm_id :: TyVar
local_dm_id = Name -> Type -> TyVar
mkLocalId Name
local_dm_name Type
local_dm_ty
             local_dm_sig :: TcIdSigInfo
local_dm_sig = CompleteSig :: TyVar -> UserTypeCtxt -> SrcSpan -> TcIdSigInfo
CompleteSig { sig_bndr :: TyVar
sig_bndr = TyVar
local_dm_id
                                        , sig_ctxt :: UserTypeCtxt
sig_ctxt  = UserTypeCtxt
ctxt
                                        , sig_loc :: SrcSpan
sig_loc   = LHsType GhcRn -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc (LHsSigType GhcRn -> LHsType GhcRn
forall (p :: Pass). LHsSigType (GhcPass p) -> LHsType (GhcPass p)
hsSigType LHsSigType GhcRn
hs_ty) }

       ; (TcEvBinds
ev_binds, (LHsBinds GhcTcId
tc_bind, [TyVar]
_))
               <- SkolemInfo
-> [TyVar]
-> [TyVar]
-> TcM (LHsBinds GhcTcId, [TyVar])
-> TcM (TcEvBinds, (LHsBinds GhcTcId, [TyVar]))
forall result.
SkolemInfo
-> [TyVar] -> [TyVar] -> TcM result -> TcM (TcEvBinds, result)
checkConstraints (TyConFlavour -> Name -> SkolemInfo
TyConSkol TyConFlavour
ClassFlavour (Class -> Name
forall a. NamedThing a => a -> Name
getName Class
clas)) [TyVar]
tyvars [TyVar
this_dict] (TcM (LHsBinds GhcTcId, [TyVar])
 -> TcM (TcEvBinds, (LHsBinds GhcTcId, [TyVar])))
-> TcM (LHsBinds GhcTcId, [TyVar])
-> TcM (TcEvBinds, (LHsBinds GhcTcId, [TyVar]))
forall a b. (a -> b) -> a -> b
$
                  TcPragEnv
-> TcIdSigInfo
-> GenLocated SrcSpan (HsBindLR GhcRn GhcRn)
-> TcM (LHsBinds GhcTcId, [TyVar])
tcPolyCheck TcPragEnv
no_prag_fn TcIdSigInfo
local_dm_sig
                              (SrcSpan
-> HsBindLR GhcRn GhcRn
-> GenLocated SrcSpan (HsBindLR GhcRn GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpan
bind_loc HsBindLR GhcRn GhcRn
lm_bind)

       ; let export :: ABExport GhcTcId
export = ABE :: forall p.
XABE p -> IdP p -> IdP p -> HsWrapper -> TcSpecPrags -> ABExport p
ABE { abe_ext :: XABE GhcTcId
abe_ext   = XABE GhcTcId
NoExtField
noExtField
                          , abe_poly :: IdP GhcTcId
abe_poly  = TyVar
IdP GhcTcId
global_dm_id
                          , abe_mono :: IdP GhcTcId
abe_mono  = TyVar
IdP GhcTcId
local_dm_id
                          , abe_wrap :: HsWrapper
abe_wrap  = HsWrapper
idHsWrapper
                          , abe_prags :: TcSpecPrags
abe_prags = TcSpecPrags
IsDefaultMethod }
             full_bind :: HsBindLR GhcTcId GhcTcId
full_bind = AbsBinds :: forall idL idR.
XAbsBinds idL idR
-> [TyVar]
-> [TyVar]
-> [ABExport idL]
-> [TcEvBinds]
-> LHsBinds idL
-> Bool
-> HsBindLR idL idR
AbsBinds { abs_ext :: XAbsBinds GhcTcId GhcTcId
abs_ext      = XAbsBinds GhcTcId GhcTcId
NoExtField
noExtField
                                  , abs_tvs :: [TyVar]
abs_tvs      = [TyVar]
tyvars
                                  , abs_ev_vars :: [TyVar]
abs_ev_vars  = [TyVar
this_dict]
                                  , abs_exports :: [ABExport GhcTcId]
abs_exports  = [ABExport GhcTcId
export]
                                  , abs_ev_binds :: [TcEvBinds]
abs_ev_binds = [TcEvBinds
ev_binds]
                                  , abs_binds :: LHsBinds GhcTcId
abs_binds    = LHsBinds GhcTcId
tc_bind
                                  , abs_sig :: Bool
abs_sig      = Bool
True }

       ; LHsBinds GhcTcId -> TcM (LHsBinds GhcTcId)
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated SrcSpan (HsBindLR GhcTcId GhcTcId) -> LHsBinds GhcTcId
forall a. a -> Bag a
unitBag (SrcSpan
-> HsBindLR GhcTcId GhcTcId
-> GenLocated SrcSpan (HsBindLR GhcTcId GhcTcId)
forall l e. l -> e -> GenLocated l e
L SrcSpan
bind_loc HsBindLR GhcTcId GhcTcId
full_bind)) }

  | Bool
otherwise = String -> SDoc -> TcM (LHsBinds GhcTcId)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcDefMeth" (TyVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyVar
sel_id)
  where
    sel_name :: Name
sel_name = TyVar -> Name
idName TyVar
sel_id
    no_prag_fn :: TcPragEnv
no_prag_fn = TcPragEnv
emptyPragEnv   -- No pragmas for local_meth_id;
                                -- they are all for meth_id

---------------
tcClassMinimalDef :: Name -> [LSig GhcRn] -> [TcMethInfo] -> TcM ClassMinimalDef
tcClassMinimalDef :: Name -> [LSig GhcRn] -> [TcMethInfo] -> TcM ClassMinimalDef
tcClassMinimalDef Name
_clas [LSig GhcRn]
sigs [TcMethInfo]
op_info
  = case [LSig GhcRn] -> Maybe ClassMinimalDef
findMinimalDef [LSig GhcRn]
sigs of
      Maybe ClassMinimalDef
Nothing -> ClassMinimalDef -> TcM ClassMinimalDef
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 -> WarnReason -> SDoc -> TcRn ()
addWarnTc WarnReason
NoReason (ClassMinimalDef -> SDoc
warningMinimalDefIncomplete ClassMinimalDef
bf))
        ClassMinimalDef -> TcM ClassMinimalDef
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 [ SrcSpanLess (LBooleanFormula Name) -> LBooleanFormula Name
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (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 -> TyVar -> [Type] -> Type
instantiateMethod Class
clas TyVar
sel_id [Type]
inst_tys
  = ASSERT( ok_first_pred ) local_meth_ty
  where
    rho_ty :: Type
rho_ty = HasDebugCallStack => Type -> [Type] -> Type
Type -> [Type] -> Type
piResultTys (TyVar -> Type
idType TyVar
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" (TyVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyVar
sel_id)

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


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

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

    get_classop_sig :: LSig GhcRn -> Maybe ([Located Name], LHsSigType GhcRn)
    get_classop_sig :: LSig GhcRn -> Maybe ([Located Name], LHsSigType GhcRn)
get_classop_sig  (L SrcSpan
_ (ClassOpSig XClassOpSig GhcRn
_ Bool
_ [Located (IdP GhcRn)]
ns LHsSigType GhcRn
hs_ty)) = ([Located Name], LHsSigType GhcRn)
-> Maybe ([Located Name], LHsSigType GhcRn)
forall a. a -> Maybe a
Just ([Located Name]
[Located (IdP GhcRn)]
ns, LHsSigType GhcRn
hs_ty)
    get_classop_sig  LSig GhcRn
_                               = Maybe ([Located Name], LHsSigType GhcRn)
forall a. Maybe a
Nothing

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

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

---------------------------
findMinimalDef :: [LSig GhcRn] -> Maybe ClassMinimalDef
findMinimalDef :: [LSig GhcRn] -> Maybe ClassMinimalDef
findMinimalDef = [Maybe ClassMinimalDef] -> Maybe ClassMinimalDef
forall a. [Maybe a] -> Maybe a
firstJusts ([Maybe ClassMinimalDef] -> Maybe ClassMinimalDef)
-> ([LSig GhcRn] -> [Maybe ClassMinimalDef])
-> [LSig GhcRn]
-> Maybe ClassMinimalDef
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LSig GhcRn -> Maybe ClassMinimalDef)
-> [LSig GhcRn] -> [Maybe ClassMinimalDef]
forall a b. (a -> b) -> [a] -> [b]
map LSig GhcRn -> Maybe ClassMinimalDef
toMinimalDef
  where
    toMinimalDef :: LSig GhcRn -> Maybe ClassMinimalDef
    toMinimalDef :: LSig GhcRn -> Maybe ClassMinimalDef
toMinimalDef (L SrcSpan
_ (MinimalSig XMinimalSig GhcRn
_ SourceText
_ (L SrcSpan
_ BooleanFormula (Located (IdP GhcRn))
bf))) = ClassMinimalDef -> Maybe ClassMinimalDef
forall a. a -> Maybe a
Just ((Located Name -> Name)
-> BooleanFormula (Located Name) -> ClassMinimalDef
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Located Name -> Name
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc BooleanFormula (Located Name)
BooleanFormula (Located (IdP GhcRn))
bf)
    toMinimalDef LSig GhcRn
_                               = 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 TcBinds.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
*                                                                      *
************************************************************************
-}

tcMkDeclCtxt :: TyClDecl GhcRn -> SDoc
tcMkDeclCtxt :: TyClDecl GhcRn -> SDoc
tcMkDeclCtxt TyClDecl GhcRn
decl = [SDoc] -> SDoc
hsep [String -> SDoc
text String
"In the", TyClDecl GhcRn -> SDoc
forall (p :: Pass). TyClDecl (GhcPass p) -> SDoc
pprTyClDeclFlavour TyClDecl GhcRn
decl,
                      String -> SDoc
text String
"declaration for", SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TyClDecl GhcRn -> IdP GhcRn
forall pass. TyClDecl pass -> IdP pass
tcdName TyClDecl GhcRn
decl))]

tcAddDeclCtxt :: TyClDecl GhcRn -> TcM a -> TcM a
tcAddDeclCtxt :: TyClDecl GhcRn -> TcM a -> TcM a
tcAddDeclCtxt TyClDecl GhcRn
decl TcM a
thing_inside
  = SDoc -> TcM a -> TcM a
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (TyClDecl GhcRn -> SDoc
tcMkDeclCtxt TyClDecl GhcRn
decl) TcM a
thing_inside

badMethodErr :: Outputable a => a -> Name -> SDoc
badMethodErr :: a -> Name -> SDoc
badMethodErr a
clas Name
op
  = [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 -> SDoc
badGenericMethod :: a -> Name -> SDoc
badGenericMethod a
clas Name
op
  = [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 :: TyVar -> Sig GhcRn -> TcRn ()
badDmPrag TyVar
sel_id Sig GhcRn
prag
  = SDoc -> TcRn ()
addErrTc (String -> SDoc
text String
"The" SDoc -> SDoc -> SDoc
<+> Sig GhcRn -> SDoc
forall name. Sig name -> SDoc
hsSigDoc Sig GhcRn
prag SDoc -> SDoc -> SDoc
<+> PtrString -> SDoc
ptext (String -> PtrString
sLit String
"for default method")
              SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (TyVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyVar
sel_id)
              SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"lacks an accompanying binding")

warningMinimalDefIncomplete :: ClassMinimalDef -> SDoc
warningMinimalDefIncomplete :: ClassMinimalDef -> SDoc
warningMinimalDefIncomplete ClassMinimalDef
mindef
  = [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 GhcRn -> SDoc
instDeclCtxt1 LHsSigType GhcRn
hs_inst_ty
  = SDoc -> SDoc
inst_decl_ctxt (LHsType GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr (LHsSigType GhcRn -> LHsType GhcRn
forall (p :: Pass). LHsSigType (GhcPass p) -> LHsType (GhcPass p)
getLHsInstDeclHead LHsSigType GhcRn
hs_inst_ty))

instDeclCtxt2 :: Type -> SDoc
instDeclCtxt2 :: Type -> SDoc
instDeclCtxt2 Type
dfun_ty
  = Class -> [Type] -> SDoc
instDeclCtxt3 Class
cls [Type]
tys
  where
    ([TyVar]
_,[Type]
_,Class
cls,[Type]
tys) = Type -> ([TyVar], [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, SrcSpan)
defs)
  -- User supplied instances ==> everything is OK
  | TyCon -> Name
tyConName TyCon
fam_tc Name -> NameSet -> Bool
`elemNameSet` NameSet
defined_ats
  = [FamInst] -> TcM [FamInst]
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, SrcSpan
_loc) <- Maybe (Type, SrcSpan)
defs
  = do { let (TCvSubst
subst', [Type]
pat_tys') = (TCvSubst -> TyVar -> (TCvSubst, Type))
-> TCvSubst -> [TyVar] -> (TCvSubst, [Type])
forall (t :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
mapAccumL TCvSubst -> TyVar -> (TCvSubst, Type)
subst_tv TCvSubst
inst_subst
                                            (TyCon -> [TyVar]
tyConTyVars TyCon
fam_tc)
             rhs' :: Type
rhs'     = TCvSubst -> Type -> Type
substTyUnchecked TCvSubst
subst' Type
rhs_ty
             tcv' :: [TyVar]
tcv' = [Type] -> [TyVar]
tyCoVarsOfTypesList [Type]
pat_tys'
             ([TyVar]
tv', [TyVar]
cv') = (TyVar -> Bool) -> [TyVar] -> ([TyVar], [TyVar])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition TyVar -> Bool
isTyVar [TyVar]
tcv'
             tvs' :: [TyVar]
tvs'     = [TyVar] -> [TyVar]
scopedSort [TyVar]
tv'
             cvs' :: [TyVar]
cvs'     = [TyVar] -> [TyVar]
scopedSort [TyVar]
cv'
       ; Name
rep_tc_name <- Located Name -> [Type] -> TcM Name
newFamInstTyConName (SrcSpan -> Name -> Located Name
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (TyCon -> Name
tyConName TyCon
fam_tc)) [Type]
pat_tys'
       ; let axiom :: CoAxiom Unbranched
axiom = Role
-> Name
-> [TyVar]
-> [TyVar]
-> [TyVar]
-> TyCon
-> [Type]
-> Type
-> CoAxiom Unbranched
mkSingleCoAxiom Role
Nominal Name
rep_tc_name [TyVar]
tvs' [] [TyVar]
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 (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 (m :: * -> *) a. Monad m => a -> m a
return [] }
  where
    subst_tv :: TCvSubst -> TyVar -> (TCvSubst, Type)
subst_tv TCvSubst
subst TyVar
tc_tv
      | Just Type
ty <- VarEnv Type -> TyVar -> Maybe Type
forall a. VarEnv a -> TyVar -> Maybe a
lookupVarEnv (TCvSubst -> VarEnv Type
getTvSubstEnv TCvSubst
subst) TyVar
tc_tv
      = (TCvSubst
subst, Type
ty)
      | Bool
otherwise
      = (TCvSubst -> TyVar -> Type -> TCvSubst
extendTvSubst TCvSubst
subst TyVar
tc_tv Type
ty', Type
ty')
      where
        ty' :: Type
ty' = TyVar -> Type
mkTyVarTy ((Type -> Type) -> TyVar -> TyVar
updateTyVarKind (TCvSubst -> Type -> Type
substTyUnchecked TCvSubst
subst) TyVar
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 (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
       -- Warn only if -Wmissing-methods AND not a signature
       ; WarnReason -> Bool -> SDoc -> TcRn ()
warnTc (WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnMissingMethods) (Bool
warn Bool -> Bool -> Bool
&& HscSource
hsc_src HscSource -> HscSource -> Bool
forall a. Eq a => a -> a -> Bool
/= HscSource
HsigFile)
                (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)) }