% (c) The University of Glasgow 2006
% (c) The GRASP Project, Glasgow University, 1992-2002
%
\begin{code}
module TcRnTypes(
TcRnIf, TcRn, TcM, RnM, IfM, IfL, IfG,
TcRef,
Env(..),
TcGblEnv(..), TcLclEnv(..),
IfGblEnv(..), IfLclEnv(..),
ErrCtxt, RecFieldEnv(..),
ImportAvails(..), emptyImportAvails, plusImportAvails,
WhereFrom(..), mkModDeps,
TcTypeEnv, TcTyThing(..), pprTcTyThingCategory,
ThStage(..), topStage, topAnnStage, topSpliceStage,
ThLevel, impLevel, outerLevel, thLevel,
ArrowCtxt(NoArrowCtxt), newArrowScope, escapeArrowScope,
Untouchables(..), inTouchableRange, isNoUntouchables,
WantedConstraints(..), insolubleWC, emptyWC, isEmptyWC,
andWC, addFlats, addImplics, mkFlatWC,
EvVarX(..), mkEvVarX, evVarOf, evVarX, evVarOfPred,
WantedEvVar, wantedToFlavored,
keepWanted,
Implication(..),
CtLoc(..), ctLocSpan, ctLocOrigin, setCtLocOrigin,
CtOrigin(..), EqOrigin(..),
WantedLoc, GivenLoc, pushErrCtxt,
SkolemInfo(..),
CtFlavor(..), pprFlavorArising, isWanted, isGiven, isDerived,
FlavoredEvVar,
pprEvVarTheta, pprWantedEvVar, pprWantedsWithLocs,
pprEvVars, pprEvVarWithType,
pprArising, pprArisingAt,
TcId, TcIdSet, TcTyVarBind(..), TcTyVarBinds
) where
#include "HsVersions.h"
import HsSyn
import HscTypes
import Type
import Class ( Class )
import DataCon ( DataCon, dataConUserType )
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 SrcLoc
import VarSet
import ErrUtils
import UniqFM
import UniqSupply
import Unique
import BasicTypes
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 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_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_ev_binds :: Bag EvBind,
tcg_binds :: LHsBinds Id,
tcg_sigs :: NameSet,
tcg_imp_specs :: [LTcSpecPrag],
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 Global-Env/Local-Env 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 top-level 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 :: TcTypeEnv,
tcl_tyvars :: TcRef TcTyVarSet,
tcl_lie :: TcRef WantedConstraints,
tcl_meta :: TcRef Unique,
tcl_untch :: Unique
}
type TcTypeEnv = NameEnv TcTyThing
data ThStage
= Splice
| Comp
| Brack
ThStage
(TcRef [PendingSplice])
(TcRef WantedConstraints)
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_level :: ThLevel }
| ATyVar Name TcType
| AThing TcKind
instance Outputable TcTyThing where
ppr (AGlobal g) = pprTyThing g
ppr elt@(ATcId {}) = text "Identifier" <>
brackets (ppr (tct_id elt) <> dcolon
<> ppr (varType (tct_id elt)) <> comma
<+> ppr (tct_level 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")
\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}
%************************************************************************
%* *
Wanted constraints
These are forced to be in TcRnTypes because
TcLclEnv mentions WantedConstraints
WantedConstraint mentions CtLoc
CtLoc mentions ErrCtxt
ErrCtxt mentions TcM
%* *
v%************************************************************************
\begin{code}
data WantedConstraints
= WC { wc_flat :: Bag WantedEvVar
, wc_impl :: Bag Implication
, wc_insol :: Bag FlavoredEvVar
}
emptyWC :: WantedConstraints
emptyWC = WC { wc_flat = emptyBag, wc_impl = emptyBag, wc_insol = emptyBag }
mkFlatWC :: Bag WantedEvVar -> WantedConstraints
mkFlatWC wevs = WC { wc_flat = wevs, wc_impl = emptyBag, wc_insol = emptyBag }
isEmptyWC :: WantedConstraints -> Bool
isEmptyWC (WC { wc_flat = f, wc_impl = i, wc_insol = n })
= isEmptyBag f && isEmptyBag i && isEmptyBag n
insolubleWC :: WantedConstraints -> Bool
insolubleWC wc = not (isEmptyBag (wc_insol wc))
|| anyBag ic_insol (wc_impl wc)
andWC :: WantedConstraints -> WantedConstraints -> WantedConstraints
andWC (WC { wc_flat = f1, wc_impl = i1, wc_insol = n1 })
(WC { wc_flat = f2, wc_impl = i2, wc_insol = n2 })
= WC { wc_flat = f1 `unionBags` f2
, wc_impl = i1 `unionBags` i2
, wc_insol = n1 `unionBags` n2 }
addFlats :: WantedConstraints -> Bag WantedEvVar -> WantedConstraints
addFlats wc wevs = wc { wc_flat = wevs `unionBags` wc_flat wc }
addImplics :: WantedConstraints -> Bag Implication -> WantedConstraints
addImplics wc implic = wc { wc_impl = implic `unionBags` wc_impl wc }
instance Outputable WantedConstraints where
ppr (WC {wc_flat = f, wc_impl = i, wc_insol = n})
= ptext (sLit "WC") <+> braces (vcat
[ if isEmptyBag f then empty else
ptext (sLit "wc_flat =") <+> pprBag pprWantedEvVar f
, if isEmptyBag i then empty else
ptext (sLit "wc_impl =") <+> pprBag ppr i
, if isEmptyBag n then empty else
ptext (sLit "wc_insol =") <+> pprBag ppr n ])
pprBag :: (a -> SDoc) -> Bag a -> SDoc
pprBag pp b = foldrBag (($$) . pp) empty b
\end{code}
\begin{code}
data Untouchables = NoUntouchables
| TouchableRange
Unique
Unique
instance Outputable Untouchables where
ppr NoUntouchables = ptext (sLit "No untouchables")
ppr (TouchableRange low high) = ptext (sLit "Touchable range:") <+>
ppr low <+> char '-' <+> ppr high
isNoUntouchables :: Untouchables -> Bool
isNoUntouchables NoUntouchables = True
isNoUntouchables (TouchableRange {}) = False
inTouchableRange :: Untouchables -> TcTyVar -> Bool
inTouchableRange NoUntouchables _ = True
inTouchableRange (TouchableRange low high) tv
= uniq >= low && uniq < high
where
uniq = varUnique tv
\end{code}
%************************************************************************
%* *
Implication constraints
%* *
%************************************************************************
\begin{code}
data Implication
= Implic {
ic_untch :: Untouchables,
ic_env :: TcTypeEnv,
ic_skols :: TcTyVarSet,
ic_given :: [EvVar],
ic_loc :: GivenLoc,
ic_wanted :: WantedConstraints,
ic_insol :: Bool,
ic_binds :: EvBindsVar
}
instance Outputable Implication where
ppr (Implic { ic_untch = untch, ic_skols = skols, ic_given = given
, ic_wanted = wanted
, ic_binds = binds, ic_loc = loc })
= ptext (sLit "Implic") <+> braces
(sep [ ptext (sLit "Untouchables = ") <+> ppr untch
, ptext (sLit "Skolems = ") <+> ppr skols
, ptext (sLit "Given = ") <+> pprEvVars given
, ptext (sLit "Wanted = ") <+> ppr wanted
, ptext (sLit "Binds = ") <+> ppr binds
, pprSkolInfo (ctLocOrigin loc)
, ppr (ctLocSpan loc) ])
\end{code}
Note [Skolems in an implication]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The skolems in an implication are not there to perform a skolem escape
check. That happens because all the environment variables are in the
untouchables, and therefore cannot be unified with anything at all,
let alone the skolems.
Instead, ic_skols is used only when considering floating a constraint
outside the implication in TcSimplify.floatEqualities or
TcSimplify.approximateImplications
Note [Insoluble constraints]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Some of the errors that we get during canonicalization are best
reported when all constraints have been simplified as much as
possible. For instance, assume that during simplification the
following constraints arise:
[Wanted] F alpha ~ uf1
[Wanted] beta ~ uf1 beta
When canonicalizing the wanted (beta ~ uf1 beta), if we eagerly fail
we will simply see a message:
'Can't construct the infinite type beta ~ uf1 beta'
and the user has no idea what the uf1 variable is.
Instead our plan is that we will NOT fail immediately, but:
(1) Record the "frozen" error in the ic_insols field
(2) Isolate the offending constraint from the rest of the inerts
(3) Keep on simplifying/canonicalizing
At the end, we will hopefully have substituted uf1 := F alpha, and we
will be able to report a more informative error:
'Can't construct the infinite type beta ~ F alpha beta'
%************************************************************************
%* *
EvVarX, WantedEvVar, FlavoredEvVar
%* *
%************************************************************************
\begin{code}
data EvVarX a = EvVarX EvVar a
type WantedEvVar = EvVarX WantedLoc
type FlavoredEvVar = EvVarX CtFlavor
instance Outputable (EvVarX a) where
ppr (EvVarX ev _) = pprEvVarWithType ev
mkEvVarX :: EvVar -> a -> EvVarX a
mkEvVarX = EvVarX
evVarOf :: EvVarX a -> EvVar
evVarOf (EvVarX ev _) = ev
evVarX :: EvVarX a -> a
evVarX (EvVarX _ a) = a
evVarOfPred :: EvVarX a -> PredType
evVarOfPred wev = evVarPred (evVarOf wev)
wantedToFlavored :: WantedEvVar -> FlavoredEvVar
wantedToFlavored (EvVarX v wl) = EvVarX v (Wanted wl)
keepWanted :: Bag FlavoredEvVar -> Bag WantedEvVar
keepWanted flevs
= foldlBag keep_wanted emptyBag flevs
where
keep_wanted :: Bag WantedEvVar -> FlavoredEvVar -> Bag WantedEvVar
keep_wanted r (EvVarX ev (Wanted wloc)) = consBag (EvVarX ev wloc) r
keep_wanted r _ = r
\end{code}
\begin{code}
pprEvVars :: [EvVar] -> SDoc
pprEvVars ev_vars = vcat (map pprEvVarWithType ev_vars)
pprEvVarTheta :: [EvVar] -> SDoc
pprEvVarTheta ev_vars = pprTheta (map evVarPred ev_vars)
pprEvVarWithType :: EvVar -> SDoc
pprEvVarWithType v = ppr v <+> dcolon <+> pprPred (evVarPred v)
pprWantedsWithLocs :: WantedConstraints -> SDoc
pprWantedsWithLocs wcs
= vcat [ pprBag pprWantedEvVarWithLoc (wc_flat wcs)
, pprBag ppr (wc_impl wcs)
, pprBag ppr (wc_insol wcs) ]
pprWantedEvVarWithLoc, pprWantedEvVar :: WantedEvVar -> SDoc
pprWantedEvVarWithLoc (EvVarX v loc) = hang (pprEvVarWithType v)
2 (pprArisingAt loc)
pprWantedEvVar (EvVarX v _) = pprEvVarWithType v
\end{code}
%************************************************************************
%* *
CtLoc
%* *
%************************************************************************
\begin{code}
data CtFlavor
= Given GivenLoc
| Derived WantedLoc
| Wanted WantedLoc
instance Outputable CtFlavor where
ppr (Given {}) = ptext (sLit "[G]")
ppr (Wanted {}) = ptext (sLit "[W]")
ppr (Derived {}) = ptext (sLit "[D]")
pprFlavorArising :: CtFlavor -> SDoc
pprFlavorArising (Derived wl ) = pprArisingAt wl
pprFlavorArising (Wanted wl) = pprArisingAt wl
pprFlavorArising (Given gl) = pprArisingAt gl
isWanted :: CtFlavor -> Bool
isWanted (Wanted {}) = True
isWanted _ = False
isGiven :: CtFlavor -> Bool
isGiven (Given {}) = True
isGiven _ = False
isDerived :: CtFlavor -> Bool
isDerived (Derived {}) = True
isDerived _ = False
\end{code}
%************************************************************************
%* *
CtLoc
%* *
%************************************************************************
The 'CtLoc' gives information about where a constraint came from.
This is important for decent error message reporting because
dictionaries don't appear in the original source code.
type will evolve...
\begin{code}
data CtLoc orig = CtLoc orig SrcSpan [ErrCtxt]
type WantedLoc = CtLoc CtOrigin
type GivenLoc = CtLoc SkolemInfo
ctLocSpan :: CtLoc o -> SrcSpan
ctLocSpan (CtLoc _ s _) = s
ctLocOrigin :: CtLoc o -> o
ctLocOrigin (CtLoc o _ _) = o
setCtLocOrigin :: CtLoc o -> o' -> CtLoc o'
setCtLocOrigin (CtLoc _ s c) o = CtLoc o s c
pushErrCtxt :: orig -> ErrCtxt -> CtLoc orig -> CtLoc orig
pushErrCtxt o err (CtLoc _ s errs) = CtLoc o s (err:errs)
pprArising :: CtOrigin -> SDoc
pprArising (TypeEqOrigin {}) = empty
pprArising FunDepOrigin = empty
pprArising orig = text "arising from" <+> ppr orig
pprArisingAt :: Outputable o => CtLoc o -> SDoc
pprArisingAt (CtLoc o s _) = sep [ text "arising from" <+> ppr o
, text "at" <+> ppr s]
\end{code}
%************************************************************************
%* *
SkolemInfo
%* *
%************************************************************************
\begin{code}
data SkolemInfo
= SigSkol UserTypeCtxt
Type
| ClsSkol Class
| InstSkol
| DataSkol
| FamInstSkol
| PatSkol
DataCon
(HsMatchContext Name)
| ArrowSkol
| IPSkol [IPName Name]
| RuleSkol RuleName
| InferSkol [(Name,TcType)]
| RuntimeUnkSkol
| BracketSkol
| UnkSkol
instance Outputable SkolemInfo where
ppr = pprSkolInfo
pprSkolInfo :: SkolemInfo -> SDoc
pprSkolInfo (SigSkol (FunSigCtxt f) ty)
= hang (ptext (sLit "the type signature for"))
2 (ppr f <+> dcolon <+> ppr ty)
pprSkolInfo (SigSkol cx ty) = hang (pprUserTypeCtxt cx <> colon)
2 (ppr ty)
pprSkolInfo (IPSkol ips) = ptext (sLit "the implicit-parameter bindings for")
<+> pprWithCommas ppr ips
pprSkolInfo (ClsSkol cls) = ptext (sLit "the class declaration for") <+> quotes (ppr cls)
pprSkolInfo InstSkol = ptext (sLit "the instance declaration")
pprSkolInfo DataSkol = ptext (sLit "the data type declaration")
pprSkolInfo FamInstSkol = ptext (sLit "the family instance declaration")
pprSkolInfo BracketSkol = ptext (sLit "a Template Haskell bracket")
pprSkolInfo (RuleSkol name) = ptext (sLit "the RULE") <+> doubleQuotes (ftext name)
pprSkolInfo ArrowSkol = ptext (sLit "the arrow form")
pprSkolInfo (PatSkol dc mc) = sep [ ptext (sLit "a pattern with constructor")
, nest 2 $ ppr dc <+> dcolon
<+> ppr (dataConUserType dc) <> comma
, ptext (sLit "in") <+> pprMatchContext mc ]
pprSkolInfo (InferSkol ids) = sep [ ptext (sLit "the inferred type of")
, vcat [ ppr name <+> dcolon <+> ppr ty
| (name,ty) <- ids ]]
pprSkolInfo UnkSkol = WARN( True, text "pprSkolInfo: UnkSkol" ) ptext (sLit "UnkSkol")
pprSkolInfo RuntimeUnkSkol = WARN( True, text "pprSkolInfo: RuntimeUnkSkol" ) ptext (sLit "RuntimeUnkSkol")
\end{code}
%************************************************************************
%* *
CtOrigin
%* *
%************************************************************************
\begin{code}
data CtOrigin
= OccurrenceOf Name
| AppOrigin
| SpecPragOrigin Name
| TypeEqOrigin EqOrigin
| IPOccOrigin (IPName Name)
| LiteralOrigin (HsOverLit Name)
| NegateOrigin
| ArithSeqOrigin (ArithSeqInfo Name)
| PArrSeqOrigin (ArithSeqInfo Name)
| SectionOrigin
| TupleOrigin
| ExprSigOrigin
| PatSigOrigin
| PatOrigin
| RecordUpdOrigin
| ViewPatOrigin
| ScOrigin
| DerivOrigin
| StandAloneDerivOrigin
| DefaultOrigin
| DoOrigin
| IfOrigin
| ProcOrigin
| AnnOrigin
| FunDepOrigin
data EqOrigin
= UnifyOrigin
{ uo_actual :: TcType
, uo_expected :: TcType }
instance Outputable CtOrigin where
ppr orig = pprO orig
pprO :: CtOrigin -> SDoc
pprO (OccurrenceOf name) = hsep [ptext (sLit "a use of"), quotes (ppr name)]
pprO AppOrigin = ptext (sLit "an application")
pprO (SpecPragOrigin name) = hsep [ptext (sLit "a specialisation pragma for"), quotes (ppr name)]
pprO (IPOccOrigin name) = hsep [ptext (sLit "a use of implicit parameter"), quotes (ppr name)]
pprO RecordUpdOrigin = ptext (sLit "a record update")
pprO ExprSigOrigin = ptext (sLit "an expression type signature")
pprO PatSigOrigin = ptext (sLit "a pattern type signature")
pprO PatOrigin = ptext (sLit "a pattern")
pprO ViewPatOrigin = ptext (sLit "a view pattern")
pprO IfOrigin = ptext (sLit "an if statement")
pprO (LiteralOrigin lit) = hsep [ptext (sLit "the literal"), quotes (ppr lit)]
pprO (ArithSeqOrigin seq) = hsep [ptext (sLit "the arithmetic sequence"), quotes (ppr seq)]
pprO (PArrSeqOrigin seq) = hsep [ptext (sLit "the parallel array sequence"), quotes (ppr seq)]
pprO SectionOrigin = ptext (sLit "an operator section")
pprO TupleOrigin = ptext (sLit "a tuple")
pprO NegateOrigin = ptext (sLit "a use of syntactic negation")
pprO ScOrigin = ptext (sLit "the superclasses of an instance declaration")
pprO DerivOrigin = ptext (sLit "the 'deriving' clause of a data type declaration")
pprO StandAloneDerivOrigin = ptext (sLit "a 'deriving' declaration")
pprO DefaultOrigin = ptext (sLit "a 'default' declaration")
pprO DoOrigin = ptext (sLit "a do statement")
pprO ProcOrigin = ptext (sLit "a proc expression")
pprO (TypeEqOrigin eq) = ptext (sLit "an equality") <+> ppr eq
pprO AnnOrigin = ptext (sLit "an annotation")
pprO FunDepOrigin = ptext (sLit "a functional dependency")
instance Outputable EqOrigin where
ppr (UnifyOrigin t1 t2) = ppr t1 <+> char '~' <+> ppr t2
\end{code}