Commit 4e325538 authored by simonpj's avatar simonpj
Browse files

[project @ 2004-08-16 09:53:47 by simonpj]

-------------------------------
	Add instance information to :i
 	Get rid of the DeclPool
	-------------------------------


1.  Add instance information to :info command.  GHCi now prints out
    which instances a type or class belongs to, when you use :i

2.  Tidy up printing of unqualified names in user output.
    Previously Outputable.PrintUnqualified was
	type PrintUnqualified = Name -> Bool
    but it's now
	type PrintUnqualified = ModuleName -> OccName -> Bool
    This turns out to be tidier even for Names, and it's now also usable
    when printing IfaceSyn stuff in GHCi, eliminating a grevious hack.

3.  On the way to doing this, Simon M had the great idea that we could
    get rid of the DeclPool holding pen, which held declarations read from
    interface files but not yet type-checked.   We do this by eagerly
    populating the TypeEnv with thunks what, when poked, do the type
    checking.   This is just a logical continuation of lazy import
    mechanism we've now had for some while.

The InstPool and RulePool still exist, but I plan to get rid of them in
the same way.  The new scheme does mean that more rules get sucked in than
before, because previously the TypeEnv was used to mean "this thing was needed"
and hence to control which rules were sucked in.  But now the TypeEnv is
populated more eagerly => more rules get sucked in.  However this problem
will go away when I get rid of the Inst and Rule pools.

I should have kept these changes separate, but I didn't.  Change (1)
affects mainly
	TcRnDriver, HscMain, CompMan, InteractiveUI
whereas change (3) is more wide ranging.
parent d32c5227
......@@ -86,7 +86,7 @@ Each data constructor C has two, and possibly three, Names associated with it:
---------------------------------------------------------------------------
* The "source data con" C DataName The DataCon itself
* The "real data con" C VarName Its worker Id
* The "wrapper data con" $wC VarName Wrapper Id (optional)
* The "wrapper data con" $WC VarName Wrapper Id (optional)
Each of these three has a distinct Unique. The "source data con" name
appears in the output of the renamer, and names the Haskell-source
......
......@@ -300,17 +300,17 @@ instance Outputable Name where
instance OutputableBndr Name where
pprBndr _ name = pprName name
pprName name@(Name {n_sort = sort, n_uniq = uniq, n_occ = occ})
pprName (Name {n_sort = sort, n_uniq = uniq, n_occ = occ})
= getPprStyle $ \ sty ->
case sort of
External mod mb_p -> pprExternal sty name uniq mod occ mb_p False
WiredIn mod mb_p thing -> pprExternal sty name uniq mod occ mb_p True
External mod mb_p -> pprExternal sty uniq mod occ mb_p False
WiredIn mod mb_p thing -> pprExternal sty uniq mod occ mb_p True
System -> pprSystem sty uniq occ
Internal -> pprInternal sty uniq occ
pprExternal sty name uniq mod occ mb_p is_wired
| codeStyle sty = ppr (moduleName mod) <> char '_' <> pprOccName occ
| debugStyle sty = sep [ppr (moduleName mod) <> dot <> pprOccName occ,
pprExternal sty uniq mod occ mb_p is_wired
| codeStyle sty = ppr mod_name <> char '_' <> pprOccName occ
| debugStyle sty = sep [ppr mod_name <> dot <> pprOccName occ,
hsep [text "{-"
, if is_wired then ptext SLIT("(w)") else empty
, pprUnique uniq
......@@ -318,8 +318,10 @@ pprExternal sty name uniq mod occ mb_p is_wired
-- Nothing -> empty
-- Just n -> brackets (ppr n)
, text "-}"]]
| unqualStyle sty name = pprOccName occ
| otherwise = ppr (moduleName mod) <> dot <> pprOccName occ
| unqualStyle sty mod_name occ = pprOccName occ
| otherwise = ppr mod_name <> dot <> pprOccName occ
where
mod_name = moduleName mod
pprInternal sty uniq occ
| codeStyle sty = pprUnique uniq
......
......@@ -7,7 +7,7 @@
module NameEnv (
NameEnv, mkNameEnv,
emptyNameEnv, unitNameEnv, nameEnvElts,
extendNameEnv_C, extendNameEnv, extendNameEnvList,
extendNameEnv_C, extendNameEnvList_C, extendNameEnv, extendNameEnvList,
foldNameEnv, filterNameEnv,
plusNameEnv, plusNameEnv_C,
lookupNameEnv, lookupNameEnv_NF, delFromNameEnv, delListFromNameEnv,
......@@ -30,37 +30,39 @@ import Maybes ( expectJust )
\begin{code}
type NameEnv a = UniqFM a -- Domain is Name
emptyNameEnv :: NameEnv a
mkNameEnv :: [(Name,a)] -> NameEnv a
nameEnvElts :: NameEnv a -> [a]
extendNameEnv_C :: (a->a->a) -> NameEnv a -> Name -> a -> NameEnv a
extendNameEnv :: NameEnv a -> Name -> a -> NameEnv a
plusNameEnv :: NameEnv a -> NameEnv a -> NameEnv a
plusNameEnv_C :: (a->a->a) -> NameEnv a -> NameEnv a -> NameEnv a
extendNameEnvList:: NameEnv a -> [(Name,a)] -> NameEnv a
delFromNameEnv :: NameEnv a -> Name -> NameEnv a
emptyNameEnv :: NameEnv a
mkNameEnv :: [(Name,a)] -> NameEnv a
nameEnvElts :: NameEnv a -> [a]
extendNameEnv_C :: (a->a->a) -> NameEnv a -> Name -> a -> NameEnv a
extendNameEnvList_C:: (a->a->a) -> NameEnv a -> [(Name,a)] -> NameEnv a
extendNameEnv :: NameEnv a -> Name -> a -> NameEnv a
plusNameEnv :: NameEnv a -> NameEnv a -> NameEnv a
plusNameEnv_C :: (a->a->a) -> NameEnv a -> NameEnv a -> NameEnv a
extendNameEnvList :: NameEnv a -> [(Name,a)] -> NameEnv a
delFromNameEnv :: NameEnv a -> Name -> NameEnv a
delListFromNameEnv :: NameEnv a -> [Name] -> NameEnv a
elemNameEnv :: Name -> NameEnv a -> Bool
unitNameEnv :: Name -> a -> NameEnv a
lookupNameEnv :: NameEnv a -> Name -> Maybe a
lookupNameEnv_NF :: NameEnv a -> Name -> a
foldNameEnv :: (a -> b -> b) -> b -> NameEnv a -> b
filterNameEnv :: (elt -> Bool) -> NameEnv elt -> NameEnv elt
elemNameEnv :: Name -> NameEnv a -> Bool
unitNameEnv :: Name -> a -> NameEnv a
lookupNameEnv :: NameEnv a -> Name -> Maybe a
lookupNameEnv_NF :: NameEnv a -> Name -> a
foldNameEnv :: (a -> b -> b) -> b -> NameEnv a -> b
filterNameEnv :: (elt -> Bool) -> NameEnv elt -> NameEnv elt
emptyNameEnv = emptyUFM
foldNameEnv = foldUFM
mkNameEnv = listToUFM
nameEnvElts = eltsUFM
extendNameEnv_C = addToUFM_C
extendNameEnv = addToUFM
plusNameEnv = plusUFM
plusNameEnv_C = plusUFM_C
extendNameEnvList= addListToUFM
delFromNameEnv = delFromUFM
delListFromNameEnv = delListFromUFM
elemNameEnv = elemUFM
unitNameEnv = unitUFM
filterNameEnv = filterUFM
emptyNameEnv = emptyUFM
foldNameEnv = foldUFM
mkNameEnv = listToUFM
nameEnvElts = eltsUFM
extendNameEnv_C = addToUFM_C
extendNameEnvList_C = addListToUFM_C
extendNameEnv = addToUFM
plusNameEnv = plusUFM
plusNameEnv_C = plusUFM_C
extendNameEnvList = addListToUFM
delFromNameEnv = delFromUFM
delListFromNameEnv = delListFromUFM
elemNameEnv = elemUFM
unitNameEnv = unitUFM
filterNameEnv = filterUFM
lookupNameEnv = lookupUFM
lookupNameEnv_NF env n = expectJust "lookupNameEnv_NF" (lookupUFM env n)
......
......@@ -24,7 +24,8 @@ module CompManager (
cmSetContext, -- :: CmState -> DynFlags -> [String] -> [String] -> IO CmState
cmGetContext, -- :: CmState -> IO ([String],[String])
cmInfoThing, -- :: CmState -> String -> IO (CmState, [(TyThing,Fixity)])
cmGetInfo, -- :: CmState -> String -> IO (CmState, [(TyThing,Fixity)])
GetInfoResult,
cmBrowseModule, -- :: CmState -> IO [TyThing]
CmRunResult(..),
......@@ -81,9 +82,9 @@ import Maybes ( expectJust, orElse, mapCatMaybes )
import DATA_IOREF ( readIORef )
#ifdef GHCI
import HscMain ( hscThing, hscStmt, hscTcExpr, hscKcType )
import HscMain ( hscGetInfo, GetInfoResult, hscStmt, hscTcExpr, hscKcType )
import TcRnDriver ( mkExportEnv, getModuleContents )
import IfaceSyn ( IfaceDecl )
import IfaceSyn ( IfaceDecl, IfaceInst )
import RdrName ( GlobalRdrEnv, plusGlobalRdrEnv )
import Name ( Name )
import NameEnv
......@@ -187,7 +188,7 @@ cmSetContext cmstate toplevs exports = do
let all_env = foldr plusGlobalRdrEnv export_env toplev_envs
return cmstate{ cm_ic = old_ic { ic_toplev_scope = toplevs,
ic_exports = exports,
ic_exports = exports,
ic_rn_gbl_env = all_env } }
mkTopLevEnv :: HomePackageTable -> String -> IO GlobalRdrEnv
......@@ -219,9 +220,8 @@ cmSetDFlags cm_state dflags
-- A string may refer to more than one TyThing (eg. a constructor,
-- and type constructor), so we return a list of all the possible TyThings.
cmInfoThing :: CmState -> String -> IO [(IfaceDecl,Fixity,SrcLoc)]
cmInfoThing cmstate id
= hscThing (cm_hsc cmstate) (cm_ic cmstate) id
cmGetInfo :: CmState -> String -> IO [GetInfoResult]
cmGetInfo cmstate id = hscGetInfo (cm_hsc cmstate) (cm_ic cmstate) id
-- ---------------------------------------------------------------------------
-- cmBrowseModule: get all the TyThings defined in a module
......
......@@ -73,8 +73,7 @@ deSugar hsc_env
= do { showPass dflags "Desugar"
-- Do desugaring
; let { is_boot = imp_dep_mods imports }
; (results, warnings) <- initDs hsc_env mod type_env is_boot $
; (results, warnings) <- initDs hsc_env mod type_env $
dsProgram ghci_mode tcg_env
; let { (ds_binds, ds_rules, ds_fords) = results
......@@ -145,9 +144,7 @@ deSugarExpr hsc_env this_mod rdr_env type_env tc_expr
; us <- mkSplitUniqSupply 'd'
-- Do desugaring
; let { is_boot = emptyModuleEnv } -- Assume no hi-boot files when
-- doing stuff from the command line
; (core_expr, ds_warns) <- initDs hsc_env this_mod type_env is_boot $
; (core_expr, ds_warns) <- initDs hsc_env this_mod type_env $
dsLExpr tc_expr
-- Display any warnings
......
......@@ -29,7 +29,7 @@ module DsMonad (
import TcRnMonad
import HsSyn ( HsExpr, HsMatchContext, Pat )
import IfaceEnv ( tcIfaceGlobal )
import TcIface ( tcIfaceGlobal )
import HscTypes ( TyThing(..), TypeEnv, HscEnv,
IsBootInterface,
tyThingId, tyThingTyCon, tyThingDataCon )
......@@ -102,14 +102,12 @@ data DsMetaVal
initDs :: HscEnv
-> Module -> TypeEnv
-> ModuleEnv (ModuleName,IsBootInterface)
-> DsM a
-> IO (a, Bag DsWarning)
initDs hsc_env mod type_env is_boot thing_inside
initDs hsc_env mod type_env thing_inside
= do { warn_var <- newIORef emptyBag
; let { if_env = IfGblEnv { if_rec_types = Just (mod, return type_env),
if_is_boot = is_boot }
; let { if_env = IfGblEnv { if_rec_types = Just (mod, return type_env) }
; gbl_env = DsGblEnv { ds_mod = mod,
ds_if_env = if_env,
ds_warns = warn_var }
......
{-# OPTIONS -#include "Linker.h" #-}
-----------------------------------------------------------------------------
-- $Id: InteractiveUI.hs,v 1.173 2004/08/13 13:06:42 simonmar Exp $
-- $Id: InteractiveUI.hs,v 1.174 2004/08/16 09:53:57 simonpj Exp $
--
-- GHC Interactive User Interface
--
......@@ -19,7 +19,7 @@ import CompManager
import HscTypes ( TyThing(..), HomeModInfo(hm_linkable), HomePackageTable,
isObjectLinkable, GhciMode(..) )
import IfaceSyn ( IfaceType, IfaceDecl(..), IfaceClassOp(..), IfaceConDecls(..), IfaceConDecl(..),
pprIfaceDeclHead, pprParendIfaceType, pprIfaceForAllPart )
IfaceInst(..), pprIfaceDeclHead, pprParendIfaceType, pprIfaceForAllPart )
import FunDeps ( pprFundeps )
import DriverFlags
import DriverState
......@@ -478,23 +478,32 @@ info s = do { let names = words s
; mapM_ (infoThing init_cms) names }
where
infoThing cms name
= do { stuff <- io (cmInfoThing cms name)
= do { stuff <- io (cmGetInfo cms name)
; io (putStrLn (showSDocForUser (cmGetPrintUnqual cms) $
vcat (intersperse (text "") (map (showThing name) stuff)))) }
showThing :: String -> (IfaceDecl, Fixity, SrcLoc) -> SDoc
showThing name (thing, fixity, src_loc)
= vcat [ showDecl (\occ -> name == occNameUserString occ) thing,
showFixity fixity,
text "-- " <> showLoc src_loc]
vcat (intersperse (text "") (map showThing stuff)))) }
showThing :: GetInfoResult -> SDoc
showThing (wanted_str, (thing, fixity, src_loc, insts))
= vcat [ showDecl want_name thing,
show_fixity fixity,
show_loc src_loc,
vcat (map show_inst insts)]
where
showFixity fix
want_name occ = wanted_str == occNameUserString occ
show_fixity fix
| fix == defaultFixity = empty
| otherwise = ppr fix <+> text name
| otherwise = ppr fix <+> text wanted_str
show_loc loc -- The ppr function for SrcLocs is a bit wonky
| isGoodSrcLoc loc = comment <+> ptext SLIT("Defined at") <+> ppr loc
| otherwise = comment <+> ppr loc
comment = ptext SLIT("--")
showLoc loc -- The ppr function for SrcLocs is a bit wonky
| isGoodSrcLoc loc = ptext SLIT("Defined at") <+> ppr loc
| otherwise = ppr loc
show_inst (iface_inst, loc)
= hang (ptext SLIT("instance") <+> ppr (ifInstHead iface_inst))
2 (char '\t' <> show_loc loc)
-- The tab tries to make them line up a bit
-- Now there is rather a lot of goop just to print declarations in a
-- civilised way with "..." for the parts we are less interested in.
......
......@@ -7,8 +7,7 @@ module IfaceEnv (
lookupOrig, lookupIfaceTc,
newIfaceName, newIfaceNames,
extendIfaceIdEnv, extendIfaceTyVarEnv,
tcIfaceGlobal, tcIfaceTyCon, tcIfaceClass, tcIfaceExtId,
tcIfaceTyVar, tcIfaceDataCon, tcIfaceLclId,
tcIfaceLclId, tcIfaceTyVar,
-- Name-cache stuff
allocateGlobalBinder, initNameCache
......@@ -16,28 +15,24 @@ module IfaceEnv (
#include "HsVersions.h"
import {-# SOURCE #-} TcIface( tcImportDecl )
import TcRnMonad
import IfaceType ( IfaceExtName(..), IfaceTyCon(..), ifaceTyConName )
import TysWiredIn ( tupleTyCon, tupleCon )
import HscTypes ( NameCache(..), HscEnv(..),
TyThing, tyThingClass, tyThingTyCon,
ExternalPackageState(..), OrigNameCache, lookupType )
TyThing, ExternalPackageState(..), OrigNameCache )
import TyCon ( TyCon, tyConName )
import Class ( Class )
import DataCon ( DataCon, dataConWorkId, dataConName )
import DataCon ( dataConWorkId, dataConName )
import Var ( TyVar, Id, varName )
import Name ( Name, nameUnique, nameModule,
nameOccName, nameSrcLoc,
getOccName, nameParent_maybe,
isWiredInName, nameIsLocalOrFrom, mkIPName,
isWiredInName, mkIPName,
mkExternalName, mkInternalName )
import NameEnv
import OccName ( OccName, isTupleOcc_maybe, tcName, dataName,
lookupOccEnv, unitOccEnv, extendOccEnv, extendOccEnvList )
import PrelNames ( gHC_PRIM_Name, pREL_TUP_Name )
import TysWiredIn ( intTyCon, boolTyCon, charTyCon, listTyCon, parrTyCon,
tupleTyCon, tupleCon )
import HscTypes ( ExternalPackageState, NameCache, TyThing(..) )
import Module ( Module, ModuleName, moduleName, mkPackageModule,
emptyModuleEnv, lookupModuleEnvByName, extendModuleEnv_C )
......@@ -250,67 +245,14 @@ initOrigNames names = foldl extendOrigNameCache emptyModuleEnv names
\end{code}
%************************************************************************
%* *
Getting from Names to TyThings
Type variables and local Ids
%* *
%************************************************************************
\begin{code}
tcIfaceGlobal :: Name -> IfM a TyThing
tcIfaceGlobal name
= do { (eps,hpt) <- getEpsAndHpt
; case lookupType hpt (eps_PTE eps) name of {
Just thing -> return thing ;
Nothing ->
setLclEnv () $ do -- This gets us back to IfG, mainly to
-- pacify get_type_env; rather untidy
{ env <- getGblEnv
; case if_rec_types env of
Just (mod, get_type_env)
| nameIsLocalOrFrom mod name
-> do -- It's defined in the module being compiled
{ type_env <- get_type_env
; case lookupNameEnv type_env name of
Just thing -> return thing
Nothing -> pprPanic "tcIfaceGlobal (local): not found:"
(ppr name $$ ppr type_env) }
other -> tcImportDecl name -- It's imported; go get it
}}}
tcIfaceTyCon :: IfaceTyCon -> IfL TyCon
tcIfaceTyCon IfaceIntTc = return intTyCon
tcIfaceTyCon IfaceBoolTc = return boolTyCon
tcIfaceTyCon IfaceCharTc = return charTyCon
tcIfaceTyCon IfaceListTc = return listTyCon
tcIfaceTyCon IfacePArrTc = return parrTyCon
tcIfaceTyCon (IfaceTupTc bx ar) = return (tupleTyCon bx ar)
tcIfaceTyCon (IfaceTc ext_nm) = do { name <- lookupIfaceExt ext_nm
; thing <- tcIfaceGlobal name
; return (tyThingTyCon thing) }
tcIfaceClass :: IfaceExtName -> IfL Class
tcIfaceClass rdr_name = do { name <- lookupIfaceExt rdr_name
; thing <- tcIfaceGlobal name
; return (tyThingClass thing) }
tcIfaceDataCon :: IfaceExtName -> IfL DataCon
tcIfaceDataCon gbl = do { name <- lookupIfaceExt gbl
; thing <- tcIfaceGlobal name
; case thing of
ADataCon dc -> return dc
other -> pprPanic "tcIfaceExtDC" (ppr gbl $$ ppr name$$ ppr thing) }
tcIfaceExtId :: IfaceExtName -> IfL Id
tcIfaceExtId gbl = do { name <- lookupIfaceExt gbl
; thing <- tcIfaceGlobal name
; case thing of
AnId id -> return id
other -> pprPanic "tcIfaceExtId" (ppr gbl $$ ppr name$$ ppr thing) }
------------------------------------------
tcIfaceLclId :: OccName -> IfL Id
tcIfaceLclId occ
= do { lcl <- getLclEnv
......@@ -318,13 +260,6 @@ tcIfaceLclId occ
`orElse`
pprPanic "tcIfaceLclId" (ppr occ)) }
tcIfaceTyVar :: OccName -> IfL TyVar
tcIfaceTyVar occ
= do { lcl <- getLclEnv
; return (lookupOccEnv (if_tv_env lcl) occ
`orElse`
pprPanic "tcIfaceTyVar" (ppr occ)) }
extendIfaceIdEnv :: [Id] -> IfL a -> IfL a
extendIfaceIdEnv ids thing_inside
= do { env <- getLclEnv
......@@ -332,6 +267,14 @@ extendIfaceIdEnv ids thing_inside
; pairs = [(getOccName id, id) | id <- ids] }
; setLclEnv (env { if_id_env = id_env' }) thing_inside }
tcIfaceTyVar :: OccName -> IfL TyVar
tcIfaceTyVar occ
= do { lcl <- getLclEnv
; return (lookupOccEnv (if_tv_env lcl) occ
`orElse`
pprPanic "tcIfaceTyVar" (ppr occ)) }
extendIfaceTyVarEnv :: [TyVar] -> IfL a -> IfL a
extendIfaceTyVarEnv tyvars thing_inside
= do { env <- getLclEnv
......
......@@ -514,11 +514,13 @@ tyThingToIfaceDecl dis abstr ext (ADataCon dc)
--------------------------
dfunToIfaceInst :: ModuleName -> DFunId -> IfaceInst
dfunToIfaceInst mod dfun_id
= IfaceInst { ifDFun = getOccName dfun_id,
dfunToIfaceInst :: DFunId -> IfaceInst
dfunToIfaceInst dfun_id
= IfaceInst { ifDFun = nameOccName dfun_name,
ifInstHead = toIfaceType (mkLhsNameFn mod) tidy_ty }
where
dfun_name = idName dfun_id
mod = nameModuleName dfun_name
(tvs, _, cls, tys) = tcSplitDFunTy (idType dfun_id)
head_ty = mkForAllTys tvs (mkPredTy (mkClassPred cls tys))
-- No need to record the instance context;
......
......@@ -18,7 +18,6 @@ module IfaceType (
-- Printing
pprIfaceType, pprParendIfaceType, pprIfaceContext,
pprIfaceIdBndr, pprIfaceTvBndr, pprIfaceTvBndrs, pprIfaceBndrs,
getIfaceExt,
tOP_PREC, tYCON_PREC, noParens, maybeParen, pprIfaceForAllPart
) where
......@@ -86,10 +85,10 @@ type IfaceTvBndr = (OccName, IfaceKind)
type IfaceKind = Kind -- Re-use the Kind type, but no KindVars in it
data IfaceType
= IfaceTyVar OccName -- Type variable only, not tycon
= IfaceTyVar OccName -- Type variable only, not tycon
| IfaceAppTy IfaceType IfaceType
| IfaceForAllTy IfaceTvBndr IfaceType
| IfacePredTy IfacePredType
| IfacePredTy IfacePredType
| IfaceTyConApp IfaceTyCon [IfaceType] -- Not necessarily saturated
-- Includes newtypes, synonyms, tuples
| IfaceFunTy IfaceType IfaceType
......@@ -175,28 +174,21 @@ maybeParen ctxt_prec inner_prec pretty
----------------------------- Printing binders ------------------------------------
\begin{code}
-- These instances are used only when printing for the user, either when
-- debugging, or in GHCi when printing the results of a :info command
instance Outputable IfaceExtName where
ppr (ExtPkg mod occ) = ppr mod <> dot <> ppr occ
ppr (HomePkg mod occ vers) = ppr mod <> dot <> ppr occ <> braces (ppr vers)
ppr (ExtPkg mod occ) = pprExt mod occ
ppr (HomePkg mod occ vers) = pprExt mod occ <> braces (ppr vers)
ppr (LocalTop occ) = ppr occ -- Do we want to distinguish these
ppr (LocalTopSub occ _) = ppr occ -- from an ordinary occurrence?
getIfaceExt :: ((Name -> IfaceExtName) -> SDoc) -> SDoc
-- Uses the print-unqual info from the SDoc to make an 'ext'
-- which in turn tells toIfaceType when to make a qualified name
-- This is only used when making Iface stuff to print out for the user;
-- e.g. we use this in pprType
getIfaceExt thing_inside
= getPprStyle $ \ sty ->
let
ext nm | unqualStyle sty nm = LocalTop (nameOccName nm)
| isInternalName nm = LocalTop (nameOccName nm)
-- This only happens for Kind constructors, which
-- don't come from any particular module and are unqualified
-- This hack will go away when kinds are separated from types
| otherwise = ExtPkg (nameModuleName nm) (nameOccName nm)
in
thing_inside ext
pprExt :: ModuleName -> OccName -> SDoc
pprExt mod occ
= getPprStyle $ \ sty ->
if unqualStyle sty mod occ then
ppr occ
else
ppr mod <> dot <> ppr occ
instance Outputable IfaceBndr where
ppr (IfaceIdBndr bndr) = pprIfaceIdBndr bndr
......@@ -220,36 +212,42 @@ pprIfaceTvBndrs tyvars = hsep (map pprIfaceTvBndr tyvars)
\begin{code}
---------------------------------
instance Outputable IfaceType where
ppr ty = ppr_ty ty
ppr ty = pprIfaceTypeForUser ty
ppr_ty = pprIfaceType tOP_PREC
pprParendIfaceType = pprIfaceType tYCON_PREC
pprIfaceTypeForUser ::IfaceType -> SDoc
-- Drop top-level for-alls; if that's not what you want, use pprIfaceType dire
pprIfaceTypeForUser ty
= pprIfaceForAllPart [] theta (pprIfaceType tau)
where
(_tvs, theta, tau) = splitIfaceSigmaTy ty
pprIfaceType :: Int -> IfaceType -> SDoc
pprIfaceType, pprParendIfaceType ::IfaceType -> SDoc
pprIfaceType = ppr_ty tOP_PREC
pprParendIfaceType = ppr_ty tYCON_PREC
-- Simple cases
pprIfaceType ctxt_prec (IfaceTyVar tyvar) = ppr tyvar
pprIfaceType ctxt_prec (IfaceTyConApp tc tys) = ppr_tc_app ctxt_prec tc tys
pprIfaceType ctxt_prec (IfacePredTy st) = braces (ppr st)
ppr_ty :: Int -> IfaceType -> SDoc
ppr_ty ctxt_prec (IfaceTyVar tyvar) = ppr tyvar
ppr_ty ctxt_prec (IfaceTyConApp tc tys) = ppr_tc_app ctxt_prec tc tys
ppr_ty ctxt_prec (IfacePredTy st) = ppr st
-- Function types
pprIfaceType ctxt_prec (IfaceFunTy ty1 ty2)
ppr_ty ctxt_prec (IfaceFunTy ty1 ty2)
= -- We don't want to lose synonyms, so we mustn't use splitFunTys here.
maybeParen ctxt_prec fUN_PREC $
sep (pprIfaceType fUN_PREC ty1 : ppr_fun_tail ty2)
sep (ppr_ty fUN_PREC ty1 : ppr_fun_tail ty2)
where
ppr_fun_tail (IfaceFunTy ty1 ty2)
= (arrow <+> pprIfaceType fUN_PREC ty1) : ppr_fun_tail ty2
= (arrow <+> ppr_ty fUN_PREC ty1) : ppr_fun_tail ty2
ppr_fun_tail other_ty
= [arrow <+> ppr_ty other_ty]
= [arrow <+> pprIfaceType other_ty]
pprIfaceType ctxt_prec (IfaceAppTy ty1 ty2)
ppr_ty ctxt_prec (IfaceAppTy ty1 ty2)
= maybeParen ctxt_prec tYCON_PREC $
pprIfaceType fUN_PREC ty1 <+> pprParendIfaceType ty2
ppr_ty fUN_PREC ty1 <+> pprParendIfaceType ty2
pprIfaceType ctxt_prec ty@(IfaceForAllTy _ _)
= maybeParen ctxt_prec fUN_PREC (pprIfaceForAllPart tvs theta (ppr_ty tau))
ppr_ty ctxt_prec ty@(IfaceForAllTy _ _)
= maybeParen ctxt_prec fUN_PREC (pprIfaceForAllPart tvs theta (pprIfaceType tau))
where
(tvs, theta, tau) = splitIfaceSigmaTy ty
......@@ -263,11 +261,11 @@ pprIfaceForAllPart tvs ctxt doc
-------------------
ppr_tc_app ctxt_prec tc [] = ppr tc
ppr_tc_app ctxt_prec IfaceListTc [ty] = brackets (ppr_ty ty)
ppr_tc_app ctxt_prec IfacePArrTc [ty] = pabrackets (ppr_ty ty)
ppr_tc_app ctxt_prec IfaceListTc [ty] = brackets (pprIfaceType ty)
ppr_tc_app ctxt_prec IfacePArrTc [ty] = pabrackets (pprIfaceType ty)
ppr_tc_app ctxt_prec (IfaceTupTc bx arity) tys
| arity == length tys
= tupleParens bx (sep (punctuate comma (map ppr_ty tys)))
= tupleParens bx (sep (punctuate comma (map pprIfaceType tys)))
ppr_tc_app ctxt_prec tc tys
= maybeParen ctxt_prec tYCON_PREC
(sep [ppr tc, nest 4 (sep (map pprParendIfaceType tys))])
......
......@@ -14,6 +14,8 @@ module LoadIface (
#include "HsVersions.h"
import {-# SOURCE #-} TcIface( tcIfaceDecl )
import DriverState ( v_GhcMode, isCompManagerMode )
import DriverUtil ( replaceFilenameSuffix )
import CmdLineOpts ( DynFlags( verbosity ), DynFlag( Opt_IgnoreInterfacePragmas ),
......@@ -24,21 +26,21 @@ import IfaceSyn ( IfaceDecl(..), IfaceConDecls(..), IfaceConDecl(..), IfaceClas
IfaceInst(..), IfaceRule(..), IfaceExpr(..), IfaceTyCon(..), IfaceIdInfo(..),
IfaceType(..), IfacePredType(..), IfaceExtName, visibleIfConDecls, mkIfaceExtName )
import IfaceEnv ( newGlobalBinder, lookupIfaceExt, lookupIfaceTc )
import HscTypes ( HscEnv(..), ModIface(..), emptyModIface,
ExternalPackageState(..), emptyTypeEnv, emptyPool,
import HscTypes ( HscEnv(..), ModIface(..), TyThing, emptyModIface, EpsStats(..), addEpsInStats,
ExternalPackageState(..), PackageTypeEnv, emptyTypeEnv,
lookupIfaceByModName, emptyPackageIfaceTable,
IsBootInterface, mkIfaceFixCache,
Pool(..), DeclPool, InstPool,
RulePool, addRuleToPool, RulePoolContents
IsBootInterface, mkIfaceFixCache, mkTypeEnv,
Gated, implicitTyThings,
addRulesToPool, addInstsToPool
)
import BasicTypes ( Version, Fixity(..), FixityDirection(..) )
import BasicTypes ( Version, Fixity(..), FixityDirection(..), isMarkedStrict )
import TcType ( Type, tcSplitTyConApp_maybe )
import Type ( funTyCon )
import TcRnMonad
import PrelNames ( gHC_PRIM_Name )
import PrelInfo ( ghcPrimExports )
import PrelInfo ( ghcPrimExports, wiredInThings )
import PrelRules ( builtinRules )
import Rules ( emptyRuleBase )
import InstEnv ( emptyInstEnv )
......@@ -48,12 +50,11 @@ import NameEnv
import MkId ( seqId )
import Packages ( basePackage )
import Module ( Module, ModuleName, ModLocation(ml_hi_file),
moduleName, isHomeModule, moduleEnvElts,
moduleName, isHomeModule, emptyModuleEnv, moduleEnvElts,
extendModuleEnv, lookupModuleEnvByName, moduleUserString
)
import OccName ( OccName, mkClassTyConOcc, mkClassDataConOcc,
mkSuperDictSelOcc,
mkDataConWrapperOcc, mkDataConWorkerOcc )
import OccName ( OccName, mkOccEnv, lookupOccEnv, mkClassTyConOcc, mkClassDataConOcc,
mkSuperDictSelOcc, mkDataConWrapperOcc, mkDataConWorkerOcc )
import Class ( Class, className )
import TyCon ( tyConName )
import SrcLoc ( mkSrcLoc, importedSrcLoc )
......@@ -67,6 +68,7 @@ import Lexer
import Outputable
import BinIface ( readBinIface )
import Panic
import List ( nub )
import DATA_IOREF ( readIORef )
......@@ -159,14 +161,10 @@ loadInterface :: SDoc -> ModuleName -> WhereFrom
loadInterface doc_str mod_name from
= do { -- Read the state
env <- getTopEnv