% (c) The University of Glasgow 2006
% (c) The GRASP Project, Glasgow University, 19922002
%
\begin{code}
module TcRnTypes(
TcRnIf, TcRn, TcM, RnM, IfM, IfL, IfG,
TcRef,
Env(..),
TcGblEnv(..), TcLclEnv(..),
IfGblEnv(..), IfLclEnv(..),
ErrCtxt, RecFieldEnv(..),
ImportAvails(..), emptyImportAvails, plusImportAvails,
WhereFrom(..), mkModDeps,
TcTyThing(..), pprTcTyThingCategory, RefinementVisibility(..),
ThStage(..), topStage, topAnnStage, topSpliceStage,
ThLevel, impLevel, outerLevel, thLevel,
ArrowCtxt(NoArrowCtxt), newArrowScope, escapeArrowScope,
Inst(..), EqInstCo, InstOrigin(..), InstLoc(..),
pprInstLoc, pprInstArising, instLocSpan, instLocOrigin, setInstLoc,
LIE, emptyLIE, unitLIE, plusLIE, consLIE, instLoc, instSpan,
plusLIEs, mkLIE, isEmptyLIE, lieToList, listToLIE,
TcId, TcIdSet, TcDictBinds, TcTyVarBind(..), TcTyVarBinds
) where
#include "HsVersions.h"
import HsSyn hiding (LIE)
import HscTypes
import Type
import Coercion
import TcType
import Annotations
import InstEnv
import FamInstEnv
import IOEnv
import RdrName
import Name
import NameEnv
import NameSet
import Var
import VarEnv
import Module
import LazyUniqFM
import SrcLoc
import VarSet
import ErrUtils
import UniqSupply
import BasicTypes
import Util
import Bag
import Outputable
import ListSetOps
import FastString
import Data.Set (Set)
\end{code}
%************************************************************************
%* *
Standard monad definition for TcRn
All the combinators for the monad can be found in TcRnMonad
%* *
%************************************************************************
The monad itself has to be defined here, because it is mentioned by ErrCtxt
\begin{code}
type TcRef a = IORef a
type TcId = Id
type TcIdSet = IdSet
type TcDictBinds = DictBinds TcId
type TcRnIf a b c = IOEnv (Env a b) c
type IfM lcl a = TcRnIf IfGblEnv lcl a
type IfG a = IfM () a
type IfL a = IfM IfLclEnv a
type TcRn a = TcRnIf TcGblEnv TcLclEnv a
type RnM a = TcRn a
type TcM a = TcRn a
\end{code}
Representation of type bindings to uninstantiated meta variables used during
constraint solving.
\begin{code}
data TcTyVarBind = TcTyVarBind TcTyVar TcType
type TcTyVarBinds = Bag TcTyVarBind
instance Outputable TcTyVarBind where
ppr (TcTyVarBind tv ty) = ppr tv <+> text ":=" <+> ppr ty
\end{code}
%************************************************************************
%* *
The main environment types
%* *
%************************************************************************
\begin{code}
data Env gbl lcl
= Env {
env_top :: HscEnv,
env_us :: !(IORef UniqSupply),
env_gbl :: gbl,
env_lcl :: lcl
}
data TcGblEnv
= TcGblEnv {
tcg_mod :: Module,
tcg_src :: HscSource,
tcg_rdr_env :: GlobalRdrEnv,
tcg_default :: Maybe [Type],
tcg_fix_env :: FixityEnv,
tcg_field_env :: RecFieldEnv,
tcg_type_env :: TypeEnv,
tcg_type_env_var :: TcRef TypeEnv,
tcg_inst_env :: InstEnv,
tcg_fam_inst_env :: FamInstEnv,
tcg_exports :: [AvailInfo],
tcg_imports :: ImportAvails,
tcg_dus :: DefUses,
tcg_keep :: TcRef NameSet,
tcg_inst_uses :: TcRef NameSet,
tcg_th_used :: TcRef Bool,
tcg_dfun_n :: TcRef OccSet,
tcg_rn_exports :: Maybe [Located (IE Name)],
tcg_rn_imports :: [LImportDecl Name],
tcg_used_rdrnames :: TcRef (Set RdrName),
tcg_rn_decls :: Maybe (HsGroup Name),
tcg_binds :: LHsBinds Id,
tcg_warns :: Warnings,
tcg_anns :: [Annotation],
tcg_insts :: [Instance],
tcg_fam_insts :: [FamInst],
tcg_rules :: [LRuleDecl Id],
tcg_fords :: [LForeignDecl Id],
tcg_doc_hdr :: Maybe LHsDocString,
tcg_hpc :: AnyHpcUsage,
tcg_main :: Maybe Name
}
data RecFieldEnv
= RecFields (NameEnv [Name])
NameSet
\end{code}
%************************************************************************
%* *
The interface environments
Used when dealing with IfaceDecls
%* *
%************************************************************************
\begin{code}
data IfGblEnv
= IfGblEnv {
if_rec_types :: Maybe (Module, IfG TypeEnv)
}
data IfLclEnv
= IfLclEnv {
if_mod :: Module,
if_loc :: SDoc,
if_tv_env :: UniqFM TyVar,
if_id_env :: UniqFM Id
}
\end{code}
%************************************************************************
%* *
The local typechecker environment
%* *
%************************************************************************
The GlobalEnv/LocalEnv story
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
During type checking, we keep in the tcg_type_env
* All types and classes
* All Ids derived from types and classes (constructors, selectors)
At the end of type checking, we zonk the local bindings,
and as we do so we add to the tcg_type_env
* Locally defined toplevel Ids
Why? Because they are now Ids not TcIds. This final GlobalEnv is
a) fed back (via the knot) to typechecking the
unfoldings of interface signatures
b) used in the ModDetails of this module
\begin{code}
data TcLclEnv
= TcLclEnv {
tcl_loc :: SrcSpan,
tcl_ctxt :: [ErrCtxt],
tcl_errs :: TcRef Messages,
tcl_th_ctxt :: ThStage,
tcl_arrow_ctxt :: ArrowCtxt,
tcl_rdr :: LocalRdrEnv,
tcl_env :: NameEnv TcTyThing,
tcl_tyvars :: TcRef TcTyVarSet,
tcl_lie :: TcRef LIE,
tcl_tybinds :: TcRef TcTyVarBinds
}
data ThStage
= Splice
| Comp
| Brack
ThStage
(TcRef [PendingSplice])
(TcRef LIE)
topStage, topAnnStage, topSpliceStage :: ThStage
topStage = Comp
topAnnStage = Splice
topSpliceStage = Splice
instance Outputable ThStage where
ppr Splice = text "Splice"
ppr Comp = text "Comp"
ppr (Brack s _ _) = text "Brack" <> parens (ppr s)
type ThLevel = Int
impLevel, outerLevel :: ThLevel
impLevel = 0
outerLevel = 1
thLevel :: ThStage -> ThLevel
thLevel Splice = 0
thLevel Comp = 1
thLevel (Brack s _ _) = thLevel s + 1
data ArrowCtxt
= NoArrowCtxt
| ArrowCtxt (Env TcGblEnv TcLclEnv)
newArrowScope :: TcM a -> TcM a
newArrowScope
= updEnv $ \env ->
env { env_lcl = (env_lcl env) { tcl_arrow_ctxt = ArrowCtxt env } }
escapeArrowScope :: TcM a -> TcM a
escapeArrowScope
= updEnv $ \ env -> case tcl_arrow_ctxt (env_lcl env) of
NoArrowCtxt -> env
ArrowCtxt env' -> env'
data TcTyThing
= AGlobal TyThing
| ATcId {
tct_id :: TcId,
tct_co :: RefinementVisibility,
tct_type :: TcType,
tct_level :: ThLevel }
| ATyVar Name TcType
| AThing TcKind
data RefinementVisibility
= Unrefineable
| Rigid HsWrapper
| Wobbly
| WobblyInvisible
instance Outputable TcTyThing where
ppr (AGlobal g) = pprTyThing g
ppr elt@(ATcId {}) = text "Identifier" <>
ifPprDebug (brackets (ppr (tct_id elt) <> dcolon <> ppr (tct_type elt) <> comma
<+> ppr (tct_level elt) <+> ppr (tct_co elt)))
ppr (ATyVar tv _) = text "Type variable" <+> quotes (ppr tv)
ppr (AThing k) = text "AThing" <+> ppr k
pprTcTyThingCategory :: TcTyThing -> SDoc
pprTcTyThingCategory (AGlobal thing) = pprTyThingCategory thing
pprTcTyThingCategory (ATyVar {}) = ptext (sLit "Type variable")
pprTcTyThingCategory (ATcId {}) = ptext (sLit "Local identifier")
pprTcTyThingCategory (AThing {}) = ptext (sLit "Kinded thing")
instance Outputable RefinementVisibility where
ppr Unrefineable = ptext (sLit "unrefineable")
ppr (Rigid co) = ptext (sLit "rigid") <+> ppr co
ppr Wobbly = ptext (sLit "wobbly")
ppr WobblyInvisible = ptext (sLit "wobbly-invisible")
\end{code}
\begin{code}
type ErrCtxt = (Bool, TidyEnv -> TcM (TidyEnv, Message))
\end{code}
%************************************************************************
%* *
Operations over ImportAvails
%* *
%************************************************************************
\begin{code}
data ImportAvails
= ImportAvails {
imp_mods :: ModuleEnv [(ModuleName, Bool, SrcSpan)],
imp_dep_mods :: ModuleNameEnv (ModuleName, IsBootInterface),
imp_dep_pkgs :: [PackageId],
imp_orphs :: [Module],
imp_finsts :: [Module]
}
mkModDeps :: [(ModuleName, IsBootInterface)]
-> ModuleNameEnv (ModuleName, IsBootInterface)
mkModDeps deps = foldl add emptyUFM deps
where
add env elt@(m,_) = addToUFM env m elt
emptyImportAvails :: ImportAvails
emptyImportAvails = ImportAvails { imp_mods = emptyModuleEnv,
imp_dep_mods = emptyUFM,
imp_dep_pkgs = [],
imp_orphs = [],
imp_finsts = [] }
plusImportAvails :: ImportAvails -> ImportAvails -> ImportAvails
plusImportAvails
(ImportAvails { imp_mods = mods1,
imp_dep_mods = dmods1, imp_dep_pkgs = dpkgs1,
imp_orphs = orphs1, imp_finsts = finsts1 })
(ImportAvails { imp_mods = mods2,
imp_dep_mods = dmods2, imp_dep_pkgs = dpkgs2,
imp_orphs = orphs2, imp_finsts = finsts2 })
= ImportAvails { imp_mods = plusModuleEnv_C (++) mods1 mods2,
imp_dep_mods = plusUFM_C plus_mod_dep dmods1 dmods2,
imp_dep_pkgs = dpkgs1 `unionLists` dpkgs2,
imp_orphs = orphs1 `unionLists` orphs2,
imp_finsts = finsts1 `unionLists` finsts2 }
where
plus_mod_dep (m1, boot1) (m2, boot2)
= WARN( not (m1 == m2), (ppr m1 <+> ppr m2) $$ (ppr boot1 <+> ppr boot2) )
(m1, boot1 && boot2)
\end{code}
%************************************************************************
%* *
\subsection{Where from}
%* *
%************************************************************************
The @WhereFrom@ type controls where the renamer looks for an interface file
\begin{code}
data WhereFrom
= ImportByUser IsBootInterface
| ImportBySystem
instance Outputable WhereFrom where
ppr (ImportByUser is_boot) | is_boot = ptext (sLit "{- SOURCE -}")
| otherwise = empty
ppr ImportBySystem = ptext (sLit "{- SYSTEM -}")
\end{code}
%************************************************************************
%* *
\subsection[Insttypes]{@Inst@ types}
%* *
v%************************************************************************
An @Inst@ is either a dictionary, an instance of an overloaded
literal, or an instance of an overloaded value. We call the latter a
``method'' even though it may not correspond to a class operation.
For example, we might have an instance of the @double@ function at
type Int, represented by
Method 34 doubleId [Int] origin
In addition to the basic Haskell variants of 'Inst's, they can now also
represent implication constraints 'forall tvs. given => wanted'
and equality constraints 'co :: ty1 ~ ty2'.
NB: Equalities occur in two flavours:
(1) Dict {tci_pred = EqPred ty1 ty2}
(2) EqInst {tci_left = ty1, tci_right = ty2, tci_co = coe}
The former arises from equalities in contexts, whereas the latter is used
whenever the type checker introduces an equality (e.g., during deferring
unification).
I am not convinced that this duplication is necessary or useful! -=chak
\begin{code}
data Inst
= Dict {
tci_name :: Name,
tci_pred :: TcPredType,
tci_loc :: InstLoc
}
| ImplicInst {
tci_name :: Name,
tci_tyvars :: [TcTyVar],
tci_given :: [Inst],
tci_wanted :: [Inst],
tci_loc :: InstLoc
}
| Method {
tci_id :: TcId,
tci_oid :: TcId,
tci_tys :: [TcType],
tci_theta :: TcThetaType,
tci_loc :: InstLoc
}
| LitInst {
tci_name :: Name,
tci_lit :: HsOverLit Name,
tci_ty :: TcType,
tci_loc :: InstLoc
}
| EqInst {
tci_left :: TcType,
tci_right :: TcType,
tci_co :: EqInstCo,
tci_loc :: InstLoc,
tci_name :: Name
}
type EqInstCo = Either
TcTyVar
Coercion
\end{code}
@Insts@ are ordered by their class/type info, rather than by their
unique. This allows the contextreduction mechanism to use standard finite
maps to do their stuff. It's horrible that this code is here, rather
than with the Avails handling stuff in TcSimplify
\begin{code}
instance Ord Inst where
compare = cmpInst
instance Eq Inst where
(==) i1 i2 = case i1 `cmpInst` i2 of
EQ -> True
_ -> False
cmpInst :: Inst -> Inst -> Ordering
cmpInst d1@(Dict {}) d2@(Dict {}) = tci_pred d1 `tcCmpPred` tci_pred d2
cmpInst (Dict {}) _ = LT
cmpInst (Method {}) (Dict {}) = GT
cmpInst m1@(Method {}) m2@(Method {}) = (tci_oid m1 `compare` tci_oid m2) `thenCmp`
(tci_tys m1 `tcCmpTypes` tci_tys m2)
cmpInst (Method {}) _ = LT
cmpInst (LitInst {}) (Dict {}) = GT
cmpInst (LitInst {}) (Method {}) = GT
cmpInst l1@(LitInst {}) l2@(LitInst {}) = (tci_lit l1 `compare` tci_lit l2) `thenCmp`
(tci_ty l1 `tcCmpType` tci_ty l2)
cmpInst (LitInst {}) _ = LT
cmpInst (ImplicInst {}) (Dict {}) = GT
cmpInst (ImplicInst {}) (Method {}) = GT
cmpInst (ImplicInst {}) (LitInst {}) = GT
cmpInst i1@(ImplicInst {}) i2@(ImplicInst {}) = tci_name i1 `compare` tci_name i2
cmpInst (ImplicInst {}) _ = LT
cmpInst (EqInst {}) (Dict {}) = GT
cmpInst (EqInst {}) (Method {}) = GT
cmpInst (EqInst {}) (LitInst {}) = GT
cmpInst (EqInst {}) (ImplicInst {}) = GT
cmpInst i1@(EqInst {}) i2@(EqInst {}) = (tci_left i1 `tcCmpType` tci_left i2) `thenCmp`
(tci_right i1 `tcCmpType` tci_right i2)
\end{code}
%************************************************************************
%* *
\subsection[Instcollections]{LIE: a collection of Insts}
%* *
%************************************************************************
\begin{code}
type LIE = Bag Inst
isEmptyLIE :: LIE -> Bool
isEmptyLIE = isEmptyBag
emptyLIE :: LIE
emptyLIE = emptyBag
unitLIE :: Inst -> LIE
unitLIE inst = unitBag inst
mkLIE :: [Inst] -> LIE
mkLIE insts = listToBag insts
plusLIE :: LIE -> LIE -> LIE
plusLIE lie1 lie2 = lie1 `unionBags` lie2
plusLIEs :: [LIE] -> LIE
plusLIEs lies = unionManyBags lies
lieToList :: LIE -> [Inst]
lieToList = bagToList
listToLIE :: [Inst] -> LIE
listToLIE = listToBag
consLIE :: Inst -> LIE -> LIE
consLIE inst lie = lie `snocBag` inst
\end{code}
%************************************************************************
%* *
\subsection[Instorigin]{The @InstOrigin@ type}
%* *
%************************************************************************
The @InstOrigin@ type gives information about where a dictionary came from.
This is important for decent error message reporting because dictionaries
don't appear in the original source code. Doubtless this type will evolve...
It appears in TcMonad because there are a couple of errormessagegeneration
functions that deal with it.
\begin{code}
data InstLoc = InstLoc InstOrigin SrcSpan [ErrCtxt]
instLoc :: Inst -> InstLoc
instLoc inst = tci_loc inst
setInstLoc :: Inst -> InstLoc -> Inst
setInstLoc inst new_loc = inst { tci_loc = new_loc }
instSpan :: Inst -> SrcSpan
instSpan wanted = instLocSpan (instLoc wanted)
instLocSpan :: InstLoc -> SrcSpan
instLocSpan (InstLoc _ s _) = s
instLocOrigin :: InstLoc -> InstOrigin
instLocOrigin (InstLoc o _ _) = o
pprInstArising :: Inst -> SDoc
pprInstArising loc = ptext (sLit "arising from") <+> pprInstLoc (tci_loc loc)
pprInstLoc :: InstLoc -> SDoc
pprInstLoc (InstLoc orig span _) = sep [ppr orig, text "at" <+> ppr span]
data InstOrigin
= SigOrigin SkolemInfo
| IPBindOrigin (IPName Name)
| OccurrenceOf Name
| SpecPragOrigin Name
| IPOccOrigin (IPName Name)
| LiteralOrigin (HsOverLit Name)
| NegateOrigin
| ArithSeqOrigin (ArithSeqInfo Name)
| PArrSeqOrigin (ArithSeqInfo Name)
| TupleOrigin
| InstSigOrigin
| ExprSigOrigin
| RecordUpdOrigin
| ViewPatOrigin
| InstScOrigin
| NoScOrigin
| DerivOrigin
| StandAloneDerivOrigin
| DefaultOrigin
| DoOrigin
| ProcOrigin
| ImplicOrigin SDoc
| EqOrigin
| AnnOrigin
instance Outputable InstOrigin where
ppr (OccurrenceOf name) = hsep [ptext (sLit "a use of"), quotes (ppr name)]
ppr (SpecPragOrigin name) = hsep [ptext (sLit "a specialisation pragma for"), quotes (ppr name)]
ppr (IPOccOrigin name) = hsep [ptext (sLit "a use of implicit parameter"), quotes (ppr name)]
ppr (IPBindOrigin name) = hsep [ptext (sLit "a binding for implicit parameter"), quotes (ppr name)]
ppr RecordUpdOrigin = ptext (sLit "a record update")
ppr ExprSigOrigin = ptext (sLit "an expression type signature")
ppr ViewPatOrigin = ptext (sLit "a view pattern")
ppr (LiteralOrigin lit) = hsep [ptext (sLit "the literal"), quotes (ppr lit)]
ppr (ArithSeqOrigin seq) = hsep [ptext (sLit "the arithmetic sequence"), quotes (ppr seq)]
ppr (PArrSeqOrigin seq) = hsep [ptext (sLit "the parallel array sequence"), quotes (ppr seq)]
ppr TupleOrigin = ptext (sLit "a tuple")
ppr NegateOrigin = ptext (sLit "a use of syntactic negation")
ppr InstScOrigin = ptext (sLit "the superclasses of an instance declaration")
ppr NoScOrigin = ptext (sLit "an instance declaration")
ppr DerivOrigin = ptext (sLit "the 'deriving' clause of a data type declaration")
ppr StandAloneDerivOrigin = ptext (sLit "a 'deriving' declaration")
ppr DefaultOrigin = ptext (sLit "a 'default' declaration")
ppr DoOrigin = ptext (sLit "a do statement")
ppr ProcOrigin = ptext (sLit "a proc expression")
ppr (ImplicOrigin doc) = doc
ppr (SigOrigin info) = pprSkolInfo info
ppr EqOrigin = ptext (sLit "a type equality")
ppr InstSigOrigin = panic "ppr InstSigOrigin"
ppr AnnOrigin = ptext (sLit "an annotation")
\end{code}