-- (c) The University of Glasgow 2006
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TupleSections #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}  -- instance MonadThings is necessarily an
                                       -- orphan
{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]
                                      -- in module Language.Haskell.Syntax.Extension
{-# LANGUAGE TypeFamilies #-}

module GHC.Tc.Utils.Env(
        TyThing(..), TcTyThing(..), TcId,

        -- Instance environment, and InstInfo type
        InstInfo(..), iDFunId, pprInstInfoDetails,
        simpleInstInfoClsTy, simpleInstInfoTy, simpleInstInfoTyCon,
        InstBindings(..),

        -- Global environment
        tcExtendGlobalEnv, tcExtendTyConEnv,
        tcExtendGlobalEnvImplicit, setGlobalTypeEnv,
        tcExtendGlobalValEnv, tcTyThBinders,
        tcLookupLocatedGlobal, tcLookupGlobal, tcLookupGlobalOnly,
        tcLookupTyCon, tcLookupClass,
        tcLookupDataCon, tcLookupPatSyn, tcLookupConLike,
        tcLookupRecSelParent,
        tcLookupLocatedGlobalId, tcLookupLocatedTyCon,
        tcLookupLocatedClass, tcLookupAxiom,
        lookupGlobal, lookupGlobal_maybe,
        addTypecheckedBinds,
        failIllegalTyCon, failIllegalTyVal,

        -- Local environment
        tcExtendKindEnv, tcExtendKindEnvList,
        tcExtendTyVarEnv, tcExtendNameTyVarEnv,
        tcExtendLetEnv, tcExtendSigIds, tcExtendRecIds,
        tcExtendIdEnv, tcExtendIdEnv1, tcExtendIdEnv2,
        tcExtendBinderStack, tcExtendLocalTypeEnv,
        isTypeClosedLetBndr,

        tcLookup, tcLookupLocated, tcLookupLocalIds,
        tcLookupId, tcLookupIdMaybe, tcLookupTyVar,
        tcLookupTcTyCon,
        tcLookupLcl_maybe,
        getInLocalScope,
        wrongThingErr, pprBinders,

        tcAddDataFamConPlaceholders, tcAddPatSynPlaceholders, tcAddKindSigPlaceholders,
        getTypeSigNames,
        tcExtendRecEnv,         -- For knot-tying

        -- Instances
        tcLookupInstance, tcGetInstEnvs,

        -- Rules
        tcExtendRules,

        -- Defaults
        tcGetDefaultTys,

        -- Template Haskell stuff
        StageCheckReason(..),
        checkWellStaged, tcMetaTy, thLevel,
        topIdLvl, isBrackStage,

        -- New Ids
        newDFunName,
        newFamInstTyConName, newFamInstAxiomName,
        mkStableIdFromString, mkStableIdFromName,
        mkWrapperName,
  ) where

import GHC.Prelude


import GHC.Driver.Env
import GHC.Driver.Env.KnotVars
import GHC.Driver.DynFlags

import GHC.Builtin.Names
import GHC.Builtin.Types

import GHC.Runtime.Context

import GHC.Hs

import GHC.Iface.Env
import GHC.Iface.Load

import GHC.Tc.Errors.Types
import GHC.Tc.Utils.Monad
import GHC.Tc.Utils.TcType
import {-# SOURCE #-} GHC.Tc.Utils.TcMType ( tcCheckUsage )
import GHC.Tc.Types.LclEnv

import GHC.Core.InstEnv
import GHC.Core.DataCon ( DataCon, dataConTyCon, flSelector )
import GHC.Core.PatSyn  ( PatSyn )
import GHC.Core.ConLike
import GHC.Core.TyCon
import GHC.Core.TyCo.Rep
import GHC.Core.Type
import GHC.Core.Coercion.Axiom
import GHC.Core.Class


import GHC.Unit.Module
import GHC.Unit.Home
import GHC.Unit.External

import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Encoding
import GHC.Utils.Misc ( HasDebugCallStack )

import GHC.Data.FastString
import GHC.Data.List.SetOps
import GHC.Data.Maybe( MaybeErr(..), orElse )

import GHC.Types.SrcLoc
import GHC.Types.Basic hiding( SuccessFlag(..) )
import GHC.Types.TypeEnv
import GHC.Types.SourceFile
import GHC.Types.Name
import GHC.Types.Name.Set
import GHC.Types.Name.Env
import GHC.Types.DefaultEnv ( DefaultEnv, ClassDefaults(..),
                              defaultEnv, emptyDefaultEnv, lookupDefaultEnv, unitDefaultEnv )
import GHC.Types.Id
import GHC.Types.Id.Info ( RecSelParent(..) )
import GHC.Types.Name.Reader
import GHC.Types.TyThing
import GHC.Types.Unique.Set ( nonDetEltsUniqSet )
import qualified GHC.LanguageExtensions as LangExt

import Data.IORef
import Data.List          ( intercalate )
import Control.Monad
import GHC.Iface.Errors.Types
import GHC.Types.Error
import GHC.Rename.Unbound ( unknownNameSuggestions, WhatLooking(..) )

{- *********************************************************************
*                                                                      *
            An IO interface to looking up globals
*                                                                      *
********************************************************************* -}

lookupGlobal :: HscEnv -> Name -> IO TyThing
-- A variant of lookupGlobal_maybe for the clients which are not
-- interested in recovering from lookup failure and accept panic.
lookupGlobal :: HscEnv -> Name -> IO TyThing
lookupGlobal HscEnv
hsc_env Name
name
  = do  {
          mb_thing <- HscEnv -> Name -> IO (MaybeErr (Either Name IfaceMessage) TyThing)
lookupGlobal_maybe HscEnv
hsc_env Name
name
        ; case mb_thing of
            Succeeded TyThing
thing -> TyThing -> IO TyThing
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return TyThing
thing
            Failed Either Name IfaceMessage
err      ->
              let msg :: SDoc
msg = case Either Name IfaceMessage
err of
                          Left Name
name -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Could not find local name:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name
                          Right IfaceMessage
err -> IfaceMessage -> SDoc
forall e. Diagnostic e => e -> SDoc
pprDiagnostic IfaceMessage
err
              in String -> SDoc -> IO TyThing
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"lookupGlobal" SDoc
msg
        }
lookupGlobal_maybe :: HscEnv -> Name -> IO (MaybeErr (Either Name IfaceMessage) TyThing)
-- This may look up an Id that one has previously looked up.
-- If so, we are going to read its interface file, and add its bindings
-- to the ExternalPackageTable.
lookupGlobal_maybe :: HscEnv -> Name -> IO (MaybeErr (Either Name IfaceMessage) TyThing)
lookupGlobal_maybe HscEnv
hsc_env Name
name
  = do  {    -- Try local envt
          let mod :: Module
mod = InteractiveContext -> Module
icInteractiveModule (HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env)
              mhome_unit :: Maybe HomeUnit
mhome_unit = HscEnv -> Maybe HomeUnit
hsc_home_unit_maybe HscEnv
hsc_env
              tcg_semantic_mod :: Module
tcg_semantic_mod = Maybe HomeUnit -> Module -> Module
homeModuleInstantiation Maybe HomeUnit
mhome_unit Module
mod

        ; if Module -> Name -> Bool
nameIsLocalOrFrom Module
tcg_semantic_mod Name
name
          then MaybeErr (Either Name IfaceMessage) TyThing
-> IO (MaybeErr (Either Name IfaceMessage) TyThing)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (MaybeErr (Either Name IfaceMessage) TyThing
 -> IO (MaybeErr (Either Name IfaceMessage) TyThing))
-> MaybeErr (Either Name IfaceMessage) TyThing
-> IO (MaybeErr (Either Name IfaceMessage) TyThing)
forall a b. (a -> b) -> a -> b
$ Either Name IfaceMessage
-> MaybeErr (Either Name IfaceMessage) TyThing
forall err val. err -> MaybeErr err val
Failed (Either Name IfaceMessage
 -> MaybeErr (Either Name IfaceMessage) TyThing)
-> Either Name IfaceMessage
-> MaybeErr (Either Name IfaceMessage) TyThing
forall a b. (a -> b) -> a -> b
$ Name -> Either Name IfaceMessage
forall a b. a -> Either a b
Left Name
name
              -- Internal names can happen in GHCi
          else do
            res <- HscEnv -> Name -> IO (MaybeErr IfaceMessage TyThing)
lookupImported_maybe HscEnv
hsc_env Name
name
            -- Try home package table and external package table
            return $ case res of
              Succeeded TyThing
ok -> TyThing -> MaybeErr (Either Name IfaceMessage) TyThing
forall err val. val -> MaybeErr err val
Succeeded TyThing
ok
              Failed   IfaceMessage
err -> Either Name IfaceMessage
-> MaybeErr (Either Name IfaceMessage) TyThing
forall err val. err -> MaybeErr err val
Failed (IfaceMessage -> Either Name IfaceMessage
forall a b. b -> Either a b
Right IfaceMessage
err)
        }

lookupImported_maybe :: HscEnv -> Name -> IO (MaybeErr IfaceMessage TyThing)
-- Returns (Failed err) if we can't find the interface file for the thing
lookupImported_maybe :: HscEnv -> Name -> IO (MaybeErr IfaceMessage TyThing)
lookupImported_maybe HscEnv
hsc_env Name
name
  = do  { mb_thing <- HscEnv -> Name -> IO (Maybe TyThing)
lookupType HscEnv
hsc_env Name
name
        ; case mb_thing of
            Just TyThing
thing -> MaybeErr IfaceMessage TyThing -> IO (MaybeErr IfaceMessage TyThing)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (TyThing -> MaybeErr IfaceMessage TyThing
forall err val. val -> MaybeErr err val
Succeeded TyThing
thing)
            Maybe TyThing
Nothing    -> HscEnv -> Name -> IO (MaybeErr IfaceMessage TyThing)
importDecl_maybe HscEnv
hsc_env Name
name
        }

importDecl_maybe :: HscEnv -> Name -> IO (MaybeErr IfaceMessage TyThing)
importDecl_maybe :: HscEnv -> Name -> IO (MaybeErr IfaceMessage TyThing)
importDecl_maybe HscEnv
hsc_env Name
name
  | Just TyThing
thing <- Name -> Maybe TyThing
wiredInNameTyThing_maybe Name
name
  = do  { Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TyThing -> Bool
needWiredInHomeIface TyThing
thing)
               (HscEnv -> IfG () -> IO ()
forall a. HscEnv -> IfG a -> IO a
initIfaceLoad HscEnv
hsc_env (Name -> IfG ()
forall lcl. Name -> IfM lcl ()
loadWiredInHomeIface Name
name))
                -- See Note [Loading instances for wired-in things]
        ; MaybeErr IfaceMessage TyThing -> IO (MaybeErr IfaceMessage TyThing)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (TyThing -> MaybeErr IfaceMessage TyThing
forall err val. val -> MaybeErr err val
Succeeded TyThing
thing) }
  | Bool
otherwise
  = HscEnv
-> IfG (MaybeErr IfaceMessage TyThing)
-> IO (MaybeErr IfaceMessage TyThing)
forall a. HscEnv -> IfG a -> IO a
initIfaceLoad HscEnv
hsc_env (Name -> IfG (MaybeErr IfaceMessage TyThing)
forall lcl. Name -> IfM lcl (MaybeErr IfaceMessage TyThing)
importDecl Name
name)

addTypecheckedBinds :: TcGblEnv -> [LHsBinds GhcTc] -> TcGblEnv
addTypecheckedBinds :: TcGblEnv -> [LHsBinds GhcTc] -> TcGblEnv
addTypecheckedBinds TcGblEnv
tcg_env [LHsBinds GhcTc]
binds
  | HscSource -> Bool
isHsBootOrSig (TcGblEnv -> HscSource
tcg_src TcGblEnv
tcg_env) = TcGblEnv
tcg_env
    -- Do not add the code for record-selector bindings
    -- when compiling hs-boot files
  | Bool
otherwise = TcGblEnv
tcg_env { tcg_binds = foldr (++)
                                            (tcg_binds tcg_env)
                                            binds }
{-
************************************************************************
*                                                                      *
*                      tcLookupGlobal                                  *
*                                                                      *
************************************************************************

Using the Located versions (eg. tcLookupLocatedGlobal) is preferred,
unless you know that the SrcSpan in the monad is already set to the
span of the Name.
-}


tcLookupLocatedGlobal :: LocatedA Name -> TcM TyThing
-- c.f. GHC.IfaceToCore.tcIfaceGlobal
tcLookupLocatedGlobal :: LocatedA Name -> TcM TyThing
tcLookupLocatedGlobal LocatedA Name
name
  = (Name -> TcM TyThing) -> LocatedA Name -> TcM TyThing
forall t a b. HasLoc t => (a -> TcM b) -> GenLocated t a -> TcM b
addLocM Name -> TcM TyThing
tcLookupGlobal LocatedA Name
name

tcLookupGlobal :: Name -> TcM TyThing
-- The Name is almost always an ExternalName, but not always
-- In GHCi, we may make command-line bindings (ghci> let x = True)
-- that bind a GlobalId, but with an InternalName
tcLookupGlobal :: Name -> TcM TyThing
tcLookupGlobal Name
name
  = do  {    -- Try local envt
          env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
        ; case lookupNameEnv (tcg_type_env env) name of {
                Just TyThing
thing -> TyThing -> TcM TyThing
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return TyThing
thing ;
                Maybe TyThing
Nothing    ->

                -- Should it have been in the local envt?
                -- (NB: use semantic mod here, since names never use
                -- identity module, see Note [Identity versus semantic module].)
          if Module -> Name -> Bool
nameIsLocalOrFrom (TcGblEnv -> Module
tcg_semantic_mod TcGblEnv
env) Name
name
          then Name -> TcM TyThing
notFound Name
name  -- Internal names can happen in GHCi
          else

           -- Try home package table and external package table
    do  { mb_thing <- Name -> TcM (MaybeErr IfaceMessage TyThing)
tcLookupImported_maybe Name
name
        ; case mb_thing of
            Succeeded TyThing
thing -> TyThing -> TcM TyThing
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return TyThing
thing
            Failed IfaceMessage
msg      -> TcRnMessage -> TcM TyThing
forall a. TcRnMessage -> TcM a
failWithTc (IfaceMessage -> TcRnMessage
TcRnInterfaceError IfaceMessage
msg)
        }}}

-- Look up only in this module's global env't. Don't look in imports, etc.
-- Panic if it's not there.
tcLookupGlobalOnly :: Name -> TcM TyThing
tcLookupGlobalOnly :: Name -> TcM TyThing
tcLookupGlobalOnly Name
name
  = do { env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
       ; return $ case lookupNameEnv (tcg_type_env env) name of
                    Just TyThing
thing -> TyThing
thing
                    Maybe TyThing
Nothing    -> String -> SDoc -> TyThing
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcLookupGlobalOnly" (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name) }

tcLookupDataCon :: Name -> TcM DataCon
tcLookupDataCon :: Name -> TcM DataCon
tcLookupDataCon Name
name = do
    thing <- Name -> TcM TyThing
tcLookupGlobal Name
name
    case thing of
        AConLike (RealDataCon DataCon
con) -> DataCon -> TcM DataCon
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return DataCon
con
        TyThing
_                          -> WrongThingSort -> TcTyThing -> Name -> TcM DataCon
forall a. WrongThingSort -> TcTyThing -> Name -> TcM a
wrongThingErr WrongThingSort
WrongThingDataCon (TyThing -> TcTyThing
AGlobal TyThing
thing) Name
name

tcLookupPatSyn :: Name -> TcM PatSyn
tcLookupPatSyn :: Name -> TcM PatSyn
tcLookupPatSyn Name
name = do
    thing <- Name -> TcM TyThing
tcLookupGlobal Name
name
    case thing of
        AConLike (PatSynCon PatSyn
ps) -> PatSyn -> TcM PatSyn
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return PatSyn
ps
        TyThing
_                       -> WrongThingSort -> TcTyThing -> Name -> TcM PatSyn
forall a. WrongThingSort -> TcTyThing -> Name -> TcM a
wrongThingErr WrongThingSort
WrongThingPatSyn (TyThing -> TcTyThing
AGlobal TyThing
thing) Name
name

tcLookupConLike :: Name -> TcM ConLike
tcLookupConLike :: Name -> TcM ConLike
tcLookupConLike Name
name = do
    thing <- Name -> TcM TyThing
tcLookupGlobal Name
name
    case thing of
        AConLike ConLike
cl -> ConLike -> TcM ConLike
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ConLike
cl
        ATyCon  {}  -> WhatLooking -> Name -> TcM ConLike
forall a. WhatLooking -> Name -> TcM a
failIllegalTyCon WhatLooking
WL_Constructor Name
name
        TyThing
_           -> WrongThingSort -> TcTyThing -> Name -> TcM ConLike
forall a. WrongThingSort -> TcTyThing -> Name -> TcM a
wrongThingErr WrongThingSort
WrongThingConLike (TyThing -> TcTyThing
AGlobal TyThing
thing) Name
name

tcLookupRecSelParent :: HsRecUpdParent GhcRn -> TcM RecSelParent
tcLookupRecSelParent :: HsRecUpdParent GhcRn -> TcM RecSelParent
tcLookupRecSelParent (RnRecUpdParent { rnRecUpdCons :: HsRecUpdParent GhcRn -> UniqSet ConLikeName
rnRecUpdCons = UniqSet ConLikeName
cons })
  = case ConLikeName
any_con of
      PatSynName Name
ps ->
        PatSyn -> RecSelParent
RecSelPatSyn (PatSyn -> RecSelParent) -> TcM PatSyn -> TcM RecSelParent
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> TcM PatSyn
tcLookupPatSyn Name
ps
      DataConName Name
dc ->
        TyCon -> RecSelParent
RecSelData (TyCon -> RecSelParent)
-> (DataCon -> TyCon) -> DataCon -> RecSelParent
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DataCon -> TyCon
dataConTyCon (DataCon -> RecSelParent) -> TcM DataCon -> TcM RecSelParent
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> TcM DataCon
tcLookupDataCon Name
dc
  where
    any_con :: ConLikeName
any_con = [ConLikeName] -> ConLikeName
forall a. HasCallStack => [a] -> a
head ([ConLikeName] -> ConLikeName) -> [ConLikeName] -> ConLikeName
forall a b. (a -> b) -> a -> b
$ UniqSet ConLikeName -> [ConLikeName]
forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet UniqSet ConLikeName
cons
      -- Any constructor will give the same result here.

tcLookupClass :: Name -> TcM Class
tcLookupClass :: Name -> TcM Class
tcLookupClass Name
name = do
    thing <- Name -> TcM TyThing
tcLookupGlobal Name
name
    case thing of
        ATyCon TyCon
tc | Just Class
cls <- TyCon -> Maybe Class
tyConClass_maybe TyCon
tc -> Class -> TcM Class
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Class
cls
        TyThing
_                                           -> WrongThingSort -> TcTyThing -> Name -> TcM Class
forall a. WrongThingSort -> TcTyThing -> Name -> TcM a
wrongThingErr WrongThingSort
WrongThingClass (TyThing -> TcTyThing
AGlobal TyThing
thing) Name
name

tcLookupTyCon :: Name -> TcM TyCon
tcLookupTyCon :: Name -> TcM TyCon
tcLookupTyCon Name
name = do
    thing <- Name -> TcM TyThing
tcLookupGlobal Name
name
    case thing of
        ATyCon TyCon
tc -> TyCon -> TcM TyCon
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return TyCon
tc
        TyThing
_         -> WrongThingSort -> TcTyThing -> Name -> TcM TyCon
forall a. WrongThingSort -> TcTyThing -> Name -> TcM a
wrongThingErr WrongThingSort
WrongThingTyCon (TyThing -> TcTyThing
AGlobal TyThing
thing) Name
name

tcLookupAxiom :: Name -> TcM (CoAxiom Branched)
tcLookupAxiom :: Name -> TcM (CoAxiom Branched)
tcLookupAxiom Name
name = do
    thing <- Name -> TcM TyThing
tcLookupGlobal Name
name
    case thing of
        ACoAxiom CoAxiom Branched
ax -> CoAxiom Branched -> TcM (CoAxiom Branched)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return CoAxiom Branched
ax
        TyThing
_           -> WrongThingSort -> TcTyThing -> Name -> TcM (CoAxiom Branched)
forall a. WrongThingSort -> TcTyThing -> Name -> TcM a
wrongThingErr WrongThingSort
WrongThingAxiom (TyThing -> TcTyThing
AGlobal TyThing
thing) Name
name

tcLookupLocatedGlobalId :: LocatedA Name -> TcM Id
tcLookupLocatedGlobalId :: LocatedA Name -> TcM Id
tcLookupLocatedGlobalId = (Name -> TcM Id) -> LocatedA Name -> TcM Id
forall t a b. HasLoc t => (a -> TcM b) -> GenLocated t a -> TcM b
addLocM Name -> TcM Id
tcLookupId

tcLookupLocatedClass :: LocatedA Name -> TcM Class
tcLookupLocatedClass :: LocatedA Name -> TcM Class
tcLookupLocatedClass = (Name -> TcM Class) -> LocatedA Name -> TcM Class
forall t a b. HasLoc t => (a -> TcM b) -> GenLocated t a -> TcM b
addLocM Name -> TcM Class
tcLookupClass

tcLookupLocatedTyCon :: LocatedN Name -> TcM TyCon
tcLookupLocatedTyCon :: LocatedN Name -> TcM TyCon
tcLookupLocatedTyCon = (Name -> TcM TyCon) -> LocatedN Name -> TcM TyCon
forall t a b. HasLoc t => (a -> TcM b) -> GenLocated t a -> TcM b
addLocM Name -> TcM TyCon
tcLookupTyCon

-- Find the instance that exactly matches a type class application.  The class arguments must be precisely
-- the same as in the instance declaration (modulo renaming & casts).
--
tcLookupInstance :: Class -> [Type] -> TcM ClsInst
tcLookupInstance :: Class -> [Type] -> TcM ClsInst
tcLookupInstance Class
cls [Type]
tys
  = do { instEnv <- TcM InstEnvs
tcGetInstEnvs
       ; let inst = InstEnvs
-> Class
-> [Type]
-> Either LookupInstanceErrReason (ClsInst, [Type])
lookupUniqueInstEnv InstEnvs
instEnv Class
cls [Type]
tys Either LookupInstanceErrReason (ClsInst, [Type])
-> ((ClsInst, [Type]) -> Either LookupInstanceErrReason ClsInst)
-> Either LookupInstanceErrReason ClsInst
forall a b.
Either LookupInstanceErrReason a
-> (a -> Either LookupInstanceErrReason b)
-> Either LookupInstanceErrReason b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ (ClsInst
inst, [Type]
tys) ->
                    if [Type] -> Bool
uniqueTyVars [Type]
tys then ClsInst -> Either LookupInstanceErrReason ClsInst
forall a b. b -> Either a b
Right ClsInst
inst else LookupInstanceErrReason -> Either LookupInstanceErrReason ClsInst
forall a b. a -> Either a b
Left LookupInstanceErrReason
LookupInstErrNotExact
        ; case inst of
          Right ClsInst
i -> ClsInst -> TcM ClsInst
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ClsInst
i
          Left LookupInstanceErrReason
err -> TcRnMessage -> TcM ClsInst
forall a. TcRnMessage -> TcM a
failWithTc (Class -> [Type] -> LookupInstanceErrReason -> TcRnMessage
TcRnLookupInstance Class
cls [Type]
tys LookupInstanceErrReason
err)
       }
  where
    uniqueTyVars :: [Type] -> Bool
uniqueTyVars [Type]
tys = (Type -> Bool) -> [Type] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Type -> Bool
isTyVarTy [Type]
tys
                    Bool -> Bool -> Bool
&& [Id] -> Bool
forall a. Eq a => [a] -> Bool
hasNoDups ((Type -> Id) -> [Type] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map HasDebugCallStack => Type -> Id
Type -> Id
getTyVar [Type]
tys)

tcGetInstEnvs :: TcM InstEnvs
-- Gets both the external-package inst-env
-- and the home-pkg inst env (includes module being compiled)
tcGetInstEnvs :: TcM InstEnvs
tcGetInstEnvs = do { eps <- TcRnIf TcGblEnv TcLclEnv ExternalPackageState
forall gbl lcl. TcRnIf gbl lcl ExternalPackageState
getEps
                   ; env <- getGblEnv
                   ; return (InstEnvs { ie_global  = eps_inst_env eps
                                      , ie_local   = tcg_inst_env env
                                      , ie_visible = tcVisibleOrphanMods env }) }

instance MonadThings (IOEnv (Env TcGblEnv TcLclEnv)) where
    lookupThing :: Name -> TcM TyThing
lookupThing = Name -> TcM TyThing
tcLookupGlobal

-- Illegal term-level use of type things
failIllegalTyCon :: WhatLooking -> Name -> TcM a
failIllegalTyVal :: Name -> TcM a
(WhatLooking -> Name -> TcM a
failIllegalTyCon, Name -> TcM a
failIllegalTyVal) = (WhatLooking -> Name -> TcM a
forall a. WhatLooking -> Name -> TcM a
fail_tycon, Name -> TcM a
forall {b}. Name -> IOEnv (Env TcGblEnv TcLclEnv) b
fail_tyvar)
  where
    fail_tycon :: WhatLooking -> Name -> IOEnv (Env TcGblEnv TcLclEnv) b
fail_tycon WhatLooking
what_looking Name
tc_nm = do
      gre <- TcRn GlobalRdrEnv
getGlobalRdrEnv
      let mb_gre = GlobalRdrEnv -> Name -> Maybe (GlobalRdrEltX GREInfo)
forall info.
Outputable info =>
GlobalRdrEnvX info -> Name -> Maybe (GlobalRdrEltX info)
lookupGRE_Name GlobalRdrEnv
gre Name
tc_nm
          pprov = case Maybe (GlobalRdrEltX GREInfo)
mb_gre of
                      Just GlobalRdrEltX GREInfo
gre -> ThLevel -> SDoc -> SDoc
nest ThLevel
2 (GlobalRdrEltX GREInfo -> SDoc
forall info. GlobalRdrEltX info -> SDoc
pprNameProvenance GlobalRdrEltX GREInfo
gre)
                      Maybe (GlobalRdrEltX GREInfo)
Nothing  -> SDoc
forall doc. IsOutput doc => doc
empty
          err = case GlobalRdrEltX GREInfo -> GREInfo
greInfo (GlobalRdrEltX GREInfo -> GREInfo)
-> Maybe (GlobalRdrEltX GREInfo) -> Maybe GREInfo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (GlobalRdrEltX GREInfo)
mb_gre of
            Just (IAmTyCon TyConFlavour Name
ClassFlavour) -> TermLevelUseErr
ClassTE
            Maybe GREInfo
_ -> TermLevelUseErr
TyConTE
      fail_with_msg what_looking dataName tc_nm pprov err

    fail_tyvar :: Name -> IOEnv (Env TcGblEnv TcLclEnv) b
fail_tyvar Name
nm =
      let pprov :: SDoc
pprov = ThLevel -> SDoc -> SDoc
nest ThLevel
2 (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"bound at" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SrcLoc -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Name -> SrcLoc
forall a. NamedThing a => a -> SrcLoc
getSrcLoc Name
nm))
      in WhatLooking
-> NameSpace
-> Name
-> SDoc
-> TermLevelUseErr
-> IOEnv (Env TcGblEnv TcLclEnv) b
forall {b}.
WhatLooking
-> NameSpace
-> Name
-> SDoc
-> TermLevelUseErr
-> IOEnv (Env TcGblEnv TcLclEnv) b
fail_with_msg WhatLooking
WL_Anything NameSpace
varName Name
nm SDoc
pprov TermLevelUseErr
TyVarTE

    fail_with_msg :: WhatLooking
-> NameSpace
-> Name
-> SDoc
-> TermLevelUseErr
-> IOEnv (Env TcGblEnv TcLclEnv) b
fail_with_msg WhatLooking
what_looking NameSpace
whatName Name
nm SDoc
pprov TermLevelUseErr
err = do
      (import_errs, hints) <- WhatLooking
-> NameSpace
-> Name
-> IOEnv (Env TcGblEnv TcLclEnv) ([ImportError], [GhcHint])
forall {name}.
HasOccName name =>
WhatLooking
-> NameSpace
-> name
-> IOEnv (Env TcGblEnv TcLclEnv) ([ImportError], [GhcHint])
get_suggestions WhatLooking
what_looking NameSpace
whatName Name
nm
      unit_state <- hsc_units <$> getTopEnv
      let
        -- TODO: unfortunate to have to convert to SDoc here.
        -- This should go away once we refactor ErrInfo.
        hint_msg = [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ (GhcHint -> SDoc) -> [GhcHint] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map GhcHint -> SDoc
forall a. Outputable a => a -> SDoc
ppr [GhcHint]
hints
        import_err_msg = [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ (ImportError -> SDoc) -> [ImportError] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map ImportError -> SDoc
forall a. Outputable a => a -> SDoc
ppr [ImportError]
import_errs
        info = ErrInfo { errInfoContext :: SDoc
errInfoContext = SDoc
pprov, errInfoSupplementary :: SDoc
errInfoSupplementary = SDoc
import_err_msg SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ SDoc
hint_msg }
      failWithTc $ TcRnMessageWithInfo unit_state (
              mkDetailedMessage info (TcRnIllegalTermLevelUse nm err))

    get_suggestions :: WhatLooking
-> NameSpace
-> name
-> IOEnv (Env TcGblEnv TcLclEnv) ([ImportError], [GhcHint])
get_suggestions WhatLooking
what_looking NameSpace
ns name
nm = do
      required_type_arguments <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.RequiredTypeArguments
      if required_type_arguments && isVarNameSpace ns
      then return ([], [])  -- See Note [Suppress hints with RequiredTypeArguments]
      else do
        let occ = NameSpace -> FastString -> OccName
mkOccNameFS NameSpace
ns (OccName -> FastString
occNameFS (name -> OccName
forall name. HasOccName name => name -> OccName
occName name
nm))
        lcl_env <- getLocalRdrEnv
        unknownNameSuggestions lcl_env what_looking (mkRdrUnqual occ)
{-
************************************************************************
*                                                                      *
                Extending the global environment
*                                                                      *
************************************************************************
-}

setGlobalTypeEnv :: TcGblEnv -> TypeEnv -> TcM TcGblEnv
-- Use this to update the global type env
-- It updates both  * the normal tcg_type_env field
--                  * the tcg_type_env_var field seen by interface files
setGlobalTypeEnv :: TcGblEnv -> NameEnv TyThing -> TcRnIf TcGblEnv TcLclEnv TcGblEnv
setGlobalTypeEnv TcGblEnv
tcg_env NameEnv TyThing
new_type_env
  = do  {     -- Sync the type-envt variable seen by interface files
         ; case KnotVars (IORef (NameEnv TyThing))
-> Module -> Maybe (IORef (NameEnv TyThing))
forall a. KnotVars a -> Module -> Maybe a
lookupKnotVars (TcGblEnv -> KnotVars (IORef (NameEnv TyThing))
tcg_type_env_var TcGblEnv
tcg_env) (TcGblEnv -> Module
tcg_mod TcGblEnv
tcg_env) of
              Just IORef (NameEnv TyThing)
tcg_env_var -> IORef (NameEnv TyThing)
-> NameEnv TyThing -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a env. IORef a -> a -> IOEnv env ()
writeMutVar IORef (NameEnv TyThing)
tcg_env_var NameEnv TyThing
new_type_env
              Maybe (IORef (NameEnv TyThing))
Nothing -> () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
         ; TcGblEnv -> TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv
tcg_env { tcg_type_env = new_type_env }) }


tcExtendGlobalEnvImplicit :: [TyThing] -> TcM r -> TcM r
  -- Just extend the global environment with some TyThings
  -- Do not extend tcg_tcs, tcg_patsyns etc
tcExtendGlobalEnvImplicit :: forall r. [TyThing] -> TcM r -> TcM r
tcExtendGlobalEnvImplicit [TyThing]
things TcM r
thing_inside
   = do { tcg_env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
        ; let ge'  = NameEnv TyThing -> [TyThing] -> NameEnv TyThing
extendTypeEnvList (TcGblEnv -> NameEnv TyThing
tcg_type_env TcGblEnv
tcg_env) [TyThing]
things
        ; tcg_env' <- setGlobalTypeEnv tcg_env ge'
        ; setGblEnv tcg_env' thing_inside }

tcExtendGlobalEnv :: [TyThing] -> TcM r -> TcM r
  -- Given a mixture of Ids, TyCons, Classes, all defined in the
  -- module being compiled, extend the global environment
tcExtendGlobalEnv :: forall r. [TyThing] -> TcM r -> TcM r
tcExtendGlobalEnv [TyThing]
things TcM r
thing_inside
  = do { env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
       ; let env' = TcGblEnv
env { tcg_tcs = [tc | ATyCon tc <- things] ++ tcg_tcs env,
                          tcg_patsyns = [ps | AConLike (PatSynCon ps) <- things] ++ tcg_patsyns env }
       ; setGblEnv env' $
            tcExtendGlobalEnvImplicit things thing_inside
       }

tcExtendTyConEnv :: [TyCon] -> TcM r -> TcM r
  -- Given a mixture of Ids, TyCons, Classes, all defined in the
  -- module being compiled, extend the global environment
tcExtendTyConEnv :: forall r. [TyCon] -> TcM r -> TcM r
tcExtendTyConEnv [TyCon]
tycons TcM r
thing_inside
  = do { env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
       ; let env' = TcGblEnv
env { tcg_tcs = tycons ++ tcg_tcs env }
       ; setGblEnv env' $
         tcExtendGlobalEnvImplicit (map ATyCon tycons) thing_inside
       }

-- Given a [TyThing] of "non-value" bindings coming from type decls
-- (constructors, field selectors, class methods) return their
-- TH binding levels (to be added to a LclEnv).
-- See GHC ticket #17820 .
tcTyThBinders :: [TyThing] -> TcM ThBindEnv
tcTyThBinders :: [TyThing] -> TcM ThBindEnv
tcTyThBinders [TyThing]
implicit_things = do
  stage <- TcM ThStage
getStage
  let th_lvl  = ThStage -> ThLevel
thLevel ThStage
stage
      th_bndrs = [(Name, (TopLevelFlag, ThLevel))] -> ThBindEnv
forall a. [(Name, a)] -> NameEnv a
mkNameEnv
                  [ ( Name
n , (TopLevelFlag
TopLevel, ThLevel
th_lvl) ) | Name
n <- [Name]
names ]
  return th_bndrs
  where
    names :: [Name]
names = (TyThing -> [Name]) -> [TyThing] -> [Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TyThing -> [Name]
get_names [TyThing]
implicit_things
    get_names :: TyThing -> [Name]
get_names (AConLike ConLike
acl) =
      ConLike -> Name
conLikeName ConLike
acl Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: (FieldLabel -> Name) -> [FieldLabel] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map FieldLabel -> Name
flSelector (ConLike -> [FieldLabel]
conLikeFieldLabels ConLike
acl)
    get_names (AnId Id
i) = [Id -> Name
idName Id
i]
    get_names TyThing
_ = []

tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a
  -- Same deal as tcExtendGlobalEnv, but for Ids
tcExtendGlobalValEnv :: forall a. [Id] -> TcM a -> TcM a
tcExtendGlobalValEnv [Id]
ids TcM a
thing_inside
  = [TyThing] -> TcM a -> TcM a
forall r. [TyThing] -> TcM r -> TcM r
tcExtendGlobalEnvImplicit [Id -> TyThing
AnId Id
id | Id
id <- [Id]
ids] TcM a
thing_inside

tcExtendRecEnv :: [(Name,TyThing)] -> TcM r -> TcM r
-- Extend the global environments for the type/class knot tying game
-- Just like tcExtendGlobalEnv, except the argument is a list of pairs
tcExtendRecEnv :: forall r. [(Name, TyThing)] -> TcM r -> TcM r
tcExtendRecEnv [(Name, TyThing)]
gbl_stuff TcM r
thing_inside
 = do  { tcg_env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
       ; let ge'      = NameEnv TyThing -> [(Name, TyThing)] -> NameEnv TyThing
forall a. NameEnv a -> [(Name, a)] -> NameEnv a
extendNameEnvList (TcGblEnv -> NameEnv TyThing
tcg_type_env TcGblEnv
tcg_env) [(Name, TyThing)]
gbl_stuff
             tcg_env' = TcGblEnv
tcg_env { tcg_type_env = ge' }
         -- No need for setGlobalTypeEnv (which side-effects the
         -- tcg_type_env_var); tcExtendRecEnv is used just
         -- when kind-check a group of type/class decls. It would
         -- in any case be wrong for an interface-file decl to end up
         -- with a TcTyCon in it!
       ; setGblEnv tcg_env' thing_inside }

{-
************************************************************************
*                                                                      *
\subsection{The local environment}
*                                                                      *
************************************************************************
-}

tcLookupLocated :: LocatedA Name -> TcM TcTyThing
tcLookupLocated :: LocatedA Name -> TcM TcTyThing
tcLookupLocated = (Name -> TcM TcTyThing) -> LocatedA Name -> TcM TcTyThing
forall t a b. HasLoc t => (a -> TcM b) -> GenLocated t a -> TcM b
addLocM Name -> TcM TcTyThing
tcLookup

tcLookupLcl_maybe :: Name -> TcM (Maybe TcTyThing)
tcLookupLcl_maybe :: Name -> TcM (Maybe TcTyThing)
tcLookupLcl_maybe Name
name
  = do { local_env <- TcM TcTypeEnv
getLclTypeEnv
       ; return (lookupNameEnv local_env name) }

tcLookup :: Name -> TcM TcTyThing
tcLookup :: Name -> TcM TcTyThing
tcLookup Name
name = do
    local_env <- TcM TcTypeEnv
getLclTypeEnv
    case lookupNameEnv local_env name of
        Just TcTyThing
thing -> TcTyThing -> TcM TcTyThing
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return TcTyThing
thing
        Maybe TcTyThing
Nothing    -> TyThing -> TcTyThing
AGlobal (TyThing -> TcTyThing) -> TcM TyThing -> TcM TcTyThing
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> TcM TyThing
tcLookupGlobal Name
name

tcLookupTyVar :: Name -> TcM TcTyVar
tcLookupTyVar :: Name -> TcM Id
tcLookupTyVar Name
name
  = do { thing <- Name -> TcM TcTyThing
tcLookup Name
name
       ; case thing of
           ATyVar Name
_ Id
tv -> Id -> TcM Id
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Id
tv
           TcTyThing
_           -> String -> SDoc -> TcM Id
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcLookupTyVar" (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name) }

tcLookupId :: Name -> TcM Id
-- Used when we aren't interested in the binding level, nor refinement.
-- The "no refinement" part means that we return the un-refined Id regardless
--
-- The Id is never a DataCon. (Why does that matter? see GHC.Tc.Gen.Expr.tcId)
tcLookupId :: Name -> TcM Id
tcLookupId Name
name = do
    thing <- Name -> TcM (Maybe Id)
tcLookupIdMaybe Name
name
    case thing of
        Just Id
id -> Id -> TcM Id
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Id
id
        Maybe Id
_       -> String -> SDoc -> TcM Id
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcLookupId" (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name)

tcLookupIdMaybe :: Name -> TcM (Maybe Id)
tcLookupIdMaybe :: Name -> TcM (Maybe Id)
tcLookupIdMaybe Name
name
  = do { thing <- Name -> TcM TcTyThing
tcLookup Name
name
       ; case thing of
           ATcId { tct_id :: TcTyThing -> Id
tct_id = Id
id} -> Maybe Id -> TcM (Maybe Id)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Id -> TcM (Maybe Id)) -> Maybe Id -> TcM (Maybe Id)
forall a b. (a -> b) -> a -> b
$ Id -> Maybe Id
forall a. a -> Maybe a
Just Id
id
           AGlobal (AnId Id
id)    -> Maybe Id -> TcM (Maybe Id)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Id -> TcM (Maybe Id)) -> Maybe Id -> TcM (Maybe Id)
forall a b. (a -> b) -> a -> b
$ Id -> Maybe Id
forall a. a -> Maybe a
Just Id
id
           TcTyThing
_                    -> Maybe Id -> TcM (Maybe Id)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Id
forall a. Maybe a
Nothing }

tcLookupLocalIds :: [Name] -> TcM [TcId]
-- We expect the variables to all be bound, and all at
-- the same level as the lookup.  Only used in one place...
tcLookupLocalIds :: [Name] -> TcM [Id]
tcLookupLocalIds [Name]
ns
  = do { env <- TcRnIf TcGblEnv TcLclEnv TcLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv
       ; return (map (lookup (getLclEnvTypeEnv env)) ns) }
  where
    lookup :: TcTypeEnv -> Name -> Id
lookup TcTypeEnv
lenv Name
name
        = case TcTypeEnv -> Name -> Maybe TcTyThing
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv TcTypeEnv
lenv Name
name of
                Just (ATcId { tct_id :: TcTyThing -> Id
tct_id = Id
id }) ->  Id
id
                Maybe TcTyThing
_ -> String -> SDoc -> Id
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcLookupLocalIds" (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name)

-- inferInitialKind has made a suitably-shaped kind for the type or class
-- Look it up in the local environment. This is used only for tycons
-- that we're currently type-checking, so we're sure to find a TcTyCon.
tcLookupTcTyCon :: HasDebugCallStack => Name -> TcM TcTyCon
tcLookupTcTyCon :: HasDebugCallStack => Name -> TcM TyCon
tcLookupTcTyCon Name
name = do
    thing <- Name -> TcM TcTyThing
tcLookup Name
name
    case thing of
        ATcTyCon TyCon
tc -> TyCon -> TcM TyCon
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return TyCon
tc
        TcTyThing
_           -> String -> SDoc -> TcM TyCon
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcLookupTcTyCon" (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name)


getInLocalScope :: TcM (Name -> Bool)
getInLocalScope :: TcM (Name -> Bool)
getInLocalScope = do { lcl_env <- TcM TcTypeEnv
getLclTypeEnv
                     ; return (`elemNameEnv` lcl_env) }

tcExtendKindEnvList :: [(Name, TcTyThing)] -> TcM r -> TcM r
-- Used only during kind checking, for TcThings that are
--      ATcTyCon or APromotionErr
-- No need to update the global tyvars, or tcl_th_bndrs, or tcl_rdr
tcExtendKindEnvList :: forall r. [(Name, TcTyThing)] -> TcM r -> TcM r
tcExtendKindEnvList [(Name, TcTyThing)]
things TcM r
thing_inside
  = do { String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"tcExtendKindEnvList" ([(Name, TcTyThing)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [(Name, TcTyThing)]
things)
       ; (TcLclCtxt -> TcLclCtxt) -> TcM r -> TcM r
forall gbl a.
(TcLclCtxt -> TcLclCtxt)
-> TcRnIf gbl TcLclEnv a -> TcRnIf gbl TcLclEnv a
updLclCtxt TcLclCtxt -> TcLclCtxt
upd_env TcM r
thing_inside }
  where
    upd_env :: TcLclCtxt -> TcLclCtxt
upd_env TcLclCtxt
env = TcLclCtxt
env { tcl_env = extendNameEnvList (tcl_env env) things }

tcExtendKindEnv :: NameEnv TcTyThing -> TcM r -> TcM r
-- A variant of tcExtendKindEvnList
tcExtendKindEnv :: forall r. TcTypeEnv -> TcM r -> TcM r
tcExtendKindEnv TcTypeEnv
extra_env TcM r
thing_inside
  = do { String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"tcExtendKindEnv" (TcTypeEnv -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcTypeEnv
extra_env)
       ; (TcLclCtxt -> TcLclCtxt) -> TcM r -> TcM r
forall gbl a.
(TcLclCtxt -> TcLclCtxt)
-> TcRnIf gbl TcLclEnv a -> TcRnIf gbl TcLclEnv a
updLclCtxt TcLclCtxt -> TcLclCtxt
upd_env TcM r
thing_inside }
  where
    upd_env :: TcLclCtxt -> TcLclCtxt
upd_env TcLclCtxt
env = TcLclCtxt
env { tcl_env = tcl_env env `plusNameEnv` extra_env }

-----------------------
-- Scoped type and kind variables
tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r
tcExtendTyVarEnv :: forall a. [Id] -> TcM a -> TcM a
tcExtendTyVarEnv [Id]
tvs TcM r
thing_inside
  -- MP: This silently coerces TyVar to TcTyVar.
  = [(Name, Id)] -> TcM r -> TcM r
forall r. [(Name, Id)] -> TcM r -> TcM r
tcExtendNameTyVarEnv ([Id] -> [(Name, Id)]
mkTyVarNamePairs [Id]
tvs) TcM r
thing_inside

tcExtendNameTyVarEnv :: [(Name,TcTyVar)] -> TcM r -> TcM r
tcExtendNameTyVarEnv :: forall r. [(Name, Id)] -> TcM r -> TcM r
tcExtendNameTyVarEnv [(Name, Id)]
binds TcM r
thing_inside
  -- this should be used only for explicitly mentioned scoped variables.
  -- thus, no coercion variables
  = TopLevelFlag -> [(Name, TcTyThing)] -> TcM r -> TcM r
forall a. TopLevelFlag -> [(Name, TcTyThing)] -> TcM a -> TcM a
tc_extend_local_env TopLevelFlag
NotTopLevel [(Name, TcTyThing)]
names (TcM r -> TcM r) -> TcM r -> TcM r
forall a b. (a -> b) -> a -> b
$
        [TcBinder] -> TcM r -> TcM r
forall a. [TcBinder] -> TcM a -> TcM a
tcExtendBinderStack [TcBinder]
tv_binds (TcM r -> TcM r) -> TcM r -> TcM r
forall a b. (a -> b) -> a -> b
$
        TcM r
thing_inside
  where
    tv_binds :: [TcBinder]
    tv_binds :: [TcBinder]
tv_binds = [Name -> Id -> TcBinder
TcTvBndr Name
name Id
tv | (Name
name,Id
tv) <- [(Name, Id)]
binds]

    names :: [(Name, TcTyThing)]
names = [(Name
name, Name -> Id -> TcTyThing
ATyVar Name
name Id
tv) | (Name
name, Id
tv) <- [(Name, Id)]
binds]

isTypeClosedLetBndr :: Id -> Bool
-- See Note [Bindings with closed types: ClosedTypeId] in GHC.Tc.Types
isTypeClosedLetBndr :: Id -> Bool
isTypeClosedLetBndr = Type -> Bool
noFreeVarsOfType (Type -> Bool) -> (Id -> Type) -> Id -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Type
idType

tcExtendRecIds :: [(Name, TcId)] -> TcM a -> TcM a
-- Used for binding the recursive uses of Ids in a binding
-- both top-level value bindings and nested let/where-bindings
-- Does not extend the TcBinderStack
tcExtendRecIds :: forall r. [(Name, Id)] -> TcM r -> TcM r
tcExtendRecIds [(Name, Id)]
pairs TcM a
thing_inside
  = TopLevelFlag -> [(Name, TcTyThing)] -> TcM a -> TcM a
forall a. TopLevelFlag -> [(Name, TcTyThing)] -> TcM a -> TcM a
tc_extend_local_env TopLevelFlag
NotTopLevel
          [ (Name
name, ATcId { tct_id :: Id
tct_id   = Id
let_id
                         , tct_info :: IdBindingInfo
tct_info = RhsNames -> Bool -> IdBindingInfo
NonClosedLet RhsNames
emptyNameSet Bool
False })
          | (Name
name, Id
let_id) <- [(Name, Id)]
pairs ] (TcM a -> TcM a) -> TcM a -> TcM a
forall a b. (a -> b) -> a -> b
$
    TcM a
thing_inside

tcExtendSigIds :: TopLevelFlag -> [TcId] -> TcM a -> TcM a
-- Used for binding the Ids that have a complete user type signature
-- Does not extend the TcBinderStack
tcExtendSigIds :: forall a. TopLevelFlag -> [Id] -> TcM a -> TcM a
tcExtendSigIds TopLevelFlag
top_lvl [Id]
sig_ids TcM a
thing_inside
  = TopLevelFlag -> [(Name, TcTyThing)] -> TcM a -> TcM a
forall a. TopLevelFlag -> [(Name, TcTyThing)] -> TcM a -> TcM a
tc_extend_local_env TopLevelFlag
top_lvl
          [ (Id -> Name
idName Id
id, ATcId { tct_id :: Id
tct_id   = Id
id
                              , tct_info :: IdBindingInfo
tct_info = IdBindingInfo
info })
          | Id
id <- [Id]
sig_ids
          , let closed :: Bool
closed = Id -> Bool
isTypeClosedLetBndr Id
id
                info :: IdBindingInfo
info   = RhsNames -> Bool -> IdBindingInfo
NonClosedLet RhsNames
emptyNameSet Bool
closed ]
     TcM a
thing_inside


tcExtendLetEnv :: TopLevelFlag -> TcSigFun -> IsGroupClosed
                  -> [Scaled TcId] -> TcM a -> TcM a
-- Used for both top-level value bindings and nested let/where-bindings
-- Adds to the TcBinderStack too
tcExtendLetEnv :: forall a.
TopLevelFlag
-> TcSigFun -> IsGroupClosed -> [Scaled Id] -> TcM a -> TcM a
tcExtendLetEnv TopLevelFlag
top_lvl TcSigFun
sig_fn (IsGroupClosed NameEnv RhsNames
fvs Bool
fv_type_closed)
               [Scaled Id]
ids TcM a
thing_inside
  = [TcBinder] -> TcM a -> TcM a
forall a. [TcBinder] -> TcM a -> TcM a
tcExtendBinderStack [Id -> TopLevelFlag -> TcBinder
TcIdBndr Id
id TopLevelFlag
top_lvl | Scaled Type
_ Id
id <- [Scaled Id]
ids] (TcM a -> TcM a) -> TcM a -> TcM a
forall a b. (a -> b) -> a -> b
$
    TopLevelFlag -> [(Name, TcTyThing)] -> TcM a -> TcM a
forall a. TopLevelFlag -> [(Name, TcTyThing)] -> TcM a -> TcM a
tc_extend_local_env TopLevelFlag
top_lvl
          [ (Id -> Name
idName Id
id, ATcId { tct_id :: Id
tct_id   = Id
id
                              , tct_info :: IdBindingInfo
tct_info = Id -> IdBindingInfo
mk_tct_info Id
id })
          | Scaled Type
_ Id
id <- [Scaled Id]
ids ] (TcM a -> TcM a) -> TcM a -> TcM a
forall a b. (a -> b) -> a -> b
$
    (Scaled Name -> TcM a -> TcM a) -> TcM a -> [Scaled Name] -> TcM a
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Scaled Name -> TcM a -> TcM a
forall a. Scaled Name -> TcM a -> TcM a
check_usage TcM a
thing_inside [Scaled Name]
scaled_names
  where
    mk_tct_info :: Id -> IdBindingInfo
mk_tct_info Id
id
      | Bool
type_closed Bool -> Bool -> Bool
&& RhsNames -> Bool
isEmptyNameSet RhsNames
rhs_fvs = IdBindingInfo
ClosedLet
      | Bool
otherwise                             = RhsNames -> Bool -> IdBindingInfo
NonClosedLet RhsNames
rhs_fvs Bool
type_closed
      where
        name :: Name
name        = Id -> Name
idName Id
id
        rhs_fvs :: RhsNames
rhs_fvs     = NameEnv RhsNames -> Name -> Maybe RhsNames
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv NameEnv RhsNames
fvs Name
name Maybe RhsNames -> RhsNames -> RhsNames
forall a. Maybe a -> a -> a
`orElse` RhsNames
emptyNameSet
        type_closed :: Bool
type_closed = Id -> Bool
isTypeClosedLetBndr Id
id Bool -> Bool -> Bool
&&
                      (Bool
fv_type_closed Bool -> Bool -> Bool
|| TcSigFun -> Name -> Bool
hasCompleteSig TcSigFun
sig_fn Name
name)
    scaled_names :: [Scaled Name]
scaled_names = [Type -> Name -> Scaled Name
forall a. Type -> a -> Scaled a
Scaled Type
p (Id -> Name
idName Id
id) | Scaled Type
p Id
id <- [Scaled Id]
ids ]
    check_usage :: Scaled Name -> TcM a -> TcM a
    check_usage :: forall a. Scaled Name -> TcM a -> TcM a
check_usage (Scaled Type
p Name
id) TcM a
thing_inside = do
      Name -> Type -> TcM a -> TcM a
forall a. Name -> Type -> TcM a -> TcM a
tcCheckUsage Name
id Type
p TcM a
thing_inside

tcExtendIdEnv :: [TcId] -> TcM a -> TcM a
-- For lambda-bound and case-bound Ids
-- Extends the TcBinderStack as well
tcExtendIdEnv :: forall a. [Id] -> TcM a -> TcM a
tcExtendIdEnv [Id]
ids TcM a
thing_inside
  = [(Name, Id)] -> TcM a -> TcM a
forall r. [(Name, Id)] -> TcM r -> TcM r
tcExtendIdEnv2 [(Id -> Name
idName Id
id, Id
id) | Id
id <- [Id]
ids] TcM a
thing_inside

tcExtendIdEnv1 :: Name -> TcId -> TcM a -> TcM a
-- Exactly like tcExtendIdEnv2, but for a single (name,id) pair
tcExtendIdEnv1 :: forall a. Name -> Id -> TcM a -> TcM a
tcExtendIdEnv1 Name
name Id
id TcM a
thing_inside
  = [(Name, Id)] -> TcM a -> TcM a
forall r. [(Name, Id)] -> TcM r -> TcM r
tcExtendIdEnv2 [(Name
name,Id
id)] TcM a
thing_inside

tcExtendIdEnv2 :: [(Name,TcId)] -> TcM a -> TcM a
tcExtendIdEnv2 :: forall r. [(Name, Id)] -> TcM r -> TcM r
tcExtendIdEnv2 [(Name, Id)]
names_w_ids TcM a
thing_inside
  = [TcBinder] -> TcM a -> TcM a
forall a. [TcBinder] -> TcM a -> TcM a
tcExtendBinderStack [ Id -> TopLevelFlag -> TcBinder
TcIdBndr Id
mono_id TopLevelFlag
NotTopLevel
                        | (Name
_,Id
mono_id) <- [(Name, Id)]
names_w_ids ] (TcM a -> TcM a) -> TcM a -> TcM a
forall a b. (a -> b) -> a -> b
$
    TopLevelFlag -> [(Name, TcTyThing)] -> TcM a -> TcM a
forall a. TopLevelFlag -> [(Name, TcTyThing)] -> TcM a -> TcM a
tc_extend_local_env TopLevelFlag
NotTopLevel
            [ (Name
name, ATcId { tct_id :: Id
tct_id = Id
id
                           , tct_info :: IdBindingInfo
tct_info    = IdBindingInfo
NotLetBound })
            | (Name
name,Id
id) <- [(Name, Id)]
names_w_ids]
    TcM a
thing_inside

tc_extend_local_env :: TopLevelFlag -> [(Name, TcTyThing)] -> TcM a -> TcM a
tc_extend_local_env :: forall a. TopLevelFlag -> [(Name, TcTyThing)] -> TcM a -> TcM a
tc_extend_local_env TopLevelFlag
top_lvl [(Name, TcTyThing)]
extra_env TcM a
thing_inside
-- Precondition: the argument list extra_env has TcTyThings
--               that ATcId or ATyVar, but nothing else
--
-- Invariant: the ATcIds are fully zonked. Reasons:
--      (a) The kinds of the forall'd type variables are defaulted
--          (see Kind.defaultKind, done in skolemiseQuantifiedTyVar)
--      (b) There are no via-Indirect occurrences of the bound variables
--          in the types, because instantiation does not look through such things
--      (c) The call to tyCoVarsOfTypes is ok without looking through refs

-- The second argument of type TyVarSet is a set of type variables
-- that are bound together with extra_env and should not be regarded
-- as free in the types of extra_env.
  = do  { String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"tc_extend_local_env" ([(Name, TcTyThing)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [(Name, TcTyThing)]
extra_env)
        ; (TcLclCtxt -> TcLclCtxt) -> TcM a -> TcM a
forall gbl a.
(TcLclCtxt -> TcLclCtxt)
-> TcRnIf gbl TcLclEnv a -> TcRnIf gbl TcLclEnv a
updLclCtxt TcLclCtxt -> TcLclCtxt
upd_lcl_env TcM a
thing_inside }
  where
    upd_lcl_env :: TcLclCtxt -> TcLclCtxt
upd_lcl_env env0 :: TcLclCtxt
env0@(TcLclCtxt { tcl_th_ctxt :: TcLclCtxt -> ThStage
tcl_th_ctxt  = ThStage
stage
                               , tcl_rdr :: TcLclCtxt -> LocalRdrEnv
tcl_rdr      = LocalRdrEnv
rdr_env
                               , tcl_th_bndrs :: TcLclCtxt -> ThBindEnv
tcl_th_bndrs = ThBindEnv
th_bndrs
                               , tcl_env :: TcLclCtxt -> TcTypeEnv
tcl_env      = TcTypeEnv
lcl_type_env })
       = TcLclCtxt
env0 { tcl_rdr = extendLocalRdrEnvList rdr_env
                          [ n | (n, _) <- extra_env, isInternalName n ]
                          -- The LocalRdrEnv contains only non-top-level names
                          -- (GlobalRdrEnv handles the top level)

              , tcl_th_bndrs = extendNameEnvList th_bndrs
                               [(n, thlvl) | (n, _) <- extra_env]

              , tcl_env = extendNameEnvList lcl_type_env extra_env }
              -- tcl_rdr and tcl_th_bndrs: extend the local LocalRdrEnv and
              -- Template Haskell staging env simultaneously. Reason for extending
              -- LocalRdrEnv: after running a TH splice we need to do renaming.
      where
        thlvl :: (TopLevelFlag, ThLevel)
thlvl = (TopLevelFlag
top_lvl, ThStage -> ThLevel
thLevel ThStage
stage)


tcExtendLocalTypeEnv :: [(Name, TcTyThing)] -> TcLclCtxt -> TcLclCtxt
tcExtendLocalTypeEnv :: [(Name, TcTyThing)] -> TcLclCtxt -> TcLclCtxt
tcExtendLocalTypeEnv [(Name, TcTyThing)]
tc_ty_things lcl_env :: TcLclCtxt
lcl_env@(TcLclCtxt { tcl_env :: TcLclCtxt -> TcTypeEnv
tcl_env = TcTypeEnv
lcl_type_env })
  = TcLclCtxt
lcl_env { tcl_env = extendNameEnvList lcl_type_env tc_ty_things }

{- *********************************************************************
*                                                                      *
             The TcBinderStack
*                                                                      *
********************************************************************* -}

tcExtendBinderStack :: [TcBinder] -> TcM a -> TcM a
tcExtendBinderStack :: forall a. [TcBinder] -> TcM a -> TcM a
tcExtendBinderStack [TcBinder]
bndrs TcM a
thing_inside
  = do { String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"tcExtendBinderStack" ([TcBinder] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TcBinder]
bndrs)
       ; (TcLclCtxt -> TcLclCtxt) -> TcM a -> TcM a
forall gbl a.
(TcLclCtxt -> TcLclCtxt)
-> TcRnIf gbl TcLclEnv a -> TcRnIf gbl TcLclEnv a
updLclCtxt (\TcLclCtxt
env -> TcLclCtxt
env { tcl_bndrs = bndrs ++ tcl_bndrs env })
                   TcM a
thing_inside }

{- *********************************************************************
*                                                                      *
             Adding placeholders
*                                                                      *
********************************************************************* -}

tcAddDataFamConPlaceholders :: [LInstDecl GhcRn] -> TcM a -> TcM a
-- See Note [AFamDataCon: not promoting data family constructors]
tcAddDataFamConPlaceholders :: forall a. [LInstDecl GhcRn] -> TcM a -> TcM a
tcAddDataFamConPlaceholders [LInstDecl GhcRn]
inst_decls TcM a
thing_inside
  = [(Name, TcTyThing)] -> TcM a -> TcM a
forall r. [(Name, TcTyThing)] -> TcM r -> TcM r
tcExtendKindEnvList [ (Name
con, PromotionErr -> TcTyThing
APromotionErr PromotionErr
FamDataConPE)
                        | GenLocated SrcSpanAnnA (InstDecl GhcRn)
lid <- [LInstDecl GhcRn]
[GenLocated SrcSpanAnnA (InstDecl GhcRn)]
inst_decls, Name
con <- LInstDecl GhcRn -> [Name]
get_cons LInstDecl GhcRn
GenLocated SrcSpanAnnA (InstDecl GhcRn)
lid ]
      TcM a
thing_inside
      -- Note [AFamDataCon: not promoting data family constructors]
  where
    -- get_cons extracts the *constructor* bindings of the declaration
    get_cons :: LInstDecl GhcRn -> [Name]
    get_cons :: LInstDecl GhcRn -> [Name]
get_cons (L SrcSpanAnnA
_ (TyFamInstD {}))                     = []
    get_cons (L SrcSpanAnnA
_ (DataFamInstD { dfid_inst :: forall pass. InstDecl pass -> DataFamInstDecl pass
dfid_inst = DataFamInstDecl GhcRn
fid }))  = DataFamInstDecl GhcRn -> [Name]
get_fi_cons DataFamInstDecl GhcRn
fid
    get_cons (L SrcSpanAnnA
_ (ClsInstD { cid_inst :: forall pass. InstDecl pass -> ClsInstDecl pass
cid_inst = ClsInstDecl { cid_datafam_insts :: forall pass. ClsInstDecl pass -> [LDataFamInstDecl pass]
cid_datafam_insts = [LDataFamInstDecl GhcRn]
fids } }))
      = (GenLocated SrcSpanAnnA (DataFamInstDecl GhcRn) -> [Name])
-> [GenLocated SrcSpanAnnA (DataFamInstDecl GhcRn)] -> [Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (DataFamInstDecl GhcRn -> [Name]
get_fi_cons (DataFamInstDecl GhcRn -> [Name])
-> (GenLocated SrcSpanAnnA (DataFamInstDecl GhcRn)
    -> DataFamInstDecl GhcRn)
-> GenLocated SrcSpanAnnA (DataFamInstDecl GhcRn)
-> [Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (DataFamInstDecl GhcRn)
-> DataFamInstDecl GhcRn
forall l e. GenLocated l e -> e
unLoc) [LDataFamInstDecl GhcRn]
[GenLocated SrcSpanAnnA (DataFamInstDecl GhcRn)]
fids

    get_fi_cons :: DataFamInstDecl GhcRn -> [Name]
    get_fi_cons :: DataFamInstDecl GhcRn -> [Name]
get_fi_cons (DataFamInstDecl { dfid_eqn :: forall pass. DataFamInstDecl pass -> FamEqn pass (HsDataDefn pass)
dfid_eqn =
                  FamEqn { feqn_rhs :: forall pass rhs. FamEqn pass rhs -> rhs
feqn_rhs = HsDataDefn { dd_cons :: forall pass. HsDataDefn pass -> DataDefnCons (LConDecl pass)
dd_cons = DataDefnCons (LConDecl GhcRn)
cons } }})
      = (LocatedN Name -> Name) -> [LocatedN Name] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map LocatedN Name -> Name
forall l e. GenLocated l e -> e
unLoc ([LocatedN Name] -> [Name]) -> [LocatedN Name] -> [Name]
forall a b. (a -> b) -> a -> b
$ (GenLocated SrcSpanAnnA (ConDecl GhcRn) -> [LocatedN Name])
-> DataDefnCons (GenLocated SrcSpanAnnA (ConDecl GhcRn))
-> [LocatedN Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (ConDecl GhcRn -> [LocatedN Name]
getConNames (ConDecl GhcRn -> [LocatedN Name])
-> (GenLocated SrcSpanAnnA (ConDecl GhcRn) -> ConDecl GhcRn)
-> GenLocated SrcSpanAnnA (ConDecl GhcRn)
-> [LocatedN Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (ConDecl GhcRn) -> ConDecl GhcRn
forall l e. GenLocated l e -> e
unLoc) DataDefnCons (LConDecl GhcRn)
DataDefnCons (GenLocated SrcSpanAnnA (ConDecl GhcRn))
cons


tcAddPatSynPlaceholders :: [PatSynBind GhcRn GhcRn] -> TcM a -> TcM a
-- See Note [Don't promote pattern synonyms]
tcAddPatSynPlaceholders :: forall a. [PatSynBind GhcRn GhcRn] -> TcM a -> TcM a
tcAddPatSynPlaceholders [PatSynBind GhcRn GhcRn]
pat_syns TcM a
thing_inside
  = [(Name, TcTyThing)] -> TcM a -> TcM a
forall r. [(Name, TcTyThing)] -> TcM r -> TcM r
tcExtendKindEnvList [ (Name
name, PromotionErr -> TcTyThing
APromotionErr PromotionErr
PatSynPE)
                        | PSB{ psb_id :: forall idL idR. PatSynBind idL idR -> LIdP idL
psb_id = L SrcSpanAnnN
_ Name
name } <- [PatSynBind GhcRn GhcRn]
pat_syns ]
       TcM a
thing_inside

tcAddKindSigPlaceholders :: LHsKind GhcRn -> TcM a -> TcM a
tcAddKindSigPlaceholders :: forall a. LHsKind GhcRn -> TcM a -> TcM a
tcAddKindSigPlaceholders LHsKind GhcRn
kind_sig TcM a
thing_inside
  = [(Name, TcTyThing)] -> TcM a -> TcM a
forall r. [(Name, TcTyThing)] -> TcM r -> TcM r
tcExtendKindEnvList [ (Name
name, PromotionErr -> TcTyThing
APromotionErr PromotionErr
TypeVariablePE)
                        | Name
name <- LHsKind GhcRn -> [Name]
hsScopedKvs LHsKind GhcRn
kind_sig ]
       TcM a
thing_inside

getTypeSigNames :: [LSig GhcRn] -> NameSet
-- Get the names that have a user type sig
getTypeSigNames :: [LSig GhcRn] -> RhsNames
getTypeSigNames [LSig GhcRn]
sigs
  = (GenLocated SrcSpanAnnA (Sig GhcRn) -> RhsNames -> RhsNames)
-> RhsNames -> [GenLocated SrcSpanAnnA (Sig GhcRn)] -> RhsNames
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr LSig GhcRn -> RhsNames -> RhsNames
GenLocated SrcSpanAnnA (Sig GhcRn) -> RhsNames -> RhsNames
get_type_sig RhsNames
emptyNameSet [LSig GhcRn]
[GenLocated SrcSpanAnnA (Sig GhcRn)]
sigs
  where
    get_type_sig :: LSig GhcRn -> NameSet -> NameSet
    get_type_sig :: LSig GhcRn -> RhsNames -> RhsNames
get_type_sig LSig GhcRn
sig RhsNames
ns =
      case LSig GhcRn
sig of
        L SrcSpanAnnA
_ (TypeSig XTypeSig GhcRn
_ [LIdP GhcRn]
names LHsSigWcType GhcRn
_) -> RhsNames -> [Name] -> RhsNames
extendNameSetList RhsNames
ns ((LocatedN Name -> Name) -> [LocatedN Name] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map LocatedN Name -> Name
forall l e. GenLocated l e -> e
unLoc [LIdP GhcRn]
[LocatedN Name]
names)
        L SrcSpanAnnA
_ (PatSynSig XPatSynSig GhcRn
_ [LIdP GhcRn]
names LHsSigType GhcRn
_) -> RhsNames -> [Name] -> RhsNames
extendNameSetList RhsNames
ns ((LocatedN Name -> Name) -> [LocatedN Name] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map LocatedN Name -> Name
forall l e. GenLocated l e -> e
unLoc [LIdP GhcRn]
[LocatedN Name]
names)
        LSig GhcRn
_ -> RhsNames
ns


{- Note [AFamDataCon: not promoting data family constructors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
  data family T a
  data instance T Int = MkT
  data Proxy (a :: k)
  data S = MkS (Proxy 'MkT)

Is it ok to use the promoted data family instance constructor 'MkT' in
the data declaration for S (where both declarations live in the same module)?
No, we don't allow this. It *might* make sense, but at least it would mean that
we'd have to interleave typechecking instances and data types, whereas at
present we do data types *then* instances.

So to check for this we put in the TcLclEnv a binding for all the family
constructors, bound to AFamDataCon, so that if we trip over 'MkT' when
type checking 'S' we'll produce a decent error message.

#12088 describes this limitation. Of course, when MkT and S live in
different modules then all is well.

Note [Don't promote pattern synonyms]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We never promote pattern synonyms.

Consider this (#11265):
  pattern A = True
  instance Eq A
We want a civilised error message from the occurrence of 'A'
in the instance, yet 'A' really has not yet been type checked.

Similarly (#9161)
  {-# LANGUAGE PatternSynonyms, DataKinds #-}
  pattern A = ()
  b :: A
  b = undefined
Here, the type signature for b mentions A.  But A is a pattern
synonym, which is typechecked as part of a group of bindings (for very
good reasons; a view pattern in the RHS may mention a value binding).
It is entirely reasonable to reject this, but to do so we need A to be
in the kind environment when kind-checking the signature for B.

Hence tcAddPatSynPlaceholders adds a binding
    A -> APromotionErr PatSynPE
to the environment. Then GHC.Tc.Gen.HsType.tcTyVar will find A in the kind
environment, and will give a 'wrongThingErr' as a result.  But the
lookup of A won't fail.


************************************************************************
*                                                                      *
\subsection{Rules}
*                                                                      *
************************************************************************
-}

tcExtendRules :: [LRuleDecl GhcTc] -> TcM a -> TcM a
        -- Just pop the new rules into the EPS and envt resp
        -- All the rules come from an interface file, not source
        -- Nevertheless, some may be for this module, if we read
        -- its interface instead of its source code
tcExtendRules :: forall a. [LRuleDecl GhcTc] -> TcM a -> TcM a
tcExtendRules [LRuleDecl GhcTc]
lcl_rules TcM a
thing_inside
 = do { env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
      ; let
          env' = TcGblEnv
env { tcg_rules = lcl_rules ++ tcg_rules env }
      ; setGblEnv env' thing_inside }

{-
************************************************************************
*                                                                      *
                Meta level
*                                                                      *
************************************************************************
-}

checkWellStaged :: StageCheckReason -- What the stage check is for
                -> ThLevel      -- Binding level (increases inside brackets)
                -> ThLevel      -- Use stage
                -> TcM ()       -- Fail if badly staged, adding an error
checkWellStaged :: StageCheckReason
-> ThLevel -> ThLevel -> IOEnv (Env TcGblEnv TcLclEnv) ()
checkWellStaged StageCheckReason
pp_thing ThLevel
bind_lvl ThLevel
use_lvl
  | ThLevel
use_lvl ThLevel -> ThLevel -> Bool
forall a. Ord a => a -> a -> Bool
>= ThLevel
bind_lvl         -- OK! Used later than bound
  = () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()                   -- E.g.  \x -> [| $(f x) |]

  | ThLevel
bind_lvl ThLevel -> ThLevel -> Bool
forall a. Eq a => a -> a -> Bool
== ThLevel
outerLevel      -- GHC restriction on top level splices
  = TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a. TcRnMessage -> TcM a
failWithTc (StageCheckReason -> TcRnMessage
TcRnStageRestriction StageCheckReason
pp_thing)

  | Bool
otherwise                   -- Badly staged
  = TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a. TcRnMessage -> TcM a
failWithTc (TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$                -- E.g.  \x -> $(f x)
    StageCheckReason -> ThLevel -> ThLevel -> TcRnMessage
TcRnBadlyStaged StageCheckReason
pp_thing ThLevel
bind_lvl ThLevel
use_lvl

topIdLvl :: Id -> ThLevel
-- Globals may either be imported, or may be from an earlier "chunk"
-- (separated by declaration splices) of this module.  The former
--  *can* be used inside a top-level splice, but the latter cannot.
-- Hence we give the former impLevel, but the latter topLevel
-- E.g. this is bad:
--      x = [| foo |]
--      $( f x )
-- By the time we are processing the $(f x), the binding for "x"
-- will be in the global env, not the local one.
topIdLvl :: Id -> ThLevel
topIdLvl Id
id | Id -> Bool
isLocalId Id
id = ThLevel
outerLevel
            | Bool
otherwise    = ThLevel
impLevel

tcMetaTy :: Name -> TcM Type
-- Given the name of a Template Haskell data type,
-- return the type
-- E.g. given the name "Expr" return the type "Expr"
tcMetaTy :: Name -> TcM Type
tcMetaTy Name
tc_name = do
    t <- Name -> TcM TyCon
tcLookupTyCon Name
tc_name
    return (mkTyConTy t)

isBrackStage :: ThStage -> Bool
isBrackStage :: ThStage -> Bool
isBrackStage (Brack {}) = Bool
True
isBrackStage ThStage
_other     = Bool
False

{-
************************************************************************
*                                                                      *
                 getDefaultTys
*                                                                      *
************************************************************************
-}

{- Note [Default class defaults]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In absence of user-defined `default` declarations, the set of class defaults in
effect (i.e. `DefaultEnv`) is determined by the absence or
presence of the `ExtendedDefaultRules` and `OverloadedStrings` extensions. In their
absence, the only rule in effect is `default Num (Integer, Double)` as specified by
Haskell Language Report.

In GHC's internal packages `DefaultEnv` is empty to minimize cross-module dependencies:
the `Num` class or `Integer` type may not even be available in low-level modules. If
you don't do this, attempted defaulting in package ghc-prim causes an actual crash
(attempting to look up the `Integer` type).

A user-defined `default` declaration overrides the defaults for the specified class,
and only for that class.
-}

tcGetDefaultTys :: TcM (DefaultEnv,  -- Default classes and types
                        Bool)        -- True <=> Use extended defaulting rules
tcGetDefaultTys :: TcM (DefaultEnv, Bool)
tcGetDefaultTys
  = do  { dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
        ; let ovl_strings = Extension -> DynFlags -> Bool
xopt Extension
LangExt.OverloadedStrings DynFlags
dflags
              extended_defaults = Extension -> DynFlags -> Bool
xopt Extension
LangExt.ExtendedDefaultRules DynFlags
dflags
                                        -- See also #1974
              builtinDefaults TyCon
cls [Type]
tys = ClassDefaults{ cd_class :: TyCon
cd_class = TyCon
cls
                                                     , cd_types :: [Type]
cd_types = [Type]
tys
                                                     , cd_module :: Maybe Module
cd_module = Maybe Module
forall a. Maybe a
Nothing
                                                     , cd_warn :: Maybe (WarningTxt GhcRn)
cd_warn = Maybe (WarningTxt GhcRn)
forall a. Maybe a
Nothing }

        -- see Note [Named default declarations] in GHC.Tc.Gen.Default
        ; defaults <- getDeclaredDefaultTys -- User-supplied defaults
        ; this_module <- tcg_mod <$> getGblEnv
        ; let this_unit = Module -> Unit
forall unit. GenModule unit -> unit
moduleUnit Module
this_module
              is_internal_unit = Unit
this_unit Unit -> [Unit] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Unit
ghcInternalUnit, Unit
primUnit]
        ; if is_internal_unit
             -- see Note [Default class defaults]
          then return (defaults, extended_defaults)
          else do
              -- not one of the built-in units
              -- @default Num (Integer, Double)@, plus extensions
              { extDef <- if extended_defaults
                          then do { list_ty <- tcMetaTy listTyConName
                                  ; integer_ty <- tcMetaTy integerTyConName
                                  ; foldableCls <- tcLookupTyCon foldableClassName
                                  ; showCls <- tcLookupTyCon showClassName
                                  ; eqCls <- tcLookupTyCon eqClassName
                                  ; pure $ defaultEnv
                                    [ builtinDefaults foldableCls [list_ty]
                                    , builtinDefaults showCls [unitTy, integer_ty, doubleTy]
                                    , builtinDefaults eqCls [unitTy, integer_ty, doubleTy]
                                    ]
                                  }
                                  -- Note [Extended defaults]
                          else pure emptyDefaultEnv
              ; ovlStr <- if ovl_strings
                          then do { isStringCls <- tcLookupTyCon isStringClassName
                                  ; pure $ unitDefaultEnv $ builtinDefaults isStringCls [stringTy]
                                  }
                          else pure emptyDefaultEnv
              ; checkWiredInTyCon doubleTyCon
              ; numDef <- case lookupDefaultEnv defaults numClassName of
                   Maybe ClassDefaults
Nothing -> do { numCls <- Name -> TcM TyCon
tcLookupTyCon Name
numClassName
                                 ; integer_ty <- tcMetaTy integerTyConName
                                 ; pure $ unitDefaultEnv $ builtinDefaults numCls [integer_ty, doubleTy]
                                 }
                   -- The Num class is already user-defaulted, no need to construct the builtin default
                   Maybe ClassDefaults
_ -> DefaultEnv -> TcRn DefaultEnv
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure DefaultEnv
emptyDefaultEnv
              ; let deflt_tys = [DefaultEnv] -> DefaultEnv
forall a. Monoid a => [a] -> a
mconcat [ DefaultEnv
extDef, DefaultEnv
numDef, DefaultEnv
ovlStr, DefaultEnv
defaults ]
              ; return (deflt_tys, extended_defaults) } }

{-
Note [Extended defaults]
~~~~~~~~~~~~~~~~~~~~~~~~
In interactive mode (or with -XExtendedDefaultRules) we add () as the first type we
try when defaulting.  This has very little real impact, except in the following case.
Consider:
        Text.Printf.printf "hello"
This has type (forall a. IO a); it prints "hello", and returns 'undefined'.  We don't
want the GHCi repl loop to try to print that 'undefined'.  The neatest thing is to
default the 'a' to (), rather than to Integer (which is what would otherwise happen;
and then GHCi doesn't attempt to print the ().  So in interactive mode, we add
() to the list of defaulting types.  See #1200.

Additionally, the list type [] is added as a default specialization for
Traversable and Foldable. As such the default default list now has types of
varying kinds, e.g. ([] :: * -> *)  and (Integer :: *).

************************************************************************
*                                                                      *
\subsection{The InstInfo type}
*                                                                      *
************************************************************************

The InstInfo type summarises the information in an instance declaration

    instance c => k (t tvs) where b

It is used just for *local* instance decls (not ones from interface files).
But local instance decls includes
        - derived ones
        - generic ones
as well as explicit user written ones.
-}

data InstInfo a
  = InstInfo
      { forall a. InstInfo a -> ClsInst
iSpec   :: ClsInst          -- Includes the dfun id
      , forall a. InstInfo a -> InstBindings a
iBinds  :: InstBindings a
      }

iDFunId :: InstInfo a -> DFunId
iDFunId :: forall a. InstInfo a -> Id
iDFunId InstInfo a
info = ClsInst -> Id
instanceDFunId (InstInfo a -> ClsInst
forall a. InstInfo a -> ClsInst
iSpec InstInfo a
info)

data InstBindings a
  = InstBindings
      { forall a. InstBindings a -> [Name]
ib_tyvars  :: [Name]   -- Names of the tyvars from the instance head
                               -- that are lexically in scope in the bindings
                               -- Must correspond 1-1 with the forall'd tyvars
                               -- of the dfun Id.  When typechecking, we are
                               -- going to extend the typechecker's envt with
                               --     ib_tyvars -> dfun_forall_tyvars

      , forall a. InstBindings a -> LHsBinds a
ib_binds   :: LHsBinds a    -- Bindings for the instance methods

      , forall a. InstBindings a -> [LSig a]
ib_pragmas :: [LSig a]      -- User pragmas recorded for generating
                                    -- specialised instances

      , forall a. InstBindings a -> [Extension]
ib_extensions :: [LangExt.Extension] -- Any extra extensions that should
                                             -- be enabled when type-checking
                                             -- this instance; needed for
                                             -- GeneralizedNewtypeDeriving

      , forall a. InstBindings a -> Bool
ib_derived :: Bool
           -- True <=> This code was generated by GHC from a deriving clause
           --          or standalone deriving declaration
           --          Used only to improve error messages
      }

instance (OutputableBndrId a)
       => Outputable (InstInfo (GhcPass a)) where
    ppr :: InstInfo (GhcPass a) -> SDoc
ppr = InstInfo (GhcPass a) -> SDoc
forall (a :: Pass).
OutputableBndrId a =>
InstInfo (GhcPass a) -> SDoc
pprInstInfoDetails

pprInstInfoDetails :: (OutputableBndrId a)
                   => InstInfo (GhcPass a) -> SDoc
pprInstInfoDetails :: forall (a :: Pass).
OutputableBndrId a =>
InstInfo (GhcPass a) -> SDoc
pprInstInfoDetails InstInfo (GhcPass a)
info
   = SDoc -> ThLevel -> SDoc -> SDoc
hang (ClsInst -> SDoc
pprInstanceHdr (InstInfo (GhcPass a) -> ClsInst
forall a. InstInfo a -> ClsInst
iSpec InstInfo (GhcPass a)
info) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"where")
        ThLevel
2 (InstBindings (GhcPass a) -> SDoc
forall {id2 :: Pass}.
(OutputableBndr (IdGhcP id2),
 OutputableBndr (IdGhcP (NoGhcTcPass id2)), IsPass id2,
 Outputable (GenLocated (Anno (IdGhcP id2)) (IdGhcP id2)),
 Outputable
   (GenLocated
      (Anno (IdGhcP (NoGhcTcPass id2))) (IdGhcP (NoGhcTcPass id2)))) =>
InstBindings (GhcPass id2) -> SDoc
details (InstInfo (GhcPass a) -> InstBindings (GhcPass a)
forall a. InstInfo a -> InstBindings a
iBinds InstInfo (GhcPass a)
info))
  where
    details :: InstBindings (GhcPass id2) -> SDoc
details (InstBindings { ib_pragmas :: forall a. InstBindings a -> [LSig a]
ib_pragmas = [LSig (GhcPass id2)]
p, ib_binds :: forall a. InstBindings a -> LHsBinds a
ib_binds = LHsBinds (GhcPass id2)
b }) =
      [SDoc] -> SDoc
pprDeclList (LHsBinds (GhcPass id2) -> [LSig (GhcPass id2)] -> [SDoc]
forall (idL :: Pass) (idR :: Pass) (id2 :: Pass).
(OutputableBndrId idL, OutputableBndrId idR,
 OutputableBndrId id2) =>
LHsBindsLR (GhcPass idL) (GhcPass idR)
-> [LSig (GhcPass id2)] -> [SDoc]
pprLHsBindsForUser LHsBinds (GhcPass id2)
b [LSig (GhcPass id2)]
p)

simpleInstInfoClsTy :: InstInfo a -> (Class, Type)
simpleInstInfoClsTy :: forall a. InstInfo a -> (Class, Type)
simpleInstInfoClsTy InstInfo a
info = case ClsInst -> ([Id], Class, [Type])
instanceHead (InstInfo a -> ClsInst
forall a. InstInfo a -> ClsInst
iSpec InstInfo a
info) of
                           ([Id]
_, Class
cls, [Type
ty]) -> (Class
cls, Type
ty)
                           ([Id], Class, [Type])
_ -> String -> (Class, Type)
forall a. HasCallStack => String -> a
panic String
"simpleInstInfoClsTy"

simpleInstInfoTy :: InstInfo a -> Type
simpleInstInfoTy :: forall a. InstInfo a -> Type
simpleInstInfoTy InstInfo a
info = (Class, Type) -> Type
forall a b. (a, b) -> b
snd (InstInfo a -> (Class, Type)
forall a. InstInfo a -> (Class, Type)
simpleInstInfoClsTy InstInfo a
info)

simpleInstInfoTyCon :: InstInfo a -> TyCon
  -- Gets the type constructor for a simple instance declaration,
  -- i.e. one of the form       instance (...) => C (T a b c) where ...
simpleInstInfoTyCon :: forall a. InstInfo a -> TyCon
simpleInstInfoTyCon InstInfo a
inst = Type -> TyCon
tcTyConAppTyCon (InstInfo a -> Type
forall a. InstInfo a -> Type
simpleInstInfoTy InstInfo a
inst)

-- | Make a name for the dict fun for an instance decl.  It's an *external*
-- name, like other top-level names, and hence must be made with
-- newGlobalBinder.
newDFunName :: Class -> [Type] -> SrcSpan -> TcM Name
newDFunName :: Class -> [Type] -> SrcSpan -> TcM Name
newDFunName Class
clas [Type]
tys SrcSpan
loc
  = do  { is_boot <- TcRnIf TcGblEnv TcLclEnv Bool
tcIsHsBootOrSig
        ; mod     <- getModule
        ; let info_string = OccName -> String
occNameString (Class -> OccName
forall a. NamedThing a => a -> OccName
getOccName Class
clas) String -> String -> String
forall a. [a] -> [a] -> [a]
++
                            (Type -> String) -> [Type] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (OccName -> String
occNameString (OccName -> String) -> (Type -> OccName) -> Type -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> OccName
getDFunTyKey) [Type]
tys
        ; dfun_occ <- chooseUniqueOccTc (mkDFunOcc info_string is_boot)
        ; newGlobalBinder mod dfun_occ loc }

newFamInstTyConName :: LocatedN Name -> [Type] -> TcM Name
newFamInstTyConName :: LocatedN Name -> [Type] -> TcM Name
newFamInstTyConName (L SrcSpanAnnN
loc Name
name) [Type]
tys = (OccName -> OccName) -> SrcSpan -> Name -> [[Type]] -> TcM Name
mk_fam_inst_name OccName -> OccName
forall a. a -> a
id (SrcSpanAnnN -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnN
loc) Name
name [[Type]
tys]

newFamInstAxiomName :: LocatedN Name -> [[Type]] -> TcM Name
newFamInstAxiomName :: LocatedN Name -> [[Type]] -> TcM Name
newFamInstAxiomName (L SrcSpanAnnN
loc Name
name) [[Type]]
branches
  = (OccName -> OccName) -> SrcSpan -> Name -> [[Type]] -> TcM Name
mk_fam_inst_name OccName -> OccName
mkInstTyCoOcc (SrcSpanAnnN -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnN
loc) Name
name [[Type]]
branches

mk_fam_inst_name :: (OccName -> OccName) -> SrcSpan -> Name -> [[Type]] -> TcM Name
mk_fam_inst_name :: (OccName -> OccName) -> SrcSpan -> Name -> [[Type]] -> TcM Name
mk_fam_inst_name OccName -> OccName
adaptOcc SrcSpan
loc Name
tc_name [[Type]]
tyss
  = do  { mod   <- IOEnv (Env TcGblEnv TcLclEnv) Module
forall (m :: * -> *). HasModule m => m Module
getModule
        ; let info_string = OccName -> String
occNameString (Name -> OccName
forall a. NamedThing a => a -> OccName
getOccName Name
tc_name) String -> String -> String
forall a. [a] -> [a] -> [a]
++
                            String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"|" [String]
ty_strings
        ; occ   <- chooseUniqueOccTc (mkInstTyTcOcc info_string)
        ; newGlobalBinder mod (adaptOcc occ) loc }
  where
    ty_strings :: [String]
ty_strings = ([Type] -> String) -> [[Type]] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((Type -> String) -> [Type] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (OccName -> String
occNameString (OccName -> String) -> (Type -> OccName) -> Type -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> OccName
getDFunTyKey)) [[Type]]
tyss

{-
Stable names used for foreign exports and annotations.
For stable names, the name must be unique (see #1533).  If the
same thing has several stable Ids based on it, the
top-level bindings generated must not have the same name.
Hence we create an External name (doesn't change), and we
append a Unique to the string right here.
-}

mkStableIdFromString :: String -> Type -> SrcSpan -> (OccName -> OccName) -> TcM TcId
mkStableIdFromString :: String -> Type -> SrcSpan -> (OccName -> OccName) -> TcM Id
mkStableIdFromString String
str Type
sig_ty SrcSpan
loc OccName -> OccName
occ_wrapper = do
    uniq <- TcRnIf TcGblEnv TcLclEnv Unique
forall gbl lcl. TcRnIf gbl lcl Unique
newUnique
    mod <- getModule
    nextWrapperNum <- tcg_next_wrapper_num <$> getGblEnv
    name <- mkWrapperName nextWrapperNum "stable" str
    let occ = FastString -> OccName
mkVarOccFS FastString
name :: OccName
        gnm = Unique -> Module -> OccName -> SrcSpan -> Name
mkExternalName Unique
uniq Module
mod (OccName -> OccName
occ_wrapper OccName
occ) SrcSpan
loc :: Name
        id  = Name -> Type -> Id
mkExportedVanillaId Name
gnm Type
sig_ty :: Id
    return id

mkStableIdFromName :: Name -> Type -> SrcSpan -> (OccName -> OccName) -> TcM TcId
mkStableIdFromName :: Name -> Type -> SrcSpan -> (OccName -> OccName) -> TcM Id
mkStableIdFromName Name
nm = String -> Type -> SrcSpan -> (OccName -> OccName) -> TcM Id
mkStableIdFromString (Name -> String
forall a. NamedThing a => a -> String
getOccString Name
nm)

mkWrapperName :: (MonadIO m, HasModule m)
              => IORef (ModuleEnv Int) -> String -> String -> m FastString
-- ^ @mkWrapperName ref what nameBase@
--
-- See Note [Generating fresh names for FFI wrappers] for @ref@'s purpose.
mkWrapperName :: forall (m :: * -> *).
(MonadIO m, HasModule m) =>
TcRef (ModuleEnv ThLevel) -> String -> String -> m FastString
mkWrapperName TcRef (ModuleEnv ThLevel)
wrapperRef String
what String
nameBase
    = do thisMod <- m Module
forall (m :: * -> *). HasModule m => m Module
getModule
         let pkg = Unit -> String
forall u. IsUnitId u => u -> String
unitString  (Module -> Unit
forall unit. GenModule unit -> unit
moduleUnit Module
thisMod)
             mod = ModuleName -> String
moduleNameString (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName      Module
thisMod)
         wrapperNum <- liftIO $ atomicModifyIORef' wrapperRef $ \ModuleEnv ThLevel
mod_env ->
             let num :: ThLevel
num = ModuleEnv ThLevel -> ThLevel -> Module -> ThLevel
forall a. ModuleEnv a -> a -> Module -> a
lookupWithDefaultModuleEnv ModuleEnv ThLevel
mod_env ThLevel
0 Module
thisMod
                 mod_env' :: ModuleEnv ThLevel
mod_env' = ModuleEnv ThLevel -> Module -> ThLevel -> ModuleEnv ThLevel
forall a. ModuleEnv a -> Module -> a -> ModuleEnv a
extendModuleEnv ModuleEnv ThLevel
mod_env Module
thisMod (ThLevel
numThLevel -> ThLevel -> ThLevel
forall a. Num a => a -> a -> a
+ThLevel
1)
             in (ModuleEnv ThLevel
mod_env', ThLevel
num)
         let components = [String
what, ThLevel -> String
forall a. Show a => a -> String
show ThLevel
wrapperNum, String
pkg, String
mod, String
nameBase]
         return $ mkFastString $ zEncodeString $ intercalate ":" components

{-
Note [Generating fresh names for FFI wrappers]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We used to use a unique, rather than nextWrapperNum, to distinguish
between FFI wrapper functions. However, the wrapper names that we
generate are external names. This means that if a call to them ends up
in an unfolding, then we can't alpha-rename them, and thus if the
unique randomly changes from one compile to another then we get a
spurious ABI change (#4012).

The wrapper counter has to be per-module, not global, so that the number we end
up using is not dependent on the modules compiled before the current one.
-}

{-
************************************************************************
*                                                                      *
\subsection{Errors}
*                                                                      *
************************************************************************
-}

pprBinders :: [Name] -> SDoc
-- Used in error messages
-- Use quotes for a single one; they look a bit "busy" for several
pprBinders :: [Name] -> SDoc
pprBinders [Name
bndr] = SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
bndr)
pprBinders [Name]
bndrs  = (Name -> SDoc) -> [Name] -> SDoc
forall a. (a -> SDoc) -> [a] -> SDoc
pprWithCommas Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Name]
bndrs

notFound :: Name -> TcM TyThing
notFound :: Name -> TcM TyThing
notFound Name
name
  = do { lcl_env <- TcRnIf TcGblEnv TcLclEnv TcLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv
       ; let stage = TcLclEnv -> ThStage
getLclEnvThStage TcLclEnv
lcl_env
       ; case stage of   -- See Note [Out of scope might be a staging error]
           Splice {}
             | Name -> Bool
isUnboundName Name
name -> TcM TyThing
forall env a. IOEnv env a
failM  -- If the name really isn't in scope
                                            -- don't report it again (#11941)
             | Bool
otherwise -> TcRnMessage -> TcM TyThing
forall a. TcRnMessage -> TcM a
failWithTc (StageCheckReason -> TcRnMessage
TcRnStageRestriction (Name -> StageCheckReason
StageCheckSplice Name
name))

           ThStage
_ | NameSpace -> Bool
isTermVarOrFieldNameSpace (Name -> NameSpace
nameNameSpace Name
name) ->
               -- This code path is only reachable with RequiredTypeArguments enabled
               -- via the following chain of calls:
               --   `notFound`       called from
               --   `tcLookupGlobal` called from
               --   `tcLookup`       called from
               --   `tcTyVar`
               -- It means the user tried to use a term variable at the type level, e.g.
               --   let { a = 42; f :: a -> a; ... } in ...
               -- If you are seeing this error for any other reason, it is a bug in GHC.
               -- See Note [Demotion of unqualified variables] (W1) in GHC.Rename.Env
               TcRnMessage -> TcM TyThing
forall a. TcRnMessage -> TcM a
failWithTc (TcRnMessage -> TcM TyThing) -> TcRnMessage -> TcM TyThing
forall a b. (a -> b) -> a -> b
$ Name -> PromotionErr -> TcRnMessage
TcRnUnpromotableThing Name
name PromotionErr
TermVariablePE

             | Bool
otherwise -> TcRnMessage -> TcM TyThing
forall a. TcRnMessage -> TcM a
failWithTc (TcRnMessage -> TcM TyThing) -> TcRnMessage -> TcM TyThing
forall a b. (a -> b) -> a -> b
$
                RdrName -> NotInScopeError -> TcRnMessage
mkTcRnNotInScope (Name -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName Name
name) (TcTypeEnv -> NotInScopeError
NotInScopeTc (TcLclEnv -> TcTypeEnv
getLclEnvTypeEnv TcLclEnv
lcl_env))
                       -- Take care: printing the whole gbl env can
                       -- cause an infinite loop, in the case where we
                       -- are in the middle of a recursive TyCon/Class group;
                       -- so let's just not print it!  Getting a loop here is
                       -- very unhelpful, because it hides one compiler bug with another
       }

wrongThingErr :: WrongThingSort -> TcTyThing -> Name -> TcM a
wrongThingErr :: forall a. WrongThingSort -> TcTyThing -> Name -> TcM a
wrongThingErr WrongThingSort
expected TcTyThing
thing Name
name =
  TcRnMessage -> TcM a
forall a. TcRnMessage -> TcM a
failWithTc (WrongThingSort -> TcTyThing -> Name -> TcRnMessage
TcRnTyThingUsedWrong WrongThingSort
expected TcTyThing
thing Name
name)

{- Note [Out of scope might be a staging error]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
  x = 3
  data T = MkT $(foo x)

where 'foo' is imported from somewhere.

This is really a staging error, because we can't run code involving 'x'.
But in fact the type checker processes types first, so 'x' won't even be
in the type envt when we look for it in $(foo x).  So inside splices we
report something missing from the type env as a staging error.
See #5752 and #5795.
-}