-- (c) The University of Glasgow 2006
{-# LANGUAGE CPP, FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}  -- instance MonadThings is necessarily an
                                       -- orphan
{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
                                      -- in module PlaceHolder
{-# LANGUAGE TypeFamilies #-}

module TcEnv(
        TyThing(..), TcTyThing(..), TcId,

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

        -- Global environment
        tcExtendGlobalEnv, tcExtendTyConEnv,
        tcExtendGlobalEnvImplicit, setGlobalTypeEnv,
        tcExtendGlobalValEnv,
        tcLookupLocatedGlobal, tcLookupGlobal, tcLookupGlobalOnly,
        tcLookupTyCon, tcLookupClass,
        tcLookupDataCon, tcLookupPatSyn, tcLookupConLike,
        tcLookupLocatedGlobalId, tcLookupLocatedTyCon,
        tcLookupLocatedClass, tcLookupAxiom,
        lookupGlobal, ioLookupDataCon,

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

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

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

        -- Tidying
        tcInitTidyEnv, tcInitOpenTidyEnv,

        -- Instances
        tcLookupInstance, tcGetInstEnvs,

        -- Rules
        tcExtendRules,

        -- Defaults
        tcGetDefaultTys,

        -- Global type variables
        tcGetGlobalTyCoVars,

        -- Template Haskell stuff
        checkWellStaged, tcMetaTy, thLevel,
        topIdLvl, isBrackStage,

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

#include "HsVersions.h"

import GhcPrelude

import HsSyn
import IfaceEnv
import TcRnMonad
import TcMType
import TcType
import LoadIface
import PrelNames
import TysWiredIn
import Id
import Var
import VarSet
import RdrName
import InstEnv
import DataCon ( DataCon )
import PatSyn  ( PatSyn )
import ConLike
import TyCon
import Type
import CoAxiom
import Class
import Name
import NameSet
import NameEnv
import VarEnv
import HscTypes
import DynFlags
import SrcLoc
import BasicTypes hiding( SuccessFlag(..) )
import Module
import Outputable
import Encoding
import FastString
import ListSetOps
import ErrUtils
import Util
import Maybes( MaybeErr(..), orElse )
import qualified GHC.LanguageExtensions as LangExt

import Data.IORef
import Data.List
import Control.Monad

{- *********************************************************************
*                                                                      *
            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 hsc_env :: HscEnv
hsc_env name :: Name
name
  = do  {
          MaybeErr MsgDoc TyThing
mb_thing <- HscEnv -> Name -> IO (MaybeErr MsgDoc TyThing)
lookupGlobal_maybe HscEnv
hsc_env Name
name
        ; case MaybeErr MsgDoc TyThing
mb_thing of
            Succeeded thing :: TyThing
thing -> TyThing -> IO TyThing
forall (m :: * -> *) a. Monad m => a -> m a
return TyThing
thing
            Failed msg :: MsgDoc
msg      -> String -> MsgDoc -> IO TyThing
forall a. HasCallStack => String -> MsgDoc -> a
pprPanic "lookupGlobal" MsgDoc
msg
        }

lookupGlobal_maybe :: HscEnv -> Name -> IO (MaybeErr MsgDoc TyThing)
-- This may look up an Id that one 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 MsgDoc TyThing)
lookupGlobal_maybe hsc_env :: HscEnv
hsc_env name :: Name
name
  = do  {    -- Try local envt
          let mod :: Module
mod = InteractiveContext -> Module
icInteractiveModule (HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env)
              dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
              tcg_semantic_mod :: Module
tcg_semantic_mod = DynFlags -> Module -> Module
canonicalizeModuleIfHome DynFlags
dflags Module
mod

        ; if Module -> Name -> Bool
nameIsLocalOrFrom Module
tcg_semantic_mod Name
name
              then (MaybeErr MsgDoc TyThing -> IO (MaybeErr MsgDoc TyThing)
forall (m :: * -> *) a. Monad m => a -> m a
return
                (MsgDoc -> MaybeErr MsgDoc TyThing
forall err val. err -> MaybeErr err val
Failed (String -> MsgDoc
text "Can't find local name: " MsgDoc -> MsgDoc -> MsgDoc
<+> Name -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr Name
name)))
                  -- Internal names can happen in GHCi
              else
           -- Try home package table and external package table
          HscEnv -> Name -> IO (MaybeErr MsgDoc TyThing)
lookupImported_maybe HscEnv
hsc_env Name
name
        }

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

importDecl_maybe :: HscEnv -> Name -> IO (MaybeErr MsgDoc TyThing)
importDecl_maybe :: HscEnv -> Name -> IO (MaybeErr MsgDoc TyThing)
importDecl_maybe hsc_env :: HscEnv
hsc_env name :: Name
name
  | Just thing :: 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 MsgDoc TyThing -> IO (MaybeErr MsgDoc TyThing)
forall (m :: * -> *) a. Monad m => a -> m a
return (TyThing -> MaybeErr MsgDoc TyThing
forall err val. val -> MaybeErr err val
Succeeded TyThing
thing) }
  | Bool
otherwise
  = HscEnv
-> IfG (MaybeErr MsgDoc TyThing) -> IO (MaybeErr MsgDoc TyThing)
forall a. HscEnv -> IfG a -> IO a
initIfaceLoad HscEnv
hsc_env (Name -> IfG (MaybeErr MsgDoc TyThing)
forall lcl. Name -> IfM lcl (MaybeErr MsgDoc TyThing)
importDecl Name
name)

ioLookupDataCon :: HscEnv -> Name -> IO DataCon
ioLookupDataCon :: HscEnv -> Name -> IO DataCon
ioLookupDataCon hsc_env :: HscEnv
hsc_env name :: Name
name = do
  MaybeErr MsgDoc DataCon
mb_thing <- HscEnv -> Name -> IO (MaybeErr MsgDoc DataCon)
ioLookupDataCon_maybe HscEnv
hsc_env Name
name
  case MaybeErr MsgDoc DataCon
mb_thing of
    Succeeded thing :: DataCon
thing -> DataCon -> IO DataCon
forall (m :: * -> *) a. Monad m => a -> m a
return DataCon
thing
    Failed msg :: MsgDoc
msg      -> String -> MsgDoc -> IO DataCon
forall a. HasCallStack => String -> MsgDoc -> a
pprPanic "lookupDataConIO" MsgDoc
msg

ioLookupDataCon_maybe :: HscEnv -> Name -> IO (MaybeErr MsgDoc DataCon)
ioLookupDataCon_maybe :: HscEnv -> Name -> IO (MaybeErr MsgDoc DataCon)
ioLookupDataCon_maybe hsc_env :: HscEnv
hsc_env name :: Name
name = do
    TyThing
thing <- HscEnv -> Name -> IO TyThing
lookupGlobal HscEnv
hsc_env Name
name
    MaybeErr MsgDoc DataCon -> IO (MaybeErr MsgDoc DataCon)
forall (m :: * -> *) a. Monad m => a -> m a
return (MaybeErr MsgDoc DataCon -> IO (MaybeErr MsgDoc DataCon))
-> MaybeErr MsgDoc DataCon -> IO (MaybeErr MsgDoc DataCon)
forall a b. (a -> b) -> a -> b
$ case TyThing
thing of
        AConLike (RealDataCon con :: DataCon
con) -> DataCon -> MaybeErr MsgDoc DataCon
forall err val. val -> MaybeErr err val
Succeeded DataCon
con
        _                          -> MsgDoc -> MaybeErr MsgDoc DataCon
forall err val. err -> MaybeErr err val
Failed (MsgDoc -> MaybeErr MsgDoc DataCon)
-> MsgDoc -> MaybeErr MsgDoc DataCon
forall a b. (a -> b) -> a -> b
$
          TcTyThing -> MsgDoc
pprTcTyThingCategory (TyThing -> TcTyThing
AGlobal TyThing
thing) MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc -> MsgDoc
quotes (Name -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr Name
name) MsgDoc -> MsgDoc -> MsgDoc
<+>
                String -> MsgDoc
text "used as a data constructor"

{-
************************************************************************
*                                                                      *
*                      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 :: Located Name -> TcM TyThing
-- c.f. IfaceEnvEnv.tcIfaceGlobal
tcLookupLocatedGlobal :: Located Name -> TcM TyThing
tcLookupLocatedGlobal name :: Located Name
name
  = (SrcSpanLess (Located Name) -> TcM TyThing)
-> Located Name -> TcM TyThing
forall a b. HasSrcSpan a => (SrcSpanLess a -> TcM b) -> a -> TcM b
addLocM Name -> TcM TyThing
SrcSpanLess (Located Name) -> TcM TyThing
tcLookupGlobal Located 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
name
  = do  {    -- Try local envt
          TcGblEnv
env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
        ; case NameEnv TyThing -> Name -> Maybe TyThing
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv (TcGblEnv -> NameEnv TyThing
tcg_type_env TcGblEnv
env) Name
name of {
                Just thing :: TyThing
thing -> TyThing -> TcM TyThing
forall (m :: * -> *) a. Monad m => a -> m a
return TyThing
thing ;
                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  { MaybeErr MsgDoc TyThing
mb_thing <- Name -> TcM (MaybeErr MsgDoc TyThing)
tcLookupImported_maybe Name
name
        ; case MaybeErr MsgDoc TyThing
mb_thing of
            Succeeded thing :: TyThing
thing -> TyThing -> TcM TyThing
forall (m :: * -> *) a. Monad m => a -> m a
return TyThing
thing
            Failed msg :: MsgDoc
msg      -> MsgDoc -> TcM TyThing
forall a. MsgDoc -> TcM a
failWithTc MsgDoc
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
name
  = do { TcGblEnv
env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
       ; TyThing -> TcM TyThing
forall (m :: * -> *) a. Monad m => a -> m a
return (TyThing -> TcM TyThing) -> TyThing -> TcM TyThing
forall a b. (a -> b) -> a -> b
$ case NameEnv TyThing -> Name -> Maybe TyThing
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv (TcGblEnv -> NameEnv TyThing
tcg_type_env TcGblEnv
env) Name
name of
                    Just thing :: TyThing
thing -> TyThing
thing
                    Nothing    -> String -> MsgDoc -> TyThing
forall a. HasCallStack => String -> MsgDoc -> a
pprPanic "tcLookupGlobalOnly" (Name -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr Name
name) }

tcLookupDataCon :: Name -> TcM DataCon
tcLookupDataCon :: Name -> TcM DataCon
tcLookupDataCon name :: Name
name = do
    TyThing
thing <- Name -> TcM TyThing
tcLookupGlobal Name
name
    case TyThing
thing of
        AConLike (RealDataCon con :: DataCon
con) -> DataCon -> TcM DataCon
forall (m :: * -> *) a. Monad m => a -> m a
return DataCon
con
        _                          -> String -> TcTyThing -> Name -> TcM DataCon
forall a. String -> TcTyThing -> Name -> TcM a
wrongThingErr "data constructor" (TyThing -> TcTyThing
AGlobal TyThing
thing) Name
name

tcLookupPatSyn :: Name -> TcM PatSyn
tcLookupPatSyn :: Name -> TcM PatSyn
tcLookupPatSyn name :: Name
name = do
    TyThing
thing <- Name -> TcM TyThing
tcLookupGlobal Name
name
    case TyThing
thing of
        AConLike (PatSynCon ps :: PatSyn
ps) -> PatSyn -> TcM PatSyn
forall (m :: * -> *) a. Monad m => a -> m a
return PatSyn
ps
        _                       -> String -> TcTyThing -> Name -> TcM PatSyn
forall a. String -> TcTyThing -> Name -> TcM a
wrongThingErr "pattern synonym" (TyThing -> TcTyThing
AGlobal TyThing
thing) Name
name

tcLookupConLike :: Name -> TcM ConLike
tcLookupConLike :: Name -> TcM ConLike
tcLookupConLike name :: Name
name = do
    TyThing
thing <- Name -> TcM TyThing
tcLookupGlobal Name
name
    case TyThing
thing of
        AConLike cl :: ConLike
cl -> ConLike -> TcM ConLike
forall (m :: * -> *) a. Monad m => a -> m a
return ConLike
cl
        _           -> String -> TcTyThing -> Name -> TcM ConLike
forall a. String -> TcTyThing -> Name -> TcM a
wrongThingErr "constructor-like thing" (TyThing -> TcTyThing
AGlobal TyThing
thing) Name
name

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

tcLookupTyCon :: Name -> TcM TyCon
tcLookupTyCon :: Name -> TcM TyCon
tcLookupTyCon name :: Name
name = do
    TyThing
thing <- Name -> TcM TyThing
tcLookupGlobal Name
name
    case TyThing
thing of
        ATyCon tc :: TyCon
tc -> TyCon -> TcM TyCon
forall (m :: * -> *) a. Monad m => a -> m a
return TyCon
tc
        _         -> String -> TcTyThing -> Name -> TcM TyCon
forall a. String -> TcTyThing -> Name -> TcM a
wrongThingErr "type constructor" (TyThing -> TcTyThing
AGlobal TyThing
thing) Name
name

tcLookupAxiom :: Name -> TcM (CoAxiom Branched)
tcLookupAxiom :: Name -> TcM (CoAxiom Branched)
tcLookupAxiom name :: Name
name = do
    TyThing
thing <- Name -> TcM TyThing
tcLookupGlobal Name
name
    case TyThing
thing of
        ACoAxiom ax :: CoAxiom Branched
ax -> CoAxiom Branched -> TcM (CoAxiom Branched)
forall (m :: * -> *) a. Monad m => a -> m a
return CoAxiom Branched
ax
        _           -> String -> TcTyThing -> Name -> TcM (CoAxiom Branched)
forall a. String -> TcTyThing -> Name -> TcM a
wrongThingErr "axiom" (TyThing -> TcTyThing
AGlobal TyThing
thing) Name
name

tcLookupLocatedGlobalId :: Located Name -> TcM Id
tcLookupLocatedGlobalId :: Located Name -> TcM Id
tcLookupLocatedGlobalId = (SrcSpanLess (Located Name) -> TcM Id) -> Located Name -> TcM Id
forall a b. HasSrcSpan a => (SrcSpanLess a -> TcM b) -> a -> TcM b
addLocM Name -> TcM Id
SrcSpanLess (Located Name) -> TcM Id
tcLookupId

tcLookupLocatedClass :: Located Name -> TcM Class
tcLookupLocatedClass :: Located Name -> TcM Class
tcLookupLocatedClass = (SrcSpanLess (Located Name) -> TcM Class)
-> Located Name -> TcM Class
forall a b. HasSrcSpan a => (SrcSpanLess a -> TcM b) -> a -> TcM b
addLocM Name -> TcM Class
SrcSpanLess (Located Name) -> TcM Class
tcLookupClass

tcLookupLocatedTyCon :: Located Name -> TcM TyCon
tcLookupLocatedTyCon :: Located Name -> TcM TyCon
tcLookupLocatedTyCon = (SrcSpanLess (Located Name) -> TcM TyCon)
-> Located Name -> TcM TyCon
forall a b. HasSrcSpan a => (SrcSpanLess a -> TcM b) -> a -> TcM b
addLocM Name -> TcM TyCon
SrcSpanLess (Located 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 cls :: Class
cls tys :: [Type]
tys
  = do { InstEnvs
instEnv <- TcM InstEnvs
tcGetInstEnvs
       ; case InstEnvs -> Class -> [Type] -> Either MsgDoc (ClsInst, [Type])
lookupUniqueInstEnv InstEnvs
instEnv Class
cls [Type]
tys of
           Left err :: MsgDoc
err             -> MsgDoc -> TcM ClsInst
forall a. MsgDoc -> TcM a
failWithTc (MsgDoc -> TcM ClsInst) -> MsgDoc -> TcM ClsInst
forall a b. (a -> b) -> a -> b
$ String -> MsgDoc
text "Couldn't match instance:" MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc
err
           Right (inst :: ClsInst
inst, tys :: [Type]
tys)
             | [Type] -> Bool
uniqueTyVars [Type]
tys -> ClsInst -> TcM ClsInst
forall (m :: * -> *) a. Monad m => a -> m a
return ClsInst
inst
             | Bool
otherwise        -> MsgDoc -> TcM ClsInst
forall a. MsgDoc -> TcM a
failWithTc MsgDoc
errNotExact
       }
  where
    errNotExact :: MsgDoc
errNotExact = String -> MsgDoc
text "Not an exact match (i.e., some variables get instantiated)"

    uniqueTyVars :: [Type] -> Bool
uniqueTyVars tys :: [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 (String -> Type -> Id
getTyVar "tcLookupInstance") [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 { ExternalPackageState
eps <- TcRnIf TcGblEnv TcLclEnv ExternalPackageState
forall gbl lcl. TcRnIf gbl lcl ExternalPackageState
getEps
                   ; TcGblEnv
env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
                   ; InstEnvs -> TcM InstEnvs
forall (m :: * -> *) a. Monad m => a -> m a
return (InstEnvs :: InstEnv -> InstEnv -> VisibleOrphanModules -> InstEnvs
InstEnvs { ie_global :: InstEnv
ie_global  = ExternalPackageState -> InstEnv
eps_inst_env ExternalPackageState
eps
                                      , ie_local :: InstEnv
ie_local   = TcGblEnv -> InstEnv
tcg_inst_env TcGblEnv
env
                                      , ie_visible :: VisibleOrphanModules
ie_visible = TcGblEnv -> VisibleOrphanModules
tcVisibleOrphanMods TcGblEnv
env }) }

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

{-
************************************************************************
*                                                                      *
                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 tcg_env :: TcGblEnv
tcg_env new_type_env :: NameEnv TyThing
new_type_env
  = do  {     -- Sync the type-envt variable seen by interface files
           IORef (NameEnv TyThing)
-> NameEnv TyThing -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a env. IORef a -> a -> IOEnv env ()
writeMutVar (TcGblEnv -> IORef (NameEnv TyThing)
tcg_type_env_var TcGblEnv
tcg_env) NameEnv TyThing
new_type_env
         ; TcGblEnv -> TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv
tcg_env { tcg_type_env :: NameEnv TyThing
tcg_type_env = NameEnv TyThing
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 :: [TyThing] -> TcM r -> TcM r
tcExtendGlobalEnvImplicit things :: [TyThing]
things thing_inside :: TcM r
thing_inside
   = do { TcGblEnv
tcg_env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
        ; let ge' :: NameEnv TyThing
ge'  = NameEnv TyThing -> [TyThing] -> NameEnv TyThing
extendTypeEnvList (TcGblEnv -> NameEnv TyThing
tcg_type_env TcGblEnv
tcg_env) [TyThing]
things
        ; TcGblEnv
tcg_env' <- TcGblEnv -> NameEnv TyThing -> TcRnIf TcGblEnv TcLclEnv TcGblEnv
setGlobalTypeEnv TcGblEnv
tcg_env NameEnv TyThing
ge'
        ; TcGblEnv -> TcM r -> TcM r
forall gbl lcl a. gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setGblEnv TcGblEnv
tcg_env' TcM r
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 :: [TyThing] -> TcM r -> TcM r
tcExtendGlobalEnv things :: [TyThing]
things thing_inside :: TcM r
thing_inside
  = do { TcGblEnv
env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
       ; let env' :: TcGblEnv
env' = TcGblEnv
env { tcg_tcs :: [TyCon]
tcg_tcs = [TyCon
tc | ATyCon tc :: TyCon
tc <- [TyThing]
things] [TyCon] -> [TyCon] -> [TyCon]
forall a. [a] -> [a] -> [a]
++ TcGblEnv -> [TyCon]
tcg_tcs TcGblEnv
env,
                          tcg_patsyns :: [PatSyn]
tcg_patsyns = [PatSyn
ps | AConLike (PatSynCon ps :: PatSyn
ps) <- [TyThing]
things] [PatSyn] -> [PatSyn] -> [PatSyn]
forall a. [a] -> [a] -> [a]
++ TcGblEnv -> [PatSyn]
tcg_patsyns TcGblEnv
env }
       ; TcGblEnv -> TcM r -> TcM r
forall gbl lcl a. gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setGblEnv TcGblEnv
env' (TcM r -> TcM r) -> TcM r -> TcM r
forall a b. (a -> b) -> a -> b
$
            [TyThing] -> TcM r -> TcM r
forall r. [TyThing] -> TcM r -> TcM r
tcExtendGlobalEnvImplicit [TyThing]
things TcM r
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 :: [TyCon] -> TcM r -> TcM r
tcExtendTyConEnv tycons :: [TyCon]
tycons thing_inside :: TcM r
thing_inside
  = do { TcGblEnv
env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
       ; let env' :: TcGblEnv
env' = TcGblEnv
env { tcg_tcs :: [TyCon]
tcg_tcs = [TyCon]
tycons [TyCon] -> [TyCon] -> [TyCon]
forall a. [a] -> [a] -> [a]
++ TcGblEnv -> [TyCon]
tcg_tcs TcGblEnv
env }
       ; TcGblEnv -> TcM r -> TcM r
forall gbl lcl a. gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setGblEnv TcGblEnv
env' (TcM r -> TcM r) -> TcM r -> TcM r
forall a b. (a -> b) -> a -> b
$
         [TyThing] -> TcM r -> TcM r
forall r. [TyThing] -> TcM r -> TcM r
tcExtendGlobalEnvImplicit ((TyCon -> TyThing) -> [TyCon] -> [TyThing]
forall a b. (a -> b) -> [a] -> [b]
map TyCon -> TyThing
ATyCon [TyCon]
tycons) TcM r
thing_inside
       }

tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a
  -- Same deal as tcExtendGlobalEnv, but for Ids
tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a
tcExtendGlobalValEnv ids :: [Id]
ids thing_inside :: 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 :: [(Name, TyThing)] -> TcM r -> TcM r
tcExtendRecEnv gbl_stuff :: [(Name, TyThing)]
gbl_stuff thing_inside :: TcM r
thing_inside
 = do  { TcGblEnv
tcg_env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
       ; let ge' :: NameEnv TyThing
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' = TcGblEnv
tcg_env { tcg_type_env :: NameEnv TyThing
tcg_type_env = NameEnv TyThing
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!
       ; TcGblEnv -> TcM r -> TcM r
forall gbl lcl a. gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setGblEnv TcGblEnv
tcg_env' TcM r
thing_inside }

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

tcLookupLocated :: Located Name -> TcM TcTyThing
tcLookupLocated :: Located Name -> TcM TcTyThing
tcLookupLocated = (SrcSpanLess (Located Name) -> TcM TcTyThing)
-> Located Name -> TcM TcTyThing
forall a b. HasSrcSpan a => (SrcSpanLess a -> TcM b) -> a -> TcM b
addLocM Name -> TcM TcTyThing
SrcSpanLess (Located Name) -> TcM TcTyThing
tcLookup

tcLookupLcl_maybe :: Name -> TcM (Maybe TcTyThing)
tcLookupLcl_maybe :: Name -> TcM (Maybe TcTyThing)
tcLookupLcl_maybe name :: Name
name
  = do { TcTypeEnv
local_env <- TcM TcTypeEnv
getLclTypeEnv
       ; Maybe TcTyThing -> TcM (Maybe TcTyThing)
forall (m :: * -> *) a. Monad m => a -> m a
return (TcTypeEnv -> Name -> Maybe TcTyThing
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv TcTypeEnv
local_env Name
name) }

tcLookup :: Name -> TcM TcTyThing
tcLookup :: Name -> TcM TcTyThing
tcLookup name :: Name
name = do
    TcTypeEnv
local_env <- TcM TcTypeEnv
getLclTypeEnv
    case TcTypeEnv -> Name -> Maybe TcTyThing
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv TcTypeEnv
local_env Name
name of
        Just thing :: TcTyThing
thing -> TcTyThing -> TcM TcTyThing
forall (m :: * -> *) a. Monad m => a -> m a
return TcTyThing
thing
        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
name
  = do { TcTyThing
thing <- Name -> TcM TcTyThing
tcLookup Name
name
       ; case TcTyThing
thing of
           ATyVar _ tv :: Id
tv -> Id -> TcM Id
forall (m :: * -> *) a. Monad m => a -> m a
return Id
tv
           _           -> String -> MsgDoc -> TcM Id
forall a. HasCallStack => String -> MsgDoc -> a
pprPanic "tcLookupTyVar" (Name -> MsgDoc
forall a. Outputable a => a -> MsgDoc
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 TcExpr.tcId)
tcLookupId :: Name -> TcM Id
tcLookupId name :: Name
name = do
    Maybe Id
thing <- Name -> TcM (Maybe Id)
tcLookupIdMaybe Name
name
    case Maybe Id
thing of
        Just id :: Id
id -> Id -> TcM Id
forall (m :: * -> *) a. Monad m => a -> m a
return Id
id
        _       -> String -> MsgDoc -> TcM Id
forall a. HasCallStack => String -> MsgDoc -> a
pprPanic "tcLookupId" (Name -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr Name
name)

tcLookupIdMaybe :: Name -> TcM (Maybe Id)
tcLookupIdMaybe :: Name -> TcM (Maybe Id)
tcLookupIdMaybe name :: Name
name
  = do { TcTyThing
thing <- Name -> TcM TcTyThing
tcLookup Name
name
       ; case TcTyThing
thing of
           ATcId { tct_id :: TcTyThing -> Id
tct_id = Id
id} -> Maybe Id -> TcM (Maybe Id)
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
id)    -> Maybe Id -> TcM (Maybe Id)
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
           _                    -> Maybe Id -> TcM (Maybe Id)
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 ns :: [Name]
ns
  = do { TcLclEnv
env <- TcRnIf TcGblEnv TcLclEnv TcLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv
       ; [Id] -> TcM [Id]
forall (m :: * -> *) a. Monad m => a -> m a
return ((Name -> Id) -> [Name] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map (TcTypeEnv -> Name -> Id
lookup (TcLclEnv -> TcTypeEnv
tcl_env TcLclEnv
env)) [Name]
ns) }
  where
    lookup :: TcTypeEnv -> Name -> Id
lookup lenv :: TcTypeEnv
lenv name :: 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
                _ -> String -> MsgDoc -> Id
forall a. HasCallStack => String -> MsgDoc -> a
pprPanic "tcLookupLocalIds" (Name -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr Name
name)

getInLocalScope :: TcM (Name -> Bool)
getInLocalScope :: TcM (Name -> Bool)
getInLocalScope = do { TcTypeEnv
lcl_env <- TcM TcTypeEnv
getLclTypeEnv
                     ; (Name -> Bool) -> TcM (Name -> Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> TcTypeEnv -> Bool
forall a. Name -> NameEnv a -> Bool
`elemNameEnv` TcTypeEnv
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 :: [(Name, TcTyThing)] -> TcM r -> TcM r
tcExtendKindEnvList things :: [(Name, TcTyThing)]
things thing_inside :: TcM r
thing_inside
  = do { String -> MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc "tcExtendKindEnvList" ([(Name, TcTyThing)] -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr [(Name, TcTyThing)]
things)
       ; (TcLclEnv -> TcLclEnv) -> TcM r -> TcM r
forall lcl gbl a.
(lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv TcLclEnv -> TcLclEnv
upd_env TcM r
thing_inside }
  where
    upd_env :: TcLclEnv -> TcLclEnv
upd_env env :: TcLclEnv
env = TcLclEnv
env { tcl_env :: TcTypeEnv
tcl_env = TcTypeEnv -> [(Name, TcTyThing)] -> TcTypeEnv
forall a. NameEnv a -> [(Name, a)] -> NameEnv a
extendNameEnvList (TcLclEnv -> TcTypeEnv
tcl_env TcLclEnv
env) [(Name, TcTyThing)]
things }

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

-----------------------
-- Scoped type and kind variables
tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r
tcExtendTyVarEnv :: [Id] -> TcM r -> TcM r
tcExtendTyVarEnv tvs :: [Id]
tvs thing_inside :: TcM r
thing_inside
  = [(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 :: [(Name, Id)] -> TcM r -> TcM r
tcExtendNameTyVarEnv binds :: [(Name, Id)]
binds thing_inside :: TcM r
thing_inside
  -- this should be used only for explicitly mentioned scoped variables.
  -- thus, no coercion variables
  = do { TopLevelFlag -> [(Name, TcTyThing)] -> TcM r -> TcM r
forall a. TopLevelFlag -> [(Name, TcTyThing)] -> TcM a -> TcM a
tc_extend_local_env TopLevelFlag
NotTopLevel
                    [(Name
name, Name -> Id -> TcTyThing
ATyVar Name
name Id
tv) | (name :: Name
name, tv :: Id
tv) <- [(Name, Id)]
binds] (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
name,tv :: Id
tv) <- [(Name, Id)]
binds]

isTypeClosedLetBndr :: Id -> Bool
-- See Note [Bindings with closed types] in TcRnTypes
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 recurive uses of Ids in a binding
-- both top-level value bindings and and nested let/where-bindings
-- Does not extend the TcBinderStack
tcExtendRecIds :: [(Name, Id)] -> TcM a -> TcM a
tcExtendRecIds pairs :: [(Name, Id)]
pairs thing_inside :: 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 :: Id -> IdBindingInfo -> TcTyThing
ATcId { tct_id :: Id
tct_id   = Id
let_id
                         , tct_info :: IdBindingInfo
tct_info = RhsNames -> Bool -> IdBindingInfo
NonClosedLet RhsNames
emptyNameSet Bool
False })
          | (name :: Name
name, let_id :: 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 :: TopLevelFlag -> [Id] -> TcM a -> TcM a
tcExtendSigIds top_lvl :: TopLevelFlag
top_lvl sig_ids :: [Id]
sig_ids thing_inside :: 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 :: Id -> IdBindingInfo -> TcTyThing
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
                  -> [TcId] -> TcM a -> TcM a
-- Used for both top-level value bindings and and nested let/where-bindings
-- Adds to the TcBinderStack too
tcExtendLetEnv :: TopLevelFlag -> TcSigFun -> IsGroupClosed -> [Id] -> TcM a -> TcM a
tcExtendLetEnv top_lvl :: TopLevelFlag
top_lvl sig_fn :: TcSigFun
sig_fn (IsGroupClosed fvs :: NameEnv RhsNames
fvs fv_type_closed :: Bool
fv_type_closed)
               ids :: [Id]
ids thing_inside :: 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 | Id
id <- [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 :: Id -> IdBindingInfo -> TcTyThing
ATcId { tct_id :: Id
tct_id   = Id
id
                              , tct_info :: IdBindingInfo
tct_info = Id -> IdBindingInfo
mk_tct_info Id
id })
          | Id
id <- [Id]
ids ]
    TcM a
thing_inside
  where
    mk_tct_info :: Id -> IdBindingInfo
mk_tct_info id :: 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)

tcExtendIdEnv :: [TcId] -> TcM a -> TcM a
-- For lambda-bound and case-bound Ids
-- Extends the TcBinderStack as well
tcExtendIdEnv :: [Id] -> TcM a -> TcM a
tcExtendIdEnv ids :: [Id]
ids thing_inside :: 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 :: Name -> Id -> TcM a -> TcM a
tcExtendIdEnv1 name :: Name
name id :: Id
id thing_inside :: 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 :: [(Name, Id)] -> TcM a -> TcM a
tcExtendIdEnv2 names_w_ids :: [(Name, Id)]
names_w_ids thing_inside :: 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
                        | (_,mono_id :: 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 :: Id -> IdBindingInfo -> TcTyThing
ATcId { tct_id :: Id
tct_id = Id
id
                           , tct_info :: IdBindingInfo
tct_info    = IdBindingInfo
NotLetBound })
            | (name :: Name
name,id :: 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 :: TopLevelFlag -> [(Name, TcTyThing)] -> TcM a -> TcM a
tc_extend_local_env top_lvl :: TopLevelFlag
top_lvl extra_env :: [(Name, TcTyThing)]
extra_env thing_inside :: 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 -> MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc "tc_extend_local_env" ([(Name, TcTyThing)] -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr [(Name, TcTyThing)]
extra_env)
        ; TcLclEnv
env0 <- TcRnIf TcGblEnv TcLclEnv TcLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv
        ; TcLclEnv
env1 <- TcLclEnv
-> [(Name, TcTyThing)] -> TcRnIf TcGblEnv TcLclEnv TcLclEnv
tcExtendLocalTypeEnv TcLclEnv
env0 [(Name, TcTyThing)]
extra_env
        ; ThStage
stage <- TcM ThStage
getStage
        ; let env2 :: TcLclEnv
env2 = (TopLevelFlag, ThLevel)
-> [(Name, TcTyThing)] -> TcLclEnv -> TcLclEnv
extend_local_env (TopLevelFlag
top_lvl, ThStage -> ThLevel
thLevel ThStage
stage) [(Name, TcTyThing)]
extra_env TcLclEnv
env1
        ; TcLclEnv -> TcM a -> TcM a
forall lcl' gbl a lcl.
lcl' -> TcRnIf gbl lcl' a -> TcRnIf gbl lcl a
setLclEnv TcLclEnv
env2 TcM a
thing_inside }
  where
    extend_local_env :: (TopLevelFlag, ThLevel) -> [(Name, TcTyThing)] -> TcLclEnv -> TcLclEnv
    -- Extend the local LocalRdrEnv and Template Haskell staging env simultaneously
    -- Reason for extending LocalRdrEnv: after running a TH splice we need
    -- to do renaming.
    extend_local_env :: (TopLevelFlag, ThLevel)
-> [(Name, TcTyThing)] -> TcLclEnv -> TcLclEnv
extend_local_env thlvl :: (TopLevelFlag, ThLevel)
thlvl pairs :: [(Name, TcTyThing)]
pairs env :: TcLclEnv
env@(TcLclEnv { tcl_rdr :: TcLclEnv -> LocalRdrEnv
tcl_rdr = LocalRdrEnv
rdr_env
                                               , tcl_th_bndrs :: TcLclEnv -> ThBindEnv
tcl_th_bndrs = ThBindEnv
th_bndrs })
      = TcLclEnv
env { tcl_rdr :: LocalRdrEnv
tcl_rdr      = LocalRdrEnv -> [Name] -> LocalRdrEnv
extendLocalRdrEnvList LocalRdrEnv
rdr_env
                                [ Name
n | (n :: Name
n, _) <- [(Name, TcTyThing)]
pairs, Name -> Bool
isInternalName Name
n ]
                                -- The LocalRdrEnv contains only non-top-level names
                                -- (GlobalRdrEnv handles the top level)
            , tcl_th_bndrs :: ThBindEnv
tcl_th_bndrs = ThBindEnv -> [(Name, (TopLevelFlag, ThLevel))] -> ThBindEnv
forall a. NameEnv a -> [(Name, a)] -> NameEnv a
extendNameEnvList ThBindEnv
th_bndrs  -- We only track Ids in tcl_th_bndrs
                                 [(Name
n, (TopLevelFlag, ThLevel)
thlvl) | (n :: Name
n, ATcId {}) <- [(Name, TcTyThing)]
pairs] }

tcExtendLocalTypeEnv :: TcLclEnv -> [(Name, TcTyThing)] -> TcM TcLclEnv
tcExtendLocalTypeEnv :: TcLclEnv
-> [(Name, TcTyThing)] -> TcRnIf TcGblEnv TcLclEnv TcLclEnv
tcExtendLocalTypeEnv lcl_env :: TcLclEnv
lcl_env@(TcLclEnv { tcl_env :: TcLclEnv -> TcTypeEnv
tcl_env = TcTypeEnv
lcl_type_env }) tc_ty_things :: [(Name, TcTyThing)]
tc_ty_things
  | VarSet -> Bool
isEmptyVarSet VarSet
extra_tvs
  = TcLclEnv -> TcRnIf TcGblEnv TcLclEnv TcLclEnv
forall (m :: * -> *) a. Monad m => a -> m a
return (TcLclEnv
lcl_env { tcl_env :: TcTypeEnv
tcl_env = TcTypeEnv -> [(Name, TcTyThing)] -> TcTypeEnv
forall a. NameEnv a -> [(Name, a)] -> NameEnv a
extendNameEnvList TcTypeEnv
lcl_type_env [(Name, TcTyThing)]
tc_ty_things })
  | Bool
otherwise
  = do { VarSet
global_tvs <- IORef VarSet -> IOEnv (Env TcGblEnv TcLclEnv) VarSet
forall a env. IORef a -> IOEnv env a
readMutVar (TcLclEnv -> IORef VarSet
tcl_tyvars TcLclEnv
lcl_env)
       ; IORef VarSet
new_g_var  <- VarSet -> IOEnv (Env TcGblEnv TcLclEnv) (IORef VarSet)
forall a env. a -> IOEnv env (IORef a)
newMutVar (VarSet
global_tvs VarSet -> VarSet -> VarSet
`unionVarSet` VarSet
extra_tvs)
       ; TcLclEnv -> TcRnIf TcGblEnv TcLclEnv TcLclEnv
forall (m :: * -> *) a. Monad m => a -> m a
return (TcLclEnv
lcl_env { tcl_tyvars :: IORef VarSet
tcl_tyvars = IORef VarSet
new_g_var
                         , tcl_env :: TcTypeEnv
tcl_env = TcTypeEnv -> [(Name, TcTyThing)] -> TcTypeEnv
forall a. NameEnv a -> [(Name, a)] -> NameEnv a
extendNameEnvList TcTypeEnv
lcl_type_env [(Name, TcTyThing)]
tc_ty_things } ) }
  where
    extra_tvs :: VarSet
extra_tvs = ((Name, TcTyThing) -> VarSet -> VarSet)
-> VarSet -> [(Name, TcTyThing)] -> VarSet
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Name, TcTyThing) -> VarSet -> VarSet
forall a. (a, TcTyThing) -> VarSet -> VarSet
get_tvs VarSet
emptyVarSet [(Name, TcTyThing)]
tc_ty_things

    get_tvs :: (a, TcTyThing) -> VarSet -> VarSet
get_tvs (_, ATcId { tct_id :: TcTyThing -> Id
tct_id = Id
id, tct_info :: TcTyThing -> IdBindingInfo
tct_info = IdBindingInfo
closed }) tvs :: VarSet
tvs
      = case IdBindingInfo
closed of
          ClosedLet -> ASSERT2( is_closed_type, ppr id $$ ppr (idType id) )
                       VarSet
tvs
          _other :: IdBindingInfo
_other    -> VarSet
tvs VarSet -> VarSet -> VarSet
`unionVarSet` VarSet
id_tvs
        where
           id_ty :: Type
id_ty          = Id -> Type
idType Id
id
           id_tvs :: VarSet
id_tvs         = Type -> VarSet
tyCoVarsOfType Type
id_ty
           id_co_tvs :: VarSet
id_co_tvs      = VarSet -> VarSet
closeOverKinds (Type -> VarSet
coVarsOfType Type
id_ty)
           is_closed_type :: Bool
is_closed_type = Bool -> Bool
not ((Id -> Bool) -> VarSet -> Bool
anyVarSet Id -> Bool
isTyVar (VarSet
id_tvs VarSet -> VarSet -> VarSet
`minusVarSet` VarSet
id_co_tvs))
           -- We only care about being closed wrt /type/ variables
           -- E.g. a top-level binding might have a type like
           --          foo :: t |> co
           -- where co :: * ~ *
           -- or some other as-yet-unsolved kind coercion

    get_tvs (_, ATyVar _ tv :: Id
tv) tvs :: VarSet
tvs          -- See Note [Global TyVars]
      = VarSet
tvs VarSet -> VarSet -> VarSet
`unionVarSet` Type -> VarSet
tyCoVarsOfType (Id -> Type
tyVarKind Id
tv) VarSet -> Id -> VarSet
`extendVarSet` Id
tv

    get_tvs (_, ATcTyCon tc :: TyCon
tc) tvs :: VarSet
tvs = VarSet
tvs VarSet -> VarSet -> VarSet
`unionVarSet` Type -> VarSet
tyCoVarsOfType (TyCon -> Type
tyConKind TyCon
tc)

    get_tvs (_, AGlobal {})       tvs :: VarSet
tvs = VarSet
tvs
    get_tvs (_, APromotionErr {}) tvs :: VarSet
tvs = VarSet
tvs

        -- Note [Global TyVars]
        -- It's important to add the in-scope tyvars to the global tyvar set
        -- as well.  Consider
        --      f (_::r) = let g y = y::r in ...
        -- Here, g mustn't be generalised.  This is also important during
        -- class and instance decls, when we mustn't generalise the class tyvars
        -- when typechecking the methods.
        --
        -- Nor must we generalise g over any kind variables free in r's kind


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

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

tcInitTidyEnv :: TcM TidyEnv
-- We initialise the "tidy-env", used for tidying types before printing,
-- by building a reverse map from the in-scope type variables to the
-- OccName that the programmer originally used for them
tcInitTidyEnv :: TcM TidyEnv
tcInitTidyEnv
  = do  { TcLclEnv
lcl_env <- TcRnIf TcGblEnv TcLclEnv TcLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv
        ; TidyEnv -> [TcBinder] -> TcM TidyEnv
go TidyEnv
emptyTidyEnv (TcLclEnv -> [TcBinder]
tcl_bndrs TcLclEnv
lcl_env) }
  where
    go :: TidyEnv -> [TcBinder] -> TcM TidyEnv
go (env :: UniqFM ThLevel
env, subst :: UniqFM Id
subst) []
      = TidyEnv -> TcM TidyEnv
forall (m :: * -> *) a. Monad m => a -> m a
return (UniqFM ThLevel
env, UniqFM Id
subst)
    go (env :: UniqFM ThLevel
env, subst :: UniqFM Id
subst) (b :: TcBinder
b : bs :: [TcBinder]
bs)
      | TcTvBndr name :: Name
name tyvar :: Id
tyvar <- TcBinder
b
       = do { let (env' :: UniqFM ThLevel
env', occ' :: OccName
occ') = UniqFM ThLevel -> OccName -> (UniqFM ThLevel, OccName)
tidyOccName UniqFM ThLevel
env (Name -> OccName
nameOccName Name
name)
                  name' :: Name
name'  = Name -> OccName -> Name
tidyNameOcc Name
name OccName
occ'
                  tyvar1 :: Id
tyvar1 = Id -> Name -> Id
setTyVarName Id
tyvar Name
name'
            ; Id
tyvar2 <- HasDebugCallStack => Id -> TcM Id
Id -> TcM Id
zonkTcTyVarToTyVar Id
tyvar1
              -- Be sure to zonk here!  Tidying applies to zonked
              -- types, so if we don't zonk we may create an
              -- ill-kinded type (Trac #14175)
            ; TidyEnv -> [TcBinder] -> TcM TidyEnv
go (UniqFM ThLevel
env', UniqFM Id -> Id -> Id -> UniqFM Id
forall a. VarEnv a -> Id -> a -> VarEnv a
extendVarEnv UniqFM Id
subst Id
tyvar Id
tyvar2) [TcBinder]
bs }
      | Bool
otherwise
      = TidyEnv -> [TcBinder] -> TcM TidyEnv
go (UniqFM ThLevel
env, UniqFM Id
subst) [TcBinder]
bs

-- | Get a 'TidyEnv' that includes mappings for all vars free in the given
-- type. Useful when tidying open types.
tcInitOpenTidyEnv :: [TyCoVar] -> TcM TidyEnv
tcInitOpenTidyEnv :: [Id] -> TcM TidyEnv
tcInitOpenTidyEnv tvs :: [Id]
tvs
  = do { TidyEnv
env1 <- TcM TidyEnv
tcInitTidyEnv
       ; let env2 :: TidyEnv
env2 = TidyEnv -> [Id] -> TidyEnv
tidyFreeTyCoVars TidyEnv
env1 [Id]
tvs
       ; TidyEnv -> TcM TidyEnv
forall (m :: * -> *) a. Monad m => a -> m a
return TidyEnv
env2 }



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

tcAddDataFamConPlaceholders :: [LInstDecl GhcRn] -> TcM a -> TcM a
-- See Note [AFamDataCon: not promoting data family constructors]
tcAddDataFamConPlaceholders :: [LInstDecl GhcRn] -> TcM a -> TcM a
tcAddDataFamConPlaceholders inst_decls :: [LInstDecl GhcRn]
inst_decls thing_inside :: 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)
                        | LInstDecl GhcRn
lid <- [LInstDecl GhcRn]
inst_decls, Name
con <- LInstDecl GhcRn -> [Name]
get_cons LInstDecl 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 _ (TyFamInstD {}))                     = []
    get_cons (L _ (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 _ (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 } }))
      = (LDataFamInstDecl GhcRn -> [Name])
-> [LDataFamInstDecl GhcRn] -> [Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (DataFamInstDecl GhcRn -> [Name]
get_fi_cons (DataFamInstDecl GhcRn -> [Name])
-> (LDataFamInstDecl GhcRn -> DataFamInstDecl GhcRn)
-> LDataFamInstDecl GhcRn
-> [Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LDataFamInstDecl GhcRn -> DataFamInstDecl GhcRn
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc) [LDataFamInstDecl GhcRn]
fids
    get_cons (L _ (ClsInstD _ (XClsInstDecl _))) = String -> [Name]
forall a. String -> a
panic "get_cons"
    get_cons (L _ (XInstDecl _)) = String -> [Name]
forall a. String -> a
panic "get_cons"

    get_fi_cons :: DataFamInstDecl GhcRn -> [Name]
    get_fi_cons :: DataFamInstDecl GhcRn -> [Name]
get_fi_cons (DataFamInstDecl { dfid_eqn :: forall pass.
DataFamInstDecl pass -> FamInstEqn pass (HsDataDefn pass)
dfid_eqn = HsIB { hsib_body :: forall pass thing. HsImplicitBndrs pass thing -> thing
hsib_body =
                  FamEqn { feqn_rhs :: forall pass pats rhs. FamEqn pass pats rhs -> rhs
feqn_rhs = HsDataDefn { dd_cons :: forall pass. HsDataDefn pass -> [LConDecl pass]
dd_cons = [LConDecl GhcRn]
cons } }}})
      = (Located Name -> Name) -> [Located Name] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Located Name -> Name
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc ([Located Name] -> [Name]) -> [Located Name] -> [Name]
forall a b. (a -> b) -> a -> b
$ (LConDecl GhcRn -> [Located Name])
-> [LConDecl GhcRn] -> [Located Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (ConDecl GhcRn -> [Located Name]
forall pass. ConDecl pass -> [Located (IdP pass)]
getConNames (ConDecl GhcRn -> [Located Name])
-> (LConDecl GhcRn -> ConDecl GhcRn)
-> LConDecl GhcRn
-> [Located Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LConDecl GhcRn -> ConDecl GhcRn
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc) [LConDecl GhcRn]
cons
    get_fi_cons (DataFamInstDecl { dfid_eqn :: forall pass.
DataFamInstDecl pass -> FamInstEqn pass (HsDataDefn pass)
dfid_eqn = HsIB { hsib_body :: forall pass thing. HsImplicitBndrs pass thing -> thing
hsib_body =
                  FamEqn { feqn_rhs :: forall pass pats rhs. FamEqn pass pats rhs -> rhs
feqn_rhs = XHsDataDefn _ }}})
      = String -> [Name]
forall a. String -> a
panic "get_fi_cons"
    get_fi_cons (DataFamInstDecl (HsIB _ (XFamEqn _))) = String -> [Name]
forall a. String -> a
panic "get_fi_cons"
    get_fi_cons (DataFamInstDecl (XHsImplicitBndrs _)) = String -> [Name]
forall a. String -> a
panic "get_fi_cons"


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

getTypeSigNames :: [LSig GhcRn] -> NameSet
-- Get the names that have a user type sig
getTypeSigNames :: [LSig GhcRn] -> RhsNames
getTypeSigNames sigs :: [LSig GhcRn]
sigs
  = (LSig GhcRn -> RhsNames -> RhsNames)
-> RhsNames -> [LSig GhcRn] -> RhsNames
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr LSig GhcRn -> RhsNames -> RhsNames
get_type_sig RhsNames
emptyNameSet [LSig GhcRn]
sigs
  where
    get_type_sig :: LSig GhcRn -> NameSet -> NameSet
    get_type_sig :: LSig GhcRn -> RhsNames -> RhsNames
get_type_sig sig :: LSig GhcRn
sig ns :: RhsNames
ns =
      case LSig GhcRn
sig of
        L _ (TypeSig _ names :: [GenLocated SrcSpan (IdP GhcRn)]
names _) -> RhsNames -> [Name] -> RhsNames
extendNameSetList RhsNames
ns ((Located Name -> Name) -> [Located Name] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Located Name -> Name
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc [Located Name]
[GenLocated SrcSpan (IdP GhcRn)]
names)
        L _ (PatSynSig _ names :: [GenLocated SrcSpan (IdP GhcRn)]
names _) -> RhsNames -> [Name] -> RhsNames
extendNameSetList RhsNames
ns ((Located Name -> Name) -> [Located Name] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Located Name -> Name
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc [Located Name]
[GenLocated SrcSpan (IdP GhcRn)]
names)
        _ -> 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.

Trac #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 (Trac #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 (Trac #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 tcAddPatSynPlaceholers adds a binding
    A -> APromotionErr PatSynPE
to the environment. Then TcHsType.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 :: [LRuleDecl GhcTc] -> TcM a -> TcM a
tcExtendRules lcl_rules :: [LRuleDecl GhcTc]
lcl_rules thing_inside :: TcM a
thing_inside
 = do { TcGblEnv
env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
      ; let
          env' :: TcGblEnv
env' = TcGblEnv
env { tcg_rules :: [LRuleDecl GhcTc]
tcg_rules = [LRuleDecl GhcTc]
lcl_rules [LRuleDecl GhcTc] -> [LRuleDecl GhcTc] -> [LRuleDecl GhcTc]
forall a. [a] -> [a] -> [a]
++ TcGblEnv -> [LRuleDecl GhcTc]
tcg_rules TcGblEnv
env }
      ; TcGblEnv -> TcM a -> TcM a
forall gbl lcl a. gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setGblEnv TcGblEnv
env' TcM a
thing_inside }

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

checkWellStaged :: SDoc         -- What the stage check is for
                -> ThLevel      -- Binding level (increases inside brackets)
                -> ThLevel      -- Use stage
                -> TcM ()       -- Fail if badly staged, adding an error
checkWellStaged :: MsgDoc -> ThLevel -> ThLevel -> IOEnv (Env TcGblEnv TcLclEnv) ()
checkWellStaged pp_thing :: MsgDoc
pp_thing bind_lvl :: ThLevel
bind_lvl use_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 (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
  = MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a. MsgDoc -> TcM a
stageRestrictionError MsgDoc
pp_thing

  | Bool
otherwise                   -- Badly staged
  = MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a. MsgDoc -> TcM a
failWithTc (MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$                -- E.g.  \x -> $(f x)
    String -> MsgDoc
text "Stage error:" MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc
pp_thing MsgDoc -> MsgDoc -> MsgDoc
<+>
        [MsgDoc] -> MsgDoc
hsep   [String -> MsgDoc
text "is bound at stage" MsgDoc -> MsgDoc -> MsgDoc
<+> ThLevel -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr ThLevel
bind_lvl,
                String -> MsgDoc
text "but used at stage" MsgDoc -> MsgDoc -> MsgDoc
<+> ThLevel -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr ThLevel
use_lvl]

stageRestrictionError :: SDoc -> TcM a
stageRestrictionError :: MsgDoc -> TcM a
stageRestrictionError pp_thing :: MsgDoc
pp_thing
  = MsgDoc -> TcM a
forall a. MsgDoc -> TcM a
failWithTc (MsgDoc -> TcM a) -> MsgDoc -> TcM a
forall a b. (a -> b) -> a -> b
$
    [MsgDoc] -> MsgDoc
sep [ String -> MsgDoc
text "GHC stage restriction:"
        , ThLevel -> MsgDoc -> MsgDoc
nest 2 ([MsgDoc] -> MsgDoc
vcat [ MsgDoc
pp_thing MsgDoc -> MsgDoc -> MsgDoc
<+> String -> MsgDoc
text "is used in a top-level splice, quasi-quote, or annotation,"
                       , String -> MsgDoc
text "and must be imported, not defined locally"])]

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 prcessing the $(f x), the binding for "x"
-- will be in the global env, not the local one.
topIdLvl :: Id -> ThLevel
topIdLvl id :: 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 tc_name :: Name
tc_name = do
    TyCon
t <- Name -> TcM TyCon
tcLookupTyCon Name
tc_name
    Type -> TcM Type
forall (m :: * -> *) a. Monad m => a -> m a
return (TyCon -> [Type] -> Type
mkTyConApp TyCon
t [])

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

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

tcGetDefaultTys :: TcM ([Type], -- Default types
                        (Bool,  -- True <=> Use overloaded strings
                         Bool)) -- True <=> Use extended defaulting rules
tcGetDefaultTys :: TcM ([Type], (Bool, Bool))
tcGetDefaultTys
  = do  { DynFlags
dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
        ; let ovl_strings :: Bool
ovl_strings = Extension -> DynFlags -> Bool
xopt Extension
LangExt.OverloadedStrings DynFlags
dflags
              extended_defaults :: Bool
extended_defaults = Extension -> DynFlags -> Bool
xopt Extension
LangExt.ExtendedDefaultRules DynFlags
dflags
                                        -- See also Trac #1974
              flags :: (Bool, Bool)
flags = (Bool
ovl_strings, Bool
extended_defaults)

        ; Maybe [Type]
mb_defaults <- TcRn (Maybe [Type])
getDeclaredDefaultTys
        ; case Maybe [Type]
mb_defaults of {
           Just tys :: [Type]
tys -> ([Type], (Bool, Bool)) -> TcM ([Type], (Bool, Bool))
forall (m :: * -> *) a. Monad m => a -> m a
return ([Type]
tys, (Bool, Bool)
flags) ;
                                -- User-supplied defaults
           Nothing  -> do

        -- No use-supplied default
        -- Use [Integer, Double], plus modifications
        { Type
integer_ty <- Name -> TcM Type
tcMetaTy Name
integerTyConName
        ; Type
list_ty <- Name -> TcM Type
tcMetaTy Name
listTyConName
        ; TyCon -> IOEnv (Env TcGblEnv TcLclEnv) ()
checkWiredInTyCon TyCon
doubleTyCon
        ; let deflt_tys :: [Type]
deflt_tys = Bool -> [Type] -> [Type]
forall a. Bool -> [a] -> [a]
opt_deflt Bool
extended_defaults [Type
unitTy, Type
list_ty]
                          -- Note [Extended defaults]
                          [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
integer_ty, Type
doubleTy]
                          [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ Bool -> [Type] -> [Type]
forall a. Bool -> [a] -> [a]
opt_deflt Bool
ovl_strings [Type
stringTy]
        ; ([Type], (Bool, Bool)) -> TcM ([Type], (Bool, Bool))
forall (m :: * -> *) a. Monad m => a -> m a
return ([Type]
deflt_tys, (Bool, Bool)
flags) } } }
  where
    opt_deflt :: Bool -> [a] -> [a]
opt_deflt True  xs :: [a]
xs = [a]
xs
    opt_deflt False _  = []

{-
Note [Extended defaults]
~~~~~~~~~~~~~~~~~~~~~
In interative 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 Trac #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
      { InstInfo a -> ClsInst
iSpec   :: ClsInst          -- Includes the dfun id
      , InstInfo a -> InstBindings a
iBinds  :: InstBindings a
      }

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

data InstBindings a
  = InstBindings
      { 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

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

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

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

      , 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 (GhcPass a))
       => Outputable (InstInfo (GhcPass a)) where
    ppr :: InstInfo (GhcPass a) -> MsgDoc
ppr = InstInfo (GhcPass a) -> MsgDoc
forall (a :: Pass).
OutputableBndrId (GhcPass a) =>
InstInfo (GhcPass a) -> MsgDoc
pprInstInfoDetails

pprInstInfoDetails :: (OutputableBndrId (GhcPass a))
                   => InstInfo (GhcPass a) -> SDoc
pprInstInfoDetails :: InstInfo (GhcPass a) -> MsgDoc
pprInstInfoDetails info :: InstInfo (GhcPass a)
info
   = MsgDoc -> ThLevel -> MsgDoc -> MsgDoc
hang (ClsInst -> MsgDoc
pprInstanceHdr (InstInfo (GhcPass a) -> ClsInst
forall a. InstInfo a -> ClsInst
iSpec InstInfo (GhcPass a)
info) MsgDoc -> MsgDoc -> MsgDoc
<+> String -> MsgDoc
text "where")
        2 (InstBindings (GhcPass a) -> MsgDoc
forall (idR :: Pass).
(OutputableBndr (IdP (GhcPass (NoGhcTcPass idR))),
 OutputableBndr (NameOrRdrName (IdP (GhcPass idR))),
 OutputableBndr (IdP (GhcPass idR)),
 OutputableBndr (NameOrRdrName (IdP (GhcPass (NoGhcTcPass idR)))),
 Outputable (XIPBinds (GhcPass (NoGhcTcPass idR))),
 Outputable (XViaStrategy (GhcPass (NoGhcTcPass idR))),
 Outputable (XIPBinds (GhcPass idR)),
 Outputable (XViaStrategy (GhcPass idR)),
 NoGhcTcPass idR ~ NoGhcTcPass (NoGhcTcPass idR)) =>
InstBindings (GhcPass idR) -> MsgDoc
details (InstInfo (GhcPass a) -> InstBindings (GhcPass a)
forall a. InstInfo a -> InstBindings a
iBinds InstInfo (GhcPass a)
info))
  where
    details :: InstBindings (GhcPass idR) -> MsgDoc
details (InstBindings { ib_binds :: forall a. InstBindings a -> LHsBinds a
ib_binds = LHsBinds (GhcPass idR)
b }) = LHsBinds (GhcPass idR) -> MsgDoc
forall (idL :: Pass) (idR :: Pass).
(OutputableBndrId (GhcPass idL), OutputableBndrId (GhcPass idR)) =>
LHsBindsLR (GhcPass idL) (GhcPass idR) -> MsgDoc
pprLHsBinds LHsBinds (GhcPass idR)
b

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

simpleInstInfoTy :: InstInfo a -> Type
simpleInstInfoTy :: InstInfo a -> Type
simpleInstInfoTy info :: 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 :: InstInfo a -> TyCon
simpleInstInfoTyCon inst :: 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 clas :: Class
clas tys :: [Type]
tys loc :: SrcSpan
loc
  = do  { Bool
is_boot <- TcRn Bool
tcIsHsBootOrSig
        ; Module
mod     <- IOEnv (Env TcGblEnv TcLclEnv) Module
forall (m :: * -> *). HasModule m => m Module
getModule
        ; let info_string :: String
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
        ; OccName
dfun_occ <- (OccSet -> OccName) -> TcM OccName
chooseUniqueOccTc (String -> Bool -> OccSet -> OccName
mkDFunOcc String
info_string Bool
is_boot)
        ; Module -> OccName -> SrcSpan -> TcM Name
forall a b. Module -> OccName -> SrcSpan -> TcRnIf a b Name
newGlobalBinder Module
mod OccName
dfun_occ SrcSpan
loc }

-- | Special case of 'newDFunName' to generate dict fun name for a single TyCon.
newDFunName' :: Class -> TyCon -> TcM Name
newDFunName' :: Class -> TyCon -> TcM Name
newDFunName' clas :: Class
clas tycon :: TyCon
tycon        -- Just a simple wrapper
  = do { SrcSpan
loc <- TcRn SrcSpan
getSrcSpanM     -- The location of the instance decl,
                                -- not of the tycon
       ; Class -> [Type] -> SrcSpan -> TcM Name
newDFunName Class
clas [TyCon -> [Type] -> Type
mkTyConApp TyCon
tycon []] SrcSpan
loc }
       -- The type passed to newDFunName is only used to generate
       -- a suitable string; hence the empty type arg list

{-
Make a name for the representation tycon of a family instance.  It's an
*external* name, like other top-level names, and hence must be made with
newGlobalBinder.
-}

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

newFamInstAxiomName :: Located Name -> [[Type]] -> TcM Name
newFamInstAxiomName :: Located Name -> [[Type]] -> TcM Name
newFamInstAxiomName (L loc :: SrcSpan
loc name :: Name
name) branches :: [[Type]]
branches
  = (OccName -> OccName) -> SrcSpan -> Name -> [[Type]] -> TcM Name
mk_fam_inst_name OccName -> OccName
mkInstTyCoOcc SrcSpan
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 adaptOcc :: OccName -> OccName
adaptOcc loc :: SrcSpan
loc tc_name :: Name
tc_name tyss :: [[Type]]
tyss
  = do  { Module
mod   <- IOEnv (Env TcGblEnv TcLclEnv) Module
forall (m :: * -> *). HasModule m => m Module
getModule
        ; let info_string :: String
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]
ty_strings
        ; OccName
occ   <- (OccSet -> OccName) -> TcM OccName
chooseUniqueOccTc (String -> OccSet -> OccName
mkInstTyTcOcc String
info_string)
        ; Module -> OccName -> SrcSpan -> TcM Name
forall a b. Module -> OccName -> SrcSpan -> TcRnIf a b Name
newGlobalBinder Module
mod (OccName -> OccName
adaptOcc OccName
occ) SrcSpan
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 str :: String
str sig_ty :: Type
sig_ty loc :: SrcSpan
loc occ_wrapper :: OccName -> OccName
occ_wrapper = do
    Unique
uniq <- TcRnIf TcGblEnv TcLclEnv Unique
forall gbl lcl. TcRnIf gbl lcl Unique
newUnique
    Module
mod <- IOEnv (Env TcGblEnv TcLclEnv) Module
forall (m :: * -> *). HasModule m => m Module
getModule
    FastString
name <- String -> String -> IOEnv (Env TcGblEnv TcLclEnv) FastString
forall (m :: * -> *).
(MonadIO m, HasDynFlags m, HasModule m) =>
String -> String -> m FastString
mkWrapperName "stable" String
str
    let occ :: OccName
occ = FastString -> OccName
mkVarOccFS FastString
name :: OccName
        gnm :: Name
gnm = Unique -> Module -> OccName -> SrcSpan -> Name
mkExternalName Unique
uniq Module
mod (OccName -> OccName
occ_wrapper OccName
occ) SrcSpan
loc :: Name
        id :: Id
id  = Name -> Type -> Id
mkExportedVanillaId Name
gnm Type
sig_ty :: Id
    Id -> TcM Id
forall (m :: * -> *) a. Monad m => a -> m a
return Id
id

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

mkWrapperName :: (MonadIO m, HasDynFlags m, HasModule m)
              => String -> String -> m FastString
mkWrapperName :: String -> String -> m FastString
mkWrapperName what :: String
what nameBase :: String
nameBase
    = do DynFlags
dflags <- m DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
         Module
thisMod <- m Module
forall (m :: * -> *). HasModule m => m Module
getModule
         let -- Note [Generating fresh names for ccall wrapper]
             wrapperRef :: IORef (ModuleEnv ThLevel)
wrapperRef = DynFlags -> IORef (ModuleEnv ThLevel)
nextWrapperNum DynFlags
dflags
             pkg :: String
pkg = UnitId -> String
unitIdString  (Module -> UnitId
moduleUnitId Module
thisMod)
             mod :: String
mod = ModuleName -> String
moduleNameString (Module -> ModuleName
moduleName      Module
thisMod)
         ThLevel
wrapperNum <- IO ThLevel -> m ThLevel
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ThLevel -> m ThLevel) -> IO ThLevel -> m ThLevel
forall a b. (a -> b) -> a -> b
$ IORef (ModuleEnv ThLevel)
-> (ModuleEnv ThLevel -> (ModuleEnv ThLevel, ThLevel))
-> IO ThLevel
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (ModuleEnv ThLevel)
wrapperRef ((ModuleEnv ThLevel -> (ModuleEnv ThLevel, ThLevel)) -> IO ThLevel)
-> (ModuleEnv ThLevel -> (ModuleEnv ThLevel, ThLevel))
-> IO ThLevel
forall a b. (a -> b) -> a -> b
$ \mod_env :: 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 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
+1)
             in (ModuleEnv ThLevel
mod_env', ThLevel
num)
         let components :: [String]
components = [String
what, ThLevel -> String
forall a. Show a => a -> String
show ThLevel
wrapperNum, String
pkg, String
mod, String
nameBase]
         FastString -> m FastString
forall (m :: * -> *) a. Monad m => a -> m a
return (FastString -> m FastString) -> FastString -> m FastString
forall a b. (a -> b) -> a -> b
$ String -> FastString
mkFastString (String -> FastString) -> String -> FastString
forall a b. (a -> b) -> a -> b
$ String -> String
zEncodeString (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate ":" [String]
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] -> MsgDoc
pprBinders [bndr :: Name
bndr] = MsgDoc -> MsgDoc
quotes (Name -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr Name
bndr)
pprBinders bndrs :: [Name]
bndrs  = (Name -> MsgDoc) -> [Name] -> MsgDoc
forall a. (a -> MsgDoc) -> [a] -> MsgDoc
pprWithCommas Name -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr [Name]
bndrs

notFound :: Name -> TcM TyThing
notFound :: Name -> TcM TyThing
notFound name :: Name
name
  = do { TcLclEnv
lcl_env <- TcRnIf TcGblEnv TcLclEnv TcLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv
       ; let stage :: ThStage
stage = TcLclEnv -> ThStage
tcl_th_ctxt TcLclEnv
lcl_env
       ; case ThStage
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 (Trac #11941)
             | Bool
otherwise -> MsgDoc -> TcM TyThing
forall a. MsgDoc -> TcM a
stageRestrictionError (MsgDoc -> MsgDoc
quotes (Name -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr Name
name))
           _ -> MsgDoc -> TcM TyThing
forall a. MsgDoc -> TcM a
failWithTc (MsgDoc -> TcM TyThing) -> MsgDoc -> TcM TyThing
forall a b. (a -> b) -> a -> b
$
                [MsgDoc] -> MsgDoc
vcat[String -> MsgDoc
text "GHC internal error:" MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc -> MsgDoc
quotes (Name -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr Name
name) MsgDoc -> MsgDoc -> MsgDoc
<+>
                     String -> MsgDoc
text "is not in scope during type checking, but it passed the renamer",
                     String -> MsgDoc
text "tcl_env of environment:" MsgDoc -> MsgDoc -> MsgDoc
<+> TcTypeEnv -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr (TcLclEnv -> TcTypeEnv
tcl_env 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 :: String -> TcTyThing -> Name -> TcM a
-- It's important that this only calls pprTcTyThingCategory, which in
-- turn does not look at the details of the TcTyThing.
-- See Note [Placeholder PatSyn kinds] in TcBinds
wrongThingErr :: String -> TcTyThing -> Name -> TcM a
wrongThingErr expected :: String
expected thing :: TcTyThing
thing name :: Name
name
  = MsgDoc -> TcM a
forall a. MsgDoc -> TcM a
failWithTc (TcTyThing -> MsgDoc
pprTcTyThingCategory TcTyThing
thing MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc -> MsgDoc
quotes (Name -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr Name
name) MsgDoc -> MsgDoc -> MsgDoc
<+>
                String -> MsgDoc
text "used as a" MsgDoc -> MsgDoc -> MsgDoc
<+> String -> MsgDoc
text String
expected)

{- 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 Trac #5752 and #5795.
-}