summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--ghc/compiler/iface/LoadIface.lhs33
-rw-r--r--ghc/compiler/main/HscTypes.lhs7
-rw-r--r--ghc/compiler/rename/RnNames.lhs2
-rw-r--r--ghc/compiler/typecheck/TcEnv.lhs11
-rw-r--r--ghc/compiler/typecheck/TcExpr.lhs2
-rw-r--r--ghc/compiler/typecheck/TcHsSyn.lhs4
-rw-r--r--ghc/compiler/typecheck/TcMType.lhs4
-rw-r--r--ghc/compiler/typecheck/TcPat.lhs2
-rw-r--r--ghc/compiler/typecheck/TcRnDriver.lhs94
-rw-r--r--ghc/compiler/typecheck/TcRnTypes.lhs6
-rw-r--r--ghc/compiler/typecheck/TcTyDecls.lhs22
-rw-r--r--ghc/compiler/typecheck/TcType.lhs4
-rw-r--r--ghc/compiler/typecheck/TcUnify.lhs2
-rw-r--r--ghc/compiler/types/Type.lhs2
-rw-r--r--ghc/compiler/types/TypeRep.lhs13
15 files changed, 166 insertions, 42 deletions
diff --git a/ghc/compiler/iface/LoadIface.lhs b/ghc/compiler/iface/LoadIface.lhs
index 62e31d4605..b6b59d7166 100644
--- a/ghc/compiler/iface/LoadIface.lhs
+++ b/ghc/compiler/iface/LoadIface.lhs
@@ -6,7 +6,7 @@
\begin{code}
module LoadIface (
loadHomeInterface, loadInterface,
- loadSrcInterface, loadOrphanModules,
+ loadSrcInterface, loadOrphanModules, loadHiBootInterface,
readIface, -- Used when reading the module's old interface
predInstGates, ifaceInstGates, ifaceStats, discardDeclPrags,
initExternalPackageState
@@ -50,7 +50,8 @@ import MkId ( seqId )
import Packages ( basePackage )
import Module ( Module, ModuleName, ModLocation(ml_hi_file),
moduleName, isHomeModule, emptyModuleEnv,
- extendModuleEnv, lookupModuleEnvByName, moduleUserString
+ extendModuleEnv, lookupModuleEnvByName, lookupModuleEnv,
+ moduleUserString
)
import OccName ( OccName, mkOccEnv, lookupOccEnv, mkClassTyConOcc, mkClassDataConOcc,
mkSuperDictSelOcc, mkDataConWrapperOcc, mkDataConWorkerOcc )
@@ -99,6 +100,34 @@ loadSrcInterface doc mod_name want_boot
elaborate err = hang (ptext SLIT("Failed to load interface for") <+>
quotes (ppr mod_name) <> colon) 4 err
+loadHiBootInterface :: TcRn (Maybe ModIface)
+-- Load the hi-boot iface for the module being compiled,
+-- if it indeed exists in the transitive closure of imports
+loadHiBootInterface
+ = do { eps <- getEps
+ ; mod <- getModule
+
+ -- We're read all the direct imports by now, so eps_is_boot will
+ -- record if any of our imports mention us by way of hi-boot file
+ ; case lookupModuleEnv (eps_is_boot eps) mod of
+ Nothing -> return Nothing -- The typical case
+
+ Just (mod_nm, True) -> -- There's a hi-boot interface below us
+ -- Load it (into the PTE), and return its interface
+ do { iface <- loadSrcInterface (mk_doc mod_nm) mod_nm True
+ ; return (Just iface) }
+
+ Just (_, False) -> -- Someone below us imported us!
+ -- This is a loop with no hi-boot in the way
+ failWithTc (moduleLoop mod)
+ }
+ where
+ mk_doc mod = ptext SLIT("Need the hi-boot interface for") <+> ppr mod
+ <+> ptext SLIT("to compare against the Real Thing")
+
+ moduleLoop mod = ptext SLIT("Circular imports: module") <+> quotes (ppr mod)
+ <+> ptext SLIT("depends on itself")
+
loadOrphanModules :: [ModuleName] -> TcM ()
loadOrphanModules mods
| null mods = returnM ()
diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs
index 78a407f474..41d38dee9c 100644
--- a/ghc/compiler/main/HscTypes.lhs
+++ b/ghc/compiler/main/HscTypes.lhs
@@ -120,10 +120,13 @@ data HscEnv
-- are compiling right now.
-- (In one-shot mode the current module is the only
-- home-package module, so hsc_HPT is empty. All other
- -- modules count as "external-package" modules.)
+ -- modules count as "external-package" modules.
+ -- However, even in GHCi mode, hi-boot interfaces are
+ -- demand-loadeded into the external-package table.)
+ --
-- hsc_HPT is not mutable because we only demand-load
-- external packages; the home package is eagerly
- -- loaded by the compilation manager.
+ -- loaded, module by module, by the compilation manager.
-- The next two are side-effected by compiling
-- to reflect sucking in interface files
diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs
index 6e8c6be8a6..0f5ad41dd5 100644
--- a/ghc/compiler/rename/RnNames.lhs
+++ b/ghc/compiler/rename/RnNames.lhs
@@ -204,7 +204,7 @@ importsFromImportDecl this_mod
-- (a) remove this_mod (might be there as a hi-boot)
-- (b) add imp_mod itself
-- Take its dependent packages unchanged
- ((imp_mod_name, want_boot) : filter not_self (dep_mods deps), dep_pkgs deps)
+ ((imp_mod_name, want_boot) : dep_mods deps, dep_pkgs deps)
| otherwise
= -- Imported module is from another package
diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs
index f80fe86b18..1aa86dcd08 100644
--- a/ghc/compiler/typecheck/TcEnv.lhs
+++ b/ghc/compiler/typecheck/TcEnv.lhs
@@ -52,7 +52,7 @@ import TcMType ( zonkTcType, zonkTcTyVar, zonkTcTyVarsAndFV )
import TcType ( Type, TcKind, TcTyVar, TcTyVarSet,
tyVarsOfType, tyVarsOfTypes, tcSplitDFunTy, mkGenTyConApp,
getDFunTyKey, tcTyConAppTyCon,
- tidyOpenType, tidyOpenTyVar
+ tidyOpenType, tidyOpenTyVar, pprTyThingCategory
)
import qualified Type ( getTyVar_maybe )
import Id ( idName, isLocalId )
@@ -605,10 +605,7 @@ wrongThingErr expected thing name
= failWithTc (pp_thing thing <+> quotes (ppr name) <+>
ptext SLIT("used as a") <+> text expected)
where
- pp_thing (AGlobal (ATyCon _)) = ptext SLIT("Type constructor")
- pp_thing (AGlobal (AClass _)) = ptext SLIT("Class")
- pp_thing (AGlobal (AnId _)) = ptext SLIT("Identifier")
- pp_thing (AGlobal (ADataCon _)) = ptext SLIT("Data constructor")
- pp_thing (ATyVar _) = ptext SLIT("Type variable")
- pp_thing (ATcId _ _ _) = ptext SLIT("Local identifier")
+ pp_thing (AGlobal thing) = pprTyThingCategory thing
+ pp_thing (ATyVar _) = ptext SLIT("Type variable")
+ pp_thing (ATcId _ _ _) = ptext SLIT("Local identifier")
\end{code}
diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs
index dd6ed24495..42fd2498c9 100644
--- a/ghc/compiler/typecheck/TcExpr.lhs
+++ b/ghc/compiler/typecheck/TcExpr.lhs
@@ -22,7 +22,7 @@ import HsSyn ( HsExpr(..), LHsExpr, HsLit(..), ArithSeqInfo(..), recBindFields,
import TcHsSyn ( hsLitType, (<$>) )
import TcRnMonad
import TcUnify ( Expected(..), tcInfer, zapExpectedType, zapExpectedTo, tcSubExp, tcGen,
- unifyFunTys, zapToListTy, zapToTyConApp, readExpectedType )
+ unifyFunTys, zapToListTy, zapToTyConApp )
import BasicTypes ( isMarkedStrict )
import Inst ( InstOrigin(..),
newOverloadedLit, newMethodFromName, newIPDict,
diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs
index 30b70362da..cf4fad9280 100644
--- a/ghc/compiler/typecheck/TcHsSyn.lhs
+++ b/ghc/compiler/typecheck/TcHsSyn.lhs
@@ -36,10 +36,10 @@ import Id ( idType, setIdType, Id )
import TcRnMonad
import Type ( Type )
-import TcType ( TcType, TcTyVar, mkTyVarTy, tcGetTyVar, mkTyConApp, isImmutableTyVar )
+import TcType ( TcType, TcTyVar, mkTyVarTy, mkTyConApp, isImmutableTyVar )
import Kind ( isLiftedTypeKind, liftedTypeKind, isSubKind )
import qualified Type
-import TcMType ( zonkQuantifiedTyVar, zonkType, zonkTcType, zonkTcTyVars,
+import TcMType ( zonkQuantifiedTyVar, zonkType, zonkTcType,
putMetaTyVar )
import TysPrim ( charPrimTy, intPrimTy, floatPrimTy,
doublePrimTy, addrPrimTy
diff --git a/ghc/compiler/typecheck/TcMType.lhs b/ghc/compiler/typecheck/TcMType.lhs
index a444842855..45ab32e9ce 100644
--- a/ghc/compiler/typecheck/TcMType.lhs
+++ b/ghc/compiler/typecheck/TcMType.lhs
@@ -52,7 +52,7 @@ import TypeRep ( Type(..), PredType(..), TyNote(..), -- Friend; can see repres
import TcType ( TcType, TcThetaType, TcTauType, TcPredType,
TcTyVarSet, TcKind, TcTyVar, TcTyVarDetails(..),
MetaDetails(..), SkolemInfo(..), isMetaTyVar, metaTvRef,
- tcEqType, tcCmpPred, isClassPred,
+ tcCmpPred, isClassPred,
tcSplitPhiTy, tcSplitPredTy_maybe, tcSplitAppTy_maybe,
tcSplitTyConApp_maybe, tcSplitForAllTys,
tcIsTyVarTy, tcSplitSigmaTy, tcIsTyVarTy,
@@ -70,7 +70,7 @@ import Type ( TvSubst, zipTopTvSubst, substTy )
import Class ( Class, classArity, className )
import TyCon ( TyCon, isSynTyCon, isUnboxedTupleTyCon,
tyConArity, tyConName )
-import Var ( TyVar, tyVarKind, tyVarName, isTyVar,
+import Var ( TyVar, tyVarKind, tyVarName,
mkTyVar, mkTcTyVar, tcTyVarDetails, isTcTyVar )
-- others:
diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs
index f831b751e6..2f583bbefe 100644
--- a/ghc/compiler/typecheck/TcPat.lhs
+++ b/ghc/compiler/typecheck/TcPat.lhs
@@ -22,7 +22,7 @@ import Name ( Name )
import TcSimplify ( tcSimplifyCheck, bindInstsOfLocalFuns )
import TcEnv ( newLocalName, tcExtendIdEnv1, tcExtendTyVarEnv,
tcLookupClass, tcLookupDataCon, tcLookupId )
-import TcMType ( newTyFlexiVarTy, arityErr, tcSkolTyVars, isRigidType )
+import TcMType ( newTyFlexiVarTy, arityErr, tcSkolTyVars )
import TcType ( TcType, TcTyVar, TcSigmaType, TcTauType, zipTopTvSubst,
SkolemInfo(PatSkol), isSkolemTyVar, pprSkolemTyVar,
mkTyVarTys, mkClassPred, mkTyConApp, isOverloadedTy )
diff --git a/ghc/compiler/typecheck/TcRnDriver.lhs b/ghc/compiler/typecheck/TcRnDriver.lhs
index 89909357cb..53b707103e 100644
--- a/ghc/compiler/typecheck/TcRnDriver.lhs
+++ b/ghc/compiler/typecheck/TcRnDriver.lhs
@@ -33,7 +33,7 @@ import RdrName ( RdrName, mkRdrUnqual, emptyGlobalRdrEnv,
import TcHsSyn ( zonkTopDecls )
import TcExpr ( tcInferRho )
import TcRnMonad
-import TcType ( tidyTopType )
+import TcType ( tidyTopType, tcEqType, mkTyVarTys, substTyWith )
import Inst ( showLIE )
import TcBinds ( tcTopBinds )
import TcDefaults ( tcDefaults )
@@ -44,7 +44,8 @@ import TcInstDcls ( tcInstDecls1, tcInstDecls2 )
import TcIface ( tcExtCoreBindings )
import TcSimplify ( tcSimplifyTop )
import TcTyClsDecls ( tcTyAndClassDecls )
-import LoadIface ( loadOrphanModules )
+import LoadIface ( loadOrphanModules, loadHiBootInterface )
+import IfaceEnv ( lookupOrig )
import RnNames ( importsFromLocalDecls, rnImports, exportsFromAvail,
reportUnusedNames, reportDeprecations )
import RnEnv ( lookupSrcOcc_maybe )
@@ -58,15 +59,16 @@ import Module ( mkHomeModule, mkModuleName, moduleName, moduleEnvElts
import OccName ( mkVarOcc )
import Name ( Name, isExternalName, getSrcLoc, getOccName )
import NameSet
-import TyCon ( tyConHasGenerics )
+import TyCon ( tyConHasGenerics, isSynTyCon, getSynTyConDefn, tyConKind )
import SrcLoc ( srcLocSpan, Located(..), noLoc )
import Outputable
import HscTypes ( ModGuts(..), HscEnv(..), ExternalPackageState(..),
GhciMode(..), noDependencies, isOneShot,
- Deprecs( NoDeprecs ), plusDeprecs,
- ForeignStubs(NoStubs), TypeEnv,
+ Deprecs( NoDeprecs ), ModIface(..), plusDeprecs,
+ ForeignStubs(NoStubs), TyThing(..),
+ TypeEnv, lookupTypeEnv,
extendTypeEnvWithIds, typeEnvIds, typeEnvTyCons,
- emptyFixityEnv
+ emptyFixityEnv, availName
)
#ifdef GHCI
import HsSyn ( HsStmtContext(..), Stmt(..), HsExpr(..), HsBindGroup(..),
@@ -113,8 +115,8 @@ import PrelNames ( iNTERACTIVE, ioTyConName, printName, monadNames, itName, retu
import Module ( ModuleName, lookupModuleEnvByName )
import HscTypes ( InteractiveContext(..), ExternalPackageState( eps_PTE ),
HomeModInfo(..), typeEnvElts, typeEnvClasses,
- TyThing(..), availName, availNames, icPrintUnqual,
- ModIface(..), ModDetails(..), Dependencies(..) )
+ availNames, icPrintUnqual,
+ ModDetails(..), Dependencies(..) )
import BasicTypes ( RecFlag(..), Fixity )
import Bag ( unitBag )
import ListSetOps ( removeDups )
@@ -321,7 +323,9 @@ tcRnSrcDecls :: [LHsDecl RdrName] -> TcM TcGblEnv
-- Returns the variables free in the decls
-- Reason: solely to report unused imports and bindings
tcRnSrcDecls decls
- = do { -- Do all the declarations
+ = do { mb_boot_iface <- loadHiBootInterface ;
+
+ -- Do all the declarations
(tc_envs, lie) <- getLIE (tc_rn_src_decls decls) ;
-- tcSimplifyTop deals with constant or ambiguous InstIds.
@@ -348,6 +352,9 @@ tcRnSrcDecls decls
let { final_type_env = extendTypeEnvWithIds type_env bind_ids } ;
+ -- Compre the hi-boot iface (if any) with the real thing
+ checkHiBootIface final_type_env mb_boot_iface ;
+
-- Make the new type env available to stuff slurped from interface files
writeMutVar (tcg_type_env_var tcg_env) final_type_env ;
@@ -399,6 +406,75 @@ tc_rn_src_decls ds
}}}
\end{code}
+%************************************************************************
+%* *
+ Comparing the hi-boot interface with the real thing
+%* *
+%************************************************************************
+
+In both one-shot mode and GHCi mode, hi-boot interfaces are demand-loaded
+into the External Package Table. Once we've typechecked the body of the
+module, we want to compare what we've found (gathered in a TypeEnv) with
+the hi-boot stuff in the EPT. We do so here, using the export list of
+the hi-boot interface as our checklist.
+
+\begin{code}
+checkHiBootIface :: TypeEnv -> Maybe ModIface -> TcM ()
+-- Compare the hi-boot file for this module (if there is one)
+-- with the type environment we've just come up with
+checkHiBootIface env Nothing -- No hi-boot
+ = return ()
+
+checkHiBootIface env (Just iface)
+ = mapM_ (check_one env) exports
+ where
+ exports = [ (mod, availName avail) | (mod,avails) <- mi_exports iface,
+ avail <- avails]
+----------------
+check_one local_env (mod,occ)
+ = do { name <- lookupOrig mod occ
+ ; eps <- getEps
+
+ -- Look up the hi-boot one;
+ -- it should jolly well be there (else GHC bug)
+ ; case lookupTypeEnv (eps_PTE eps) name of {
+ Nothing -> pprPanic "checkHiBootIface" (ppr name) ;
+ Just boot_thing ->
+
+ -- Look it up in the local type env
+ -- It should be there, but it's a programmer error if not
+ case lookupTypeEnv local_env name of
+ Nothing -> addErrTc (missingBootThing boot_thing)
+ Just real_thing -> check_thing boot_thing real_thing
+ } }
+
+----------------
+check_thing (ATyCon boot_tc) (ATyCon real_tc)
+ | isSynTyCon boot_tc && isSynTyCon real_tc,
+ defn1 `tcEqType` substTyWith tvs2 (mkTyVarTys tvs1) defn2
+ = return ()
+
+ | tyConKind boot_tc == tyConKind real_tc
+ = return ()
+ where
+ (tvs1, defn1) = getSynTyConDefn boot_tc
+ (tvs2, defn2) = getSynTyConDefn boot_tc
+
+check_thing (AnId boot_id) (AnId real_id)
+ | idType boot_id `tcEqType` idType real_id
+ = return ()
+
+check_thing boot_thing real_thing -- Default case; failure
+ = addErrAt (srcLocSpan (getSrcLoc real_thing))
+ (bootMisMatch real_thing)
+
+----------------
+missingBootThing thing
+ = ppr thing <+> ptext SLIT("is defined in the hi-boot file, but not in the module")
+bootMisMatch thing
+ = ppr thing <+> ptext SLIT("has conflicting definitions in the module and its hi-boot file")
+\end{code}
+
%************************************************************************
%* *
diff --git a/ghc/compiler/typecheck/TcRnTypes.lhs b/ghc/compiler/typecheck/TcRnTypes.lhs
index f563331acc..ea10ccef80 100644
--- a/ghc/compiler/typecheck/TcRnTypes.lhs
+++ b/ghc/compiler/typecheck/TcRnTypes.lhs
@@ -111,14 +111,14 @@ type TcM a = TcRn a -- Historical
data Env gbl lcl -- Changes as we move into an expression
= Env {
env_top :: HscEnv, -- Top-level stuff that never changes
- -- Includes all info about imported things
+ -- Includes all info about imported things
env_us :: TcRef UniqSupply, -- Unique supply for local varibles
env_gbl :: gbl, -- Info about things defined at the top level
- -- of the module being compiled
+ -- of the module being compiled
- env_lcl :: lcl -- Nested stuff -- changes as we go into
+ env_lcl :: lcl -- Nested stuff; changes as we go into
-- an expression
}
diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs
index a0d019a48a..7dd0a2ed1b 100644
--- a/ghc/compiler/typecheck/TcTyDecls.lhs
+++ b/ghc/compiler/typecheck/TcTyDecls.lhs
@@ -47,6 +47,13 @@ import Outputable
%* *
%************************************************************************
+Checking for class-decl loops is easy, because we don't allow class decls
+in interface files.
+
+We allow type synonyms in hi-boot files, but we *trust* hi-boot files,
+so we don't check for loops that involve them. So we only look for synonym
+loops in the module being compiled.
+
We check for type synonym and class cycles on the *source* code.
Main reasons:
@@ -64,8 +71,9 @@ Main reasons:
The main disadvantage is that a cycle that goes via a type synonym in an
.hi-boot file can lead the compiler into a loop, because it assumes that cycles
-only occur in source code. But hi-boot files are trusted anyway, so this isn't
-much worse than (say) a kind error.
+only occur entirely within the source code of the module being compiled.
+But hi-boot files are trusted anyway, so this isn't much worse than (say)
+a kind error.
[ NOTE ----------------------------------------------
If we reverse this decision, this comment came from tcTyDecl1, and should
@@ -136,6 +144,14 @@ calcClassCycles decls
%* *
%************************************************************************
+For newtypes, we label some as "recursive" such that
+
+ INVARIANT: there is no cycle of non-recursive newtypes
+
+In any loop, only one newtype need be marked as recursive; it is
+a "loop breaker". Labelling more than necessary as recursive is OK,
+provided the invariant is maintained.
+
A newtype M.T is defined to be "recursive" iff
(a) its rhs mentions an abstract (hi-boot) TyCon
or (b) one can get from T's rhs to T via type
@@ -163,7 +179,7 @@ back to it. (This is an error too.)
Hi-boot types
~~~~~~~~~~~~~
-A data type read from an hi-boot file will have an Unknown in its data constructors,
+A data type read from an hi-boot file will have an AbstractTyCon as its AlgTyConRhs
and will respond True to isHiBootTyCon. The idea is that we treat these as if one
could get from these types to anywhere. So when we see
diff --git a/ghc/compiler/typecheck/TcType.lhs b/ghc/compiler/typecheck/TcType.lhs
index e1bfedbf1a..a53daf52fd 100644
--- a/ghc/compiler/typecheck/TcType.lhs
+++ b/ghc/compiler/typecheck/TcType.lhs
@@ -110,7 +110,7 @@ module TcType (
tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta,
pprKind, pprParendKind,
- pprType, pprParendType,
+ pprType, pprParendType, pprTyThingCategory,
pprPred, pprTheta, pprThetaArrow, pprClassPred
) where
@@ -150,7 +150,7 @@ import Type ( -- Re-exports
typeKind, repType,
pprKind, pprParendKind,
- pprType, pprParendType,
+ pprType, pprParendType, pprTyThingCategory,
pprPred, pprTheta, pprThetaArrow, pprClassPred
)
import TyCon ( TyCon, isUnLiftedTyCon, tyConUnique )
diff --git a/ghc/compiler/typecheck/TcUnify.lhs b/ghc/compiler/typecheck/TcUnify.lhs
index 3163802fff..07b4043697 100644
--- a/ghc/compiler/typecheck/TcUnify.lhs
+++ b/ghc/compiler/typecheck/TcUnify.lhs
@@ -65,7 +65,7 @@ import Name ( isSystemName, mkSysTvName )
import ErrUtils ( Message )
import SrcLoc ( noLoc )
import BasicTypes ( Arity )
-import Util ( equalLength, notNull )
+import Util ( notNull )
import Outputable
\end{code}
diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs
index ab9f4519e5..dfb72d354d 100644
--- a/ghc/compiler/types/Type.lhs
+++ b/ghc/compiler/types/Type.lhs
@@ -73,7 +73,7 @@ module Type (
deShadowTy,
-- Pretty-printing
- pprType, pprParendType,
+ pprType, pprParendType, pprTyThingCategory,
pprPred, pprTheta, pprThetaArrow, pprClassPred
) where
diff --git a/ghc/compiler/types/TypeRep.lhs b/ghc/compiler/types/TypeRep.lhs
index 287c2be5c5..5c4bd3315a 100644
--- a/ghc/compiler/types/TypeRep.lhs
+++ b/ghc/compiler/types/TypeRep.lhs
@@ -14,7 +14,7 @@ module TypeRep (
funTyCon,
-- Pretty-printing
- pprType, pprParendType,
+ pprType, pprParendType, pprTyThingCategory,
pprPred, pprTheta, pprThetaArrow, pprClassPred,
-- Re-export fromKind
@@ -251,10 +251,13 @@ data TyThing = AnId Id
| AClass Class
instance Outputable TyThing where
- ppr (AnId id) = ptext SLIT("AnId") <+> ppr id
- ppr (ATyCon tc) = ptext SLIT("ATyCon") <+> ppr tc
- ppr (AClass cl) = ptext SLIT("AClass") <+> ppr cl
- ppr (ADataCon dc) = ptext SLIT("ADataCon") <+> ppr (dataConName dc)
+ ppr thing = pprTyThingCategory thing <+> quotes (ppr (getName thing))
+
+pprTyThingCategory :: TyThing -> SDoc
+pprTyThingCategory (ATyCon _) = ptext SLIT("Type constructor")
+pprTyThingCategory (AClass _) = ptext SLIT("Class")
+pprTyThingCategory (AnId _) = ptext SLIT("Identifier")
+pprTyThingCategory (ADataCon _) = ptext SLIT("Data constructor")
instance NamedThing TyThing where -- Can't put this with the type
getName (AnId id) = getName id -- decl, because the DataCon instance
View Lorry Controller Status