hcat [text "{-# LINE ", int src_line, space,
char '\"', ftext src_path, text " #-}"]
- ppr (ImportedLoc mod) = ptext SLIT("Imported from") <+> quotes (text mod)
+ ppr (ImportedLoc mod) = ptext SLIT("Imported from") <+> text mod
ppr (UnhelpfulLoc s) = ftext s
\end{code}
{-# OPTIONS -#include "Linker.h" #-}
-----------------------------------------------------------------------------
--- $Id: InteractiveUI.hs,v 1.185 2005/01/28 12:55:23 simonmar Exp $
+-- $Id: InteractiveUI.hs,v 1.186 2005/01/28 17:44:56 simonpj Exp $
--
-- GHC Interactive User Interface
--
#include "HsVersions.h"
import CompManager
-import HscTypes ( HomeModInfo(hm_linkable), HomePackageTable,
- isObjectLinkable, GhciMode(..) )
+import HscTypes ( GhciMode(..) )
import IfaceSyn ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecls(..), IfaceConDecl(..),
IfaceInst(..), pprIfaceDeclHead, pprParendIfaceType, pprIfaceForAllPart )
import FunDeps ( pprFundeps )
import OccName ( OccName, isSymOcc, occNameUserString )
import BasicTypes ( StrictnessMark(..), defaultFixity, SuccessFlag(..) )
import Outputable
-import CmdLineOpts ( DynFlag(..), DynFlags(..), dopt_unset )
+import CmdLineOpts ( DynFlags(..) )
import Panic hiding ( showException )
import Config
import SrcLoc ( SrcLoc, isGoodSrcLoc )
import Control.Exception as Exception
import Data.Dynamic
-import Control.Concurrent
+-- import Control.Concurrent
import Numeric
import Data.List
showThing :: GetInfoResult -> SDoc
showThing (wanted_str, (thing, fixity, src_loc, insts))
- = vcat [ showDecl want_name thing,
+ = vcat [ showWithLoc src_loc (showDecl want_name thing),
show_fixity fixity,
- show_loc src_loc,
vcat (map show_inst insts)]
where
want_name occ = wanted_str == occNameUserString occ
| fix == defaultFixity = empty
| otherwise = ppr fix <+> text wanted_str
+ show_inst (iface_inst, loc)
+ = showWithLoc loc (ptext SLIT("instance") <+> ppr (ifInstHead iface_inst))
+
+showWithLoc :: SrcLoc -> SDoc -> SDoc
+showWithLoc loc doc
+ = hang doc 2 (char '\t' <> show_loc loc)
+ -- The tab tries to make them line up a bit
+ where
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("--")
- 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.
visibleIfConDecls,
-- Converting things to IfaceSyn
- tyThingToIfaceDecl, dfunToIfaceInst, coreRuleToIfaceRule,
+ tyThingToIfaceDecl, dfunToIfaceInst, coreRuleToIfaceRule,
-- Equality
IfaceEq(..), (&&&), bool, eqListBy, eqMaybeBy,
import DataCon ( dataConName, dataConSig, dataConFieldLabels, dataConStrictMarks,
dataConTyCon, dataConIsInfix, isVanillaDataCon )
import Class ( FunDep, DefMeth, classExtraBigSig, classTyCon )
-import OccName ( OccName, OccEnv, lookupOccEnv, emptyOccEnv,
- lookupOccEnv, extendOccEnv, emptyOccEnv,
+import OccName ( OccName, OccEnv, emptyOccEnv,
+ lookupOccEnv, extendOccEnv,
OccSet, unionOccSets, unitOccSet )
-import Name ( Name, NamedThing(..), getOccName, nameOccName, nameModule, isExternalName )
+import Name ( Name, NamedThing(..), nameOccName, isExternalName )
import NameSet ( NameSet, elemNameSet )
-import Module ( Module )
import CostCentre ( CostCentre, pprCostCentreCore )
import Literal ( Literal )
import ForeignCall ( ForeignCall )
--------------------------
-dfunToIfaceInst :: DFunId -> IfaceInst
-dfunToIfaceInst dfun_id
+dfunToIfaceInst :: (Name -> IfaceExtName) -> DFunId -> IfaceInst
+dfunToIfaceInst ext_lhs dfun_id
= IfaceInst { ifDFun = nameOccName dfun_name,
- ifInstHead = toIfaceType (mkLhsNameFn mod) tidy_ty }
+ ifInstHead = toIfaceType ext_lhs tidy_ty }
where
dfun_name = idName dfun_id
- mod = nameModule dfun_name
(tvs, _, cls, tys) = tcSplitDFunTy (idType dfun_id)
head_ty = mkForAllTys tvs (mkPredTy (mkClassPred cls tys))
-- No need to record the instance context;
| otherwise = Just (HsUnfold inline_prag (toIfaceExpr ext rhs))
--------------------------
-coreRuleToIfaceRule :: Module -> (Name -> IfaceExtName) -> IdCoreRule -> IfaceRule
-coreRuleToIfaceRule mod ext (IdCoreRule id _ (BuiltinRule _ _))
+coreRuleToIfaceRule :: (Name -> IfaceExtName) -- For the LHS names
+ -> (Name -> IfaceExtName) -- For the RHS names
+ -> IdCoreRule -> IfaceRule
+coreRuleToIfaceRule ext_lhs ext_rhs (IdCoreRule id _ (BuiltinRule _ _))
= pprTrace "toHsRule: builtin" (ppr id) (bogusIfaceRule (mkIfaceExtName (getName id)))
-coreRuleToIfaceRule mod ext (IdCoreRule id _ (Rule name act bndrs args rhs))
+coreRuleToIfaceRule ext_lhs ext_rhs (IdCoreRule id _ (Rule name act bndrs args rhs))
= IfaceRule { ifRuleName = name, ifActivation = act,
- ifRuleBndrs = map (toIfaceBndr ext) bndrs,
- ifRuleHead = ext (idName id),
- ifRuleArgs = map (toIfaceExpr (mkLhsNameFn mod)) args,
- -- Use LHS name-fn for the args
- ifRuleRhs = toIfaceExpr ext rhs }
+ ifRuleBndrs = map (toIfaceBndr ext_lhs) bndrs,
+ ifRuleHead = ext_lhs (idName id),
+ ifRuleArgs = map (toIfaceExpr ext_lhs) args,
+ ifRuleRhs = toIfaceExpr ext_rhs rhs }
bogusIfaceRule :: IfaceExtName -> IfaceRule
bogusIfaceRule id_name
| otherwise = IfaceLcl (nameOccName name)
where
name = idName v
-
----------------------
--- mkLhsNameFn ignores versioning info altogether
--- Used for the LHS of instance decls and rules, where we
--- there's no point in recording version info
-mkLhsNameFn :: Module -> Name -> IfaceExtName
-mkLhsNameFn this_mod name
- | mod == this_mod = LocalTop occ
- | otherwise = ExtPkg mod occ
- where
- mod = nameModule name
- occ = nameOccName name
\end{code}
IfaceType(..), IfaceKind, IfacePredType(..), IfaceTyCon(..),
IfaceContext, IfaceBndr(..), IfaceTvBndr, IfaceIdBndr,
- IfaceExtName(..), mkIfaceExtName, ifaceTyConName, ifPrintUnqual,
+ IfaceExtName(..), mkIfaceExtName, isLocalIfaceExtName,
+ ifaceTyConName, interactiveExtNameFun,
-- Conversion from Type -> IfaceType
toIfaceType, toIfacePred, toIfaceContext,
#include "HsVersions.h"
import Kind ( Kind(..) )
-import TypeRep ( Type(..), TyNote(..), PredType(..), Kind, ThetaType )
+import TypeRep ( Type(..), TyNote(..), PredType(..), ThetaType )
import TyCon ( TyCon, isTupleTyCon, tyConArity, tupleTyConBoxity )
import Var ( isId, tyVarKind, idType )
import TysWiredIn ( listTyConName, parrTyConName, tupleTyCon, intTyConName, charTyConName, boolTyConName )
-- LocalTopSub is written into iface files as LocalTop; the parent
-- info is only used when computing version information in MkIface
+isLocalIfaceExtName :: IfaceExtName -> Bool
+isLocalIfaceExtName (LocalTop _) = True
+isLocalIfaceExtName (LocalTopSub _ _) = True
+isLocalIfaceExtName other = False
+
mkIfaceExtName name = ExtPkg (nameModule name) (nameOccName name)
-- Local helper for wired-in names
-ifPrintUnqual :: PrintUnqualified -> IfaceExtName -> Bool
-ifPrintUnqual print_unqual (ExtPkg mod occ) = print_unqual mod occ
-ifPrintUnqual print_unqual (HomePkg mod occ _) = print_unqual mod occ
-ifPrintUnqual print_unqual other = True
+interactiveExtNameFun :: PrintUnqualified -> Name-> IfaceExtName
+interactiveExtNameFun print_unqual name
+ | print_unqual mod occ = LocalTop occ
+ | otherwise = ExtPkg mod occ
+ where
+ mod = nameModule name
+ occ = nameOccName name
\end{code}
ppr (LocalTopSub occ _) = ppr occ -- from an ordinary occurrence?
pprExt :: Module -> OccName -> SDoc
-pprExt mod occ
- = getPprStyle $ \ sty ->
- if unqualStyle sty mod occ then
- ppr occ
- else
- ppr mod <> dot <> ppr occ
+-- No need to worry about printing unqualified becuase that was handled
+-- in the transiation to IfaceSyn
+pprExt mod occ = ppr mod <> dot <> ppr occ
instance Outputable IfaceBndr where
ppr (IfaceIdBndr bndr) = pprIfaceIdBndr bndr
ifaceInstGates (IfaceForAllTy _ t) = ifaceInstGates t
ifaceInstGates (IfaceFunTy _ t) = ifaceInstGates t
-ifaceInstGates (IfacePredTy (IfaceClassP cls tys)) = instHeadGates cls tys
+ifaceInstGates (IfacePredTy (IfaceClassP cls tys)) = (cls, instHeadTyconGates tys)
ifaceInstGates other = pprPanic "ifaceInstGates" (ppr other)
-- The other cases should not happen
-instHeadGates cls tys = (cls, mapCatMaybes root_tycon tys)
+instHeadTyconGates tys = mapCatMaybes root_tycon tys
where
root_tycon (IfaceFunTy _ _) = Just (IfaceTc funTyConExtName)
root_tycon (IfaceTyConApp tc _) = Just tc
mg_rules = rules,
mg_types = type_env }
= do { eps <- hscEPS hsc_env
- ; let { ext_nm = mkExtNameFn hsc_env eps this_mod
+ ; let { ext_nm_rhs = mkExtNameFn hsc_env eps this_mod
+ ; ext_nm_lhs = mkLhsNameFn this_mod
; local_things = [thing | thing <- typeEnvElts type_env,
not (isWiredInName (getName thing)) ]
-- Do not export anything about wired-in things
| thing <- local_things
, not (mustExposeThing exports thing)]
- ; decls = [ tyThingToIfaceDecl omit_prags abstract_tcs ext_nm thing
+ ; decls = [ tyThingToIfaceDecl omit_prags abstract_tcs ext_nm_rhs thing
| thing <- local_things, wantDeclFor exports abstract_tcs thing ]
-- Don't put implicit Ids and class tycons in the interface file
; iface_rules
| omit_prags = []
| otherwise = sortLe le_rule $
- map (coreRuleToIfaceRule this_mod ext_nm) rules
- ; iface_insts = sortLe le_inst (map dfunToIfaceInst insts)
+ map (coreRuleToIfaceRule ext_nm_lhs ext_nm_rhs) rules
+ ; iface_insts = sortLe le_inst (map (dfunToIfaceInst ext_nm_lhs) insts)
; intermediate_iface = ModIface {
mi_module = this_mod,
iface = lookupIfaceByModule hpt pit mod `orElse`
pprPanic "lookupVers2" (ppr mod <+> ppr occ)
+
+---------------------
+-- mkLhsNameFn ignores versioning info altogether
+-- It is used for the LHS of instance decls and rules, where we
+-- there's no point in recording version info
+mkLhsNameFn :: Module -> Name -> IfaceExtName
+mkLhsNameFn this_mod name
+ | mod == this_mod = LocalTop occ
+ | otherwise = ExtPkg mod occ
+ where
+ mod = nameModule name
+ occ = nameOccName name
+
+
-----------------------------
-- Compute version numbers for local decls
mkAbstractTyConRhs, mkDataTyConRhs, mkNewTyConRhs )
import TcRnMonad
import Type ( liftedTypeKind, splitTyConApp,
- mkTyVarTys, mkGenTyConApp, mkTyVarTys, ThetaType, pprClassPred )
+ mkTyVarTys, mkGenTyConApp, ThetaType, pprClassPred )
import TypeRep ( Type(..), PredType(..) )
import TyCon ( TyCon, tyConName )
import HscTypes ( ExternalPackageState(..), EpsStats(..), PackageInstEnv,
; returnM (IdCoreRule fn (isOrphNm fn_rdr) core_rule) }
isOrphNm :: IfaceExtName -> Bool
-isOrphNm (LocalTop _) = False
-isOrphNm (LocalTopSub _ _) = False
-isOrphNm other = True
+-- An orphan name comes from somewhere other than this module,
+-- so it has a non-local name
+isOrphNm name = not (isLocalIfaceExtName name)
\end{code}
#include "HsVersions.h"
+import IO
#ifdef GHCI
import {-# SOURCE #-} TcSplice ( tcSpliceDecls )
#endif
import IfaceSyn ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..),
IfaceExtName(..), IfaceConDecls(..), IfaceInst(..),
tyThingToIfaceDecl, dfunToIfaceInst )
-import IfaceType ( IfaceTyCon(..), ifPrintUnqual )
+import IfaceType ( IfaceTyCon(..), interactiveExtNameFun, isLocalIfaceExtName )
import IfaceEnv ( lookupOrig )
import RnEnv ( lookupOccRn, dataTcOccs, lookupFixityRn )
import Id ( Id, isImplicitId, setIdType, globalIdDetails )
import SrcLoc ( interactiveSrcLoc, unLoc )
import Kind ( Kind )
import Var ( globaliseId )
-import Name ( nameOccName, nameModule )
+import Name ( nameOccName )
import NameEnv ( delListFromNameEnv )
import PrelNames ( iNTERACTIVE, ioTyConName, printName, monadNames, itName, returnIOName )
import HscTypes ( InteractiveContext(..), HomeModInfo(..), typeEnvElts, typeEnvClasses,
-- so it had better be a home module
= do { hpt <- getHpt
; case lookupModuleEnv hpt mod of
- Just mod_info -> return (map toIfaceDecl $
+ Just mod_info -> return (map (toIfaceDecl ext_nm) $
filter wantToSee $
typeEnvElts $
md_types (hm_details mod_info))
get_decl (mod, avail)
= do { main_name <- lookupOrig mod (availName avail)
; thing <- tcLookupGlobal main_name
- ; return (filter_decl (availNames avail) (toIfaceDecl thing)) }
+ ; return (filter_decl (availNames avail) (toIfaceDecl ext_nm thing)) }
+
+ ext_nm = interactiveExtNameFun (icPrintUnqual ictxt)
---------------------
filter_decl occs decl@(IfaceClass {ifSigs = sigs})
-- their parent declaration
let { do_one name = do { thing <- tcLookupGlobal name
; fixity <- lookupFixityRn name
- ; insts <- lookupInsts print_unqual thing
- ; return (toIfaceDecl thing, fixity,
+ ; insts <- lookupInsts ext_nm thing
+ ; return (toIfaceDecl ext_nm thing, fixity,
getSrcLoc thing, insts) } } ;
-- For the SrcLoc, the 'thing' has better info than
-- the 'name' because getting the former forced the
}
where
cmp (d1,_,_,_) (d2,_,_,_) = ifName d1 `compare` ifName d2
-
- print_unqual :: PrintUnqualified
- print_unqual = icPrintUnqual ictxt
+ ext_nm = interactiveExtNameFun (icPrintUnqual ictxt)
-lookupInsts :: PrintUnqualified -> TyThing -> TcM [(IfaceInst, SrcLoc)]
+lookupInsts :: (Name -> IfaceExtName) -> TyThing -> TcM [(IfaceInst, SrcLoc)]
-- Filter the instances by the ones whose tycons (or clases resp)
-- are in scope unqualified. Otherwise we list a whole lot too many!
-lookupInsts print_unqual (AClass cls)
+lookupInsts ext_nm (AClass cls)
= do { loadImportedInsts cls [] -- [] means load all instances for cls
; inst_envs <- tcGetInstEnvs
; return [ (inst, getSrcLoc dfun)
| (_,_,dfun) <- classInstances inst_envs cls
- , let inst = dfunToIfaceInst dfun
+ , let inst = dfunToIfaceInst ext_nm dfun
(_, tycons) = ifaceInstGates (ifInstHead inst)
, all print_tycon_unqual tycons ] }
where
- print_tycon_unqual (IfaceTc ext_nm) = ifPrintUnqual print_unqual ext_nm
+ print_tycon_unqual (IfaceTc nm) = isLocalIfaceExtName nm
print_tycon_unqual other = True -- Int etc
-lookupInsts print_unqual (ATyCon tc)
+lookupInsts ext_nm (ATyCon tc)
= do { eps <- getEps -- Load all instances for all classes that are
-- in the type environment (which are all the ones
-- we've seen in any interface file so far)
; return [ (inst, getSrcLoc dfun)
| (_, _, dfun) <- instEnvElts home_ie ++ instEnvElts pkg_ie
, relevant dfun
- , let inst = dfunToIfaceInst dfun
+ , let inst = dfunToIfaceInst ext_nm dfun
(cls, _) = ifaceInstGates (ifInstHead inst)
- , ifPrintUnqual print_unqual cls ] }
+ , isLocalIfaceExtName cls ] }
where
relevant df = tc_name `elemNameSet` tyClsNamesOfDFunHead (idType df)
tc_name = tyConName tc
-lookupInsts print_unqual other = return []
+lookupInsts ext_nm other = return []
-toIfaceDecl :: TyThing -> IfaceDecl
-toIfaceDecl thing
+toIfaceDecl :: (Name -> IfaceExtName) -> TyThing -> IfaceDecl
+toIfaceDecl ext_nm thing
= tyThingToIfaceDecl True -- Discard IdInfo
emptyNameSet -- Show data cons
ext_nm (munge thing)
where
- ext_nm n = ExtPkg (nameModule n) (nameOccName n)
-
-- munge transforms a thing to its "parent" thing
munge (ADataCon dc) = ATyCon (dataConTyCon dc)
munge (AnId id) = case globalIdDetails id of
ClassOpId cls -> AClass cls
other -> AnId id
munge other_thing = other_thing
-
#endif /* GHCI */
\end{code}
projects / ghc-hetmet.git / commitdiff