---------------------------------------------------------------------------
* 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
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
-- 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
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,
\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)
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(..),
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
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
-- 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
= 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
; 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
import TcRnMonad
import HsSyn ( HsExpr, HsMatchContext, Pat )
-import IfaceEnv ( tcIfaceGlobal )
+import TcIface ( tcIfaceGlobal )
import HscTypes ( TyThing(..), TypeEnv, HscEnv,
IsBootInterface,
tyThingId, tyThingTyCon, tyThingDataCon )
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
--
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
; 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.
lookupOrig, lookupIfaceTc,
newIfaceName, newIfaceNames,
extendIfaceIdEnv, extendIfaceTyVarEnv,
- tcIfaceGlobal, tcIfaceTyCon, tcIfaceClass, tcIfaceExtId,
- tcIfaceTyVar, tcIfaceDataCon, tcIfaceLclId,
+ tcIfaceLclId, tcIfaceTyVar,
-- Name-cache stuff
allocateGlobalBinder, initNameCache
#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 )
\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
`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
; 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
--------------------------
-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;
-- Printing
pprIfaceType, pprParendIfaceType, pprIfaceContext,
pprIfaceIdBndr, pprIfaceTvBndr, pprIfaceTvBndrs, pprIfaceBndrs,
- getIfaceExt,
tOP_PREC, tYCON_PREC, noParens, maybeParen, pprIfaceForAllPart
) where
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
----------------------------- 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
\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
-------------------
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))])
#include "HsVersions.h"
+import {-# SOURCE #-} TcIface( tcIfaceDecl )
+
import DriverState ( v_GhcMode, isCompManagerMode )
import DriverUtil ( replaceFilenameSuffix )
import CmdLineOpts ( DynFlags( verbosity ), DynFlag( Opt_IgnoreInterfacePragmas ),
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 )
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 )
import Outputable
import BinIface ( readBinIface )
import Panic
+import List ( nub )
import DATA_IOREF ( readIORef )
loadInterface doc_str mod_name from
= do { -- Read the state
- env <- getTopEnv
- ; let { hpt = hsc_HPT env
- ; eps_var = hsc_EPS env }
- ; eps <- readMutVar eps_var
- ; let { pit = eps_PIT eps }
+ (eps,hpt) <- getEpsAndHpt
-- Check whether we have the interface already
- ; case lookupIfaceByModName hpt pit mod_name of {
+ ; case lookupIfaceByModName hpt (eps_PIT eps) mod_name of {
Just iface
-> returnM (Right iface) ; -- Already loaded
-- The (src_imp == mi_boot iface) test checks that the already-loaded
-- if an earlier import had a before we got to real imports. I think.
other -> do
- { if_gbl_env <- getGblEnv
- ; let { hi_boot_file = case from of
+ { let { hi_boot_file = case from of
ImportByUser usr_boot -> usr_boot
ImportBySystem -> sys_boot
- ; mb_dep = lookupModuleEnvByName (if_is_boot if_gbl_env) mod_name
+ ; mb_dep = lookupModuleEnvByName (eps_is_boot eps) mod_name
; sys_boot = case mb_dep of
Just (_, is_boot) -> is_boot
Nothing -> False
; read_result <- findAndReadIface doc_str mod_name hi_boot_file
; case read_result of {
Left err -> do
- { let { -- Not found, so add an empty iface to
+ { let fake_iface = emptyModIface opt_InPackage mod_name
+
+ ; updateEps_ $ \eps ->
+ eps { eps_PIT = extendModuleEnv (eps_PIT eps) (mi_module fake_iface) fake_iface }
+ -- Not found, so add an empty iface to
-- the EPS map so that we don't look again
- fake_iface = emptyModIface opt_InPackage mod_name
- ; new_pit = extendModuleEnv pit (mi_module fake_iface) fake_iface
- ; new_eps = eps { eps_PIT = new_pit } }
- ; writeMutVar eps_var new_eps
+
; returnM (Left err) } ;
-- Found and parsed!
Right iface ->
- let { mod = mi_module iface } in
+ let { mod = mi_module iface
+ ; mod_name = moduleName mod } in
-- Sanity check. If we're system-importing a module we know nothing at all
-- about, it should be from a different package to this one
WARN( case from of { ImportBySystem -> True; other -> False } &&
not (isJust mb_dep) &&
isHomeModule mod,
- ppr mod $$ ppr mb_dep)
+ ppr mod $$ ppr mb_dep $$ ppr (eps_is_boot eps) )
- initIfaceLcl (moduleName mod) $ do
+ initIfaceLcl mod_name $ do
-- Load the new ModIface into the External Package State
-- Even home-package interfaces loaded by loadInterface
-- (which only happens in OneShot mode; in Batch/Interactive
-- explicitly tag each export which seems a bit of a bore)
{ ignore_prags <- doptM Opt_IgnoreInterfacePragmas
- ; new_eps_decls <- loadDecls ignore_prags mod (eps_decls eps) (mi_decls iface)
- ; new_eps_rules <- loadRules ignore_prags mod (eps_rules eps) (mi_rules iface)
- ; new_eps_insts <- loadInsts mod (eps_insts eps) (mi_insts iface)
+ ; new_eps_decls <- loadDecls ignore_prags mod (mi_decls iface)
+ ; new_eps_rules <- loadRules ignore_prags mod_name (mi_rules iface)
+ ; new_eps_insts <- loadInsts mod_name (mi_insts iface)
; let { final_iface = iface { mi_decls = panic "No mi_decls in PIT",
mi_insts = panic "No mi_insts in PIT",
- mi_rules = panic "No mi_rules in PIT" }
+ mi_rules = panic "No mi_rules in PIT" } }
+
+ ; traceIf (text "Extending PTE" <+> ppr (map fst (concat new_eps_decls)))
+
+ ; updateEps_ $ \ eps ->
+ eps { eps_PIT = extendModuleEnv (eps_PIT eps) mod final_iface,
+ eps_PTE = addDeclsToPTE (eps_PTE eps) new_eps_decls,
+ eps_rules = addRulesToPool (eps_rules eps) new_eps_rules,
+ eps_insts = addInstsToPool (eps_insts eps) new_eps_insts,
+ eps_stats = addEpsInStats (eps_stats eps) (length new_eps_decls)
+ (length new_eps_insts) (length new_eps_rules) }
- ; new_eps = eps { eps_PIT = extendModuleEnv pit mod final_iface,
- eps_decls = new_eps_decls,
- eps_rules = new_eps_rules,
- eps_insts = new_eps_insts } }
- ; writeMutVar eps_var new_eps
; return (Right final_iface)
}}}}}
-- the declaration itself, will find the fully-glorious Name
-----------------------------------------------------
+addDeclsToPTE :: PackageTypeEnv -> [[(Name,TyThing)]] -> PackageTypeEnv
+addDeclsToPTE pte things = foldl extendNameEnvList pte things
+
loadDecls :: Bool -- Don't load pragmas into the decl pool
- -> Module -> DeclPool
+ -> Module
-> [(Version, IfaceDecl)]
- -> IfM lcl DeclPool
-loadDecls ignore_prags mod (Pool decls_map n_in n_out) decls
- = do { decls_map' <- foldlM (loadDecl ignore_prags mod) decls_map decls
- ; returnM (Pool decls_map' (n_in + length decls) n_out) }
-
-loadDecl ignore_prags mod decls_map (_version, decl)
- = do { main_name <- mk_new_bndr Nothing (ifName decl)
- ; let decl' | ignore_prags = discardDeclPrags decl
- | otherwise = decl
-
- -- Populate the name cache with final versions of all the subordinate names
- ; mapM_ (mk_new_bndr (Just main_name)) (ifaceDeclSubBndrs decl')
-
- -- Extend the decls pool with a mapping for the main name (only)
- ; returnM (extendNameEnv decls_map main_name decl') }
+ -> IfL [[(Name,TyThing)]] -- The list can be poked eagerly, but the
+ -- TyThings are forkM'd thunks
+loadDecls ignore_prags mod decls = mapM (loadDecl ignore_prags mod) decls
+
+loadDecl ignore_prags mod (_version, decl)
+ = do { -- Populate the name cache with final versions of all
+ -- the names associated with the decl
+ main_name <- mk_new_bndr Nothing (ifName decl)
+ ; implicit_names <- mapM (mk_new_bndr (Just main_name)) (ifaceDeclSubBndrs decl)
+
+ -- Typecheck the thing, lazily
+ ; thing <- forkM doc (bumpDeclStats main_name >> tcIfaceDecl decl)
+ ; let mini_env = mkOccEnv [(getOccName t, t) | t <- implicitTyThings thing]
+ lookup n = case lookupOccEnv mini_env (getOccName n) of
+ Just thing -> thing
+ Nothing -> pprPanic "loadDecl" (ppr main_name <+> ppr n)
+
+ ; returnM ((main_name, thing) : [(n, lookup n) | n <- implicit_names]) }
+ -- We build a list from the *known* names, with (lookup n) thunks
+ -- as the TyThings. That way we can extend the PTE without poking the
+ -- thunks
where
+ decl' | ignore_prags = discardDeclPrags decl
+ | otherwise = decl
+
-- mk_new_bndr allocates in the name cache the final canonical
-- name for the thing, with the correct
-- * package info
-- imported name, to fix the module correctly in the cache
mk_new_bndr mb_parent occ = newGlobalBinder mod occ mb_parent loc
loc = importedSrcLoc (moduleUserString mod)
+ doc = ptext SLIT("Declaration for") <+> ppr (ifName decl)
discardDeclPrags :: IfaceDecl -> IfaceDecl
discardDeclPrags decl@(IfaceId {ifIdInfo = HasInfo _}) = decl { ifIdInfo = NoInfo }
discardDeclPrags decl = decl
+bumpDeclStats :: Name -> IfL () -- Record that one more declaration has actually been used
+bumpDeclStats name
+ = do { traceIf (text "Loading decl for" <+> ppr name)
+ ; updateEps_ (\eps -> let stats = eps_stats eps
+ in eps { eps_stats = stats { n_decls_out = n_decls_out stats + 1 } })
+ }
-----------------
ifaceDeclSubBndrs :: IfaceDecl -> [OccName]
-- *Excludes* the 'main' name, but *includes* the implicitly-bound names
--- Rather revolting, because it has to predict what gets bound
+-- Deeply revolting, because it has to predict what gets bound,
+-- especially the question of whether there's a wrapper for a datacon
ifaceDeclSubBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_occ, ifSigs = sigs })
- = [tc_occ, dc_occ] ++
+ = [tc_occ, dc_occ, dcww_occ] ++
[op | IfaceClassOp op _ _ <- sigs] ++
- [mkSuperDictSelOcc n cls_occ | n <- [1..length sc_ctxt]] ++
- -- The worker and wrapper for the DataCon of the class TyCon
- -- are based off the data-con name
- [mkDataConWrapperOcc dc_occ, mkDataConWorkerOcc dc_occ]
+ [mkSuperDictSelOcc n cls_occ | n <- [1..n_ctxt]]
where
+ n_ctxt = length sc_ctxt
+ n_sigs = length sigs
tc_occ = mkClassTyConOcc cls_occ
dc_occ = mkClassDataConOcc cls_occ
+ dcww_occ | is_newtype = mkDataConWrapperOcc dc_occ -- Newtypes have wrapper but no worker
+ | otherwise = mkDataConWorkerOcc dc_occ -- Otherwise worker but no wrapper
+ is_newtype = n_sigs + n_ctxt == 1 -- Sigh
+
+ifaceDeclSubBndrs (IfaceData {ifCons = IfAbstractTyCon})
+ = []
+ifaceDeclSubBndrs (IfaceData {ifCons = IfNewTyCon (IfaceConDecl con_occ _ _ _ _ _ fields)})
+ = fields ++ [con_occ, mkDataConWrapperOcc con_occ]
+ -- Wrapper, no worker; see MkId.mkDataConIds
+
+ifaceDeclSubBndrs (IfaceData {ifCons = IfDataTyCon cons})
+ = nub (concatMap fld_occs cons) -- Eliminate duplicate fields
+ ++ concatMap dc_occs cons
+ where
+ fld_occs (IfaceConDecl _ _ _ _ _ _ fields) = fields
+ dc_occs (IfaceConDecl con_occ _ _ _ _ strs _)
+ | has_wrapper = [con_occ, work_occ, wrap_occ]
+ | otherwise = [con_occ, work_occ]
+ where
+ wrap_occ = mkDataConWrapperOcc con_occ
+ work_occ = mkDataConWorkerOcc con_occ
+ has_wrapper = any isMarkedStrict strs -- See MkId.mkDataConIds (sigh)
+ -- ToDo: may miss strictness in existential dicts
-ifaceDeclSubBndrs (IfaceData {ifCons = cons}) = foldr ((++) . conDeclBndrs) []
- (visibleIfConDecls cons)
-ifaceDeclSubBndrs other = []
-
-conDeclBndrs (IfaceConDecl con_occ _ _ _ _ _ fields)
- = fields ++
- [con_occ, mkDataConWrapperOcc con_occ, mkDataConWorkerOcc con_occ]
+ifaceDeclSubBndrs _other = []
-----------------------------------------------------
-- Loading instance decls
-----------------------------------------------------
-loadInsts :: Module -> InstPool -> [IfaceInst] -> IfL InstPool
-loadInsts mod (Pool pool n_in n_out) decls
- = do { new_pool <- foldlM (loadInstDecl (moduleName mod)) pool decls
- ; returnM (Pool new_pool
- (n_in + length decls)
- n_out) }
+loadInsts :: ModuleName -> [IfaceInst] -> IfL [(Name, Gated IfaceInst)]
+loadInsts mod decls = mapM (loadInstDecl mod) decls
-loadInstDecl mod pool decl@(IfaceInst {ifInstHead = inst_ty})
+loadInstDecl mod decl@(IfaceInst {ifInstHead = inst_ty})
= do {
-- Find out what type constructors and classes are "gates" for the
-- instance declaration. If all these "gates" are slurped in then
let { (cls_ext, tc_exts) = ifaceInstGates inst_ty }
; cls <- lookupIfaceExt cls_ext
; tcs <- mapM lookupIfaceTc tc_exts
- ; let { new_pool = extendNameEnv_C combine pool cls [(tcs, (mod,decl))]
- ; combine old _ = (tcs,(mod,decl)) : old }
- ; returnM new_pool
+ ; returnM (cls, (tcs, (mod,decl)))
}
-----------------------------------------------------
-----------------------------------------------------
loadRules :: Bool -- Don't load pragmas into the decl pool
- -> Module -> RulePool -> [IfaceRule] -> IfL RulePool
-loadRules ignore_prags mod pool@(Pool rule_pool n_in n_out) rules
- | ignore_prags = returnM pool
- | otherwise
- = do { new_pool <- foldlM (loadRule (moduleName mod)) rule_pool rules
- ; returnM (Pool new_pool (n_in + length rules) n_out) }
-
-loadRule :: ModuleName -> RulePoolContents -> IfaceRule -> IfL RulePoolContents
+ -> ModuleName
+ -> [IfaceRule] -> IfL [Gated IfaceRule]
+loadRules ignore_prags mod rules
+ | ignore_prags = returnM []
+ | otherwise = mapM (loadRule mod) rules
+
+loadRule :: ModuleName -> IfaceRule -> IfL (Gated IfaceRule)
-- "Gate" the rule simply by a crude notion of the free vars of
-- the LHS. It can be crude, because having too few free vars is safe.
-loadRule mod_name pool decl@(IfaceRule {ifRuleHead = fn, ifRuleArgs = args})
+loadRule mod decl@(IfaceRule {ifRuleHead = fn, ifRuleArgs = args})
= do { names <- mapM lookupIfaceExt (fn : arg_fvs)
- ; returnM (addRuleToPool pool (mod_name, decl) names) }
+ ; returnM (names, (mod, decl)) }
where
arg_fvs = [n | arg <- args, n <- crudeIfExprGblFvs arg]
+
---------------------------
crudeIfExprGblFvs :: IfaceExpr -> [IfaceExtName]
-- A crude approximation to the free external names of an IfExpr
initExternalPackageState :: ExternalPackageState
initExternalPackageState
= EPS {
+ eps_is_boot = emptyModuleEnv,
eps_PIT = emptyPackageIfaceTable,
eps_PTE = emptyTypeEnv,
eps_inst_env = emptyInstEnv,
eps_rule_base = emptyRuleBase,
- eps_decls = emptyPool emptyNameEnv,
- eps_insts = emptyPool emptyNameEnv,
- eps_rules = foldr add (emptyPool []) builtinRules
+ eps_insts = emptyNameEnv,
+ eps_rules = addRulesToPool [] (map mk_gated_rule builtinRules),
+ -- Initialise the EPS rule pool with the built-in rules
+ eps_stats = EpsStats { n_ifaces_in = 0, n_decls_in = 0, n_decls_out = 0
+ , n_insts_in = 0, n_insts_out = 0
+ , n_rules_in = length builtinRules, n_rules_out = 0 }
}
where
- -- Initialise the EPS rule pool with the built-in rules
- add (fn_name, core_rule) (Pool rules n_in n_out)
- = Pool rules' (n_in+1) n_out
- where
- rules' = addRuleToPool rules iface_rule [fn_name]
- iface_rule = (nameModuleName fn_name, IfaceBuiltinRule (mkIfaceExtName fn_name) core_rule)
+ mk_gated_rule (fn_name, core_rule)
+ = ([fn_name], (nameModuleName fn_name, IfaceBuiltinRule (mkIfaceExtName fn_name) core_rule))
\end{code}
\begin{code}
ifaceStats :: ExternalPackageState -> SDoc
ifaceStats eps
- = hcat [text "Renamer stats: ", stats]
+ = hcat [text "Renamer stats: ", msg]
where
- n_mods = length [() | _ <- moduleEnvElts (eps_PIT eps)]
- -- This is really only right for a one-shot compile
-
- Pool _ n_decls_in n_decls_out = eps_decls eps
- Pool _ n_insts_in n_insts_out = eps_insts eps
- Pool _ n_rules_in n_rules_out = eps_rules eps
-
- stats = vcat
- [int n_mods <+> text "interfaces read",
- hsep [ int n_decls_out, text "type/class/variable imported, out of",
- int n_decls_in, text "read"],
- hsep [ int n_insts_out, text "instance decls imported, out of",
- int n_insts_in, text "read"],
- hsep [ int n_rules_out, text "rule decls imported, out of",
- int n_rules_in, text "read"]
+ stats = eps_stats eps
+ msg = vcat
+ [int (n_ifaces_in stats) <+> text "interfaces read",
+ hsep [ int (n_decls_out stats), text "type/class/variable imported, out of",
+ int (n_decls_in stats), text "read"],
+ hsep [ int (n_insts_out stats), text "instance decls imported, out of",
+ int (n_insts_in stats), text "read"],
+ hsep [ int (n_rules_out stats), text "rule decls imported, out of",
+ int (n_rules_in stats), text "read"]
]
\end{code}
import TcType ( isFFITy )
import HscTypes ( ModIface(..), TyThing(..),
ModGuts(..), ModGuts, IfaceExport,
- GhciMode(..),
+ GhciMode(..), isOneShot,
HscEnv(..), hscEPS,
Dependencies(..), FixItem(..),
mkIfaceDepCache, mkIfaceFixCache, mkIfaceVerCache,
| omit_prags = []
| otherwise = sortLt lt_rule $
map (coreRuleToIfaceRule this_mod_name ext_nm) rules
- ; iface_insts = sortLt lt_inst (map (dfunToIfaceInst this_mod_name) insts)
+ ; iface_insts = sortLt lt_inst (map dfunToIfaceInst insts)
; intermediate_iface = ModIface {
mi_module = this_mod,
| not source_unchanged
= returnM outOfDate
| otherwise
- = traceHiDiffs (text "Considering whether compilation is required for" <+>
- ppr (mi_module iface) <> colon) `thenM_`
+ = do { traceHiDiffs (text "Considering whether compilation is required for" <+>
+ ppr (mi_module iface) <> colon)
-- Source code unchanged and no errors yet... carry on
+
-- First put the dependent-module info in the envt, just temporarily,
-- so that when we look for interfaces we look for the right one (.hi or .hi-boot)
-- It's just temporary because either the usage check will succeed
-- (in which case we are done with this module) or it'll fail (in which
-- case we'll compile the module from scratch anyhow).
- updGblEnv (\ gbl -> gbl { if_is_boot = mod_deps }) (
- checkList [checkModUsage u | u <- mi_usages iface]
- )
+ ; mode <- getGhciMode
+ ; ifM (isOneShot mode)
+ (updateEps_ $ \eps -> eps { eps_is_boot = mod_deps })
+
+ ; checkList [checkModUsage u | u <- mi_usages iface]
+ }
where
-- This is a bit of a hack really
mod_deps :: ModuleEnv (ModuleName, IsBootInterface)
module TcIface where
-tcImportDecl :: Name.Name -> TcRnTypes.IfG TypeRep.TyThing
+tcIfaceDecl :: IfaceSyn.IfaceDecl -> TcRnTypes.IfL TypeRep.TyThing
\begin{code}
module TcIface (
- tcImportDecl, typecheckIface,
+ tcImportDecl, typecheckIface, tcIfaceDecl, tcIfaceGlobal,
loadImportedInsts, loadImportedRules,
tcExtCoreBindings
) where
import IfaceSyn
import LoadIface ( loadHomeInterface, predInstGates, discardDeclPrags )
-import IfaceEnv ( lookupIfaceTop, newGlobalBinder, lookupOrig,
+import IfaceEnv ( lookupIfaceTop, lookupIfaceExt, newGlobalBinder, lookupOrig,
extendIfaceIdEnv, extendIfaceTyVarEnv, newIPName,
- tcIfaceTyVar, tcIfaceTyCon, tcIfaceClass, tcIfaceExtId,
- tcIfaceDataCon, tcIfaceLclId,
+ tcIfaceTyVar, tcIfaceLclId,
newIfaceName, newIfaceNames )
import BuildTyCl ( buildSynTyCon, buildAlgTyCon, buildDataCon, buildClass,
mkAbstractTyConRhs, mkDataTyConRhs, mkNewTyConRhs )
mkTyVarTys, mkGenTyConApp, mkTyVarTys, ThetaType, pprClassPred )
import TypeRep ( Type(..), PredType(..) )
import TyCon ( TyCon, tyConName )
-import HscTypes ( ExternalPackageState(..), PackageInstEnv,
- HscEnv, TyThing(..), implicitTyThings, typeEnvIds,
+import HscTypes ( ExternalPackageState(..), EpsStats(..), PackageInstEnv,
+ HscEnv, TyThing(..), implicitTyThings, tyThingClass, tyThingTyCon,
ModIface(..), ModDetails(..), InstPool, ModGuts,
- TypeEnv, mkTypeEnv, extendTypeEnvList, lookupTypeEnv,
- RulePool, Pool(..) )
+ TypeEnv, mkTypeEnv, extendTypeEnv, extendTypeEnvList,
+ lookupTypeEnv, lookupType, typeEnvIds,
+ RulePool )
import InstEnv ( extendInstEnv )
import CoreSyn
import PprCore ( pprIdRules )
vanillaIdInfo, newStrictnessInfo )
import Class ( Class )
import TyCon ( tyConDataCons, tyConTyVars, isTupleTyCon, mkForeignTyCon )
-import DataCon ( dataConWorkId, dataConExistentialTyVars, dataConArgTys )
-import TysWiredIn ( tupleCon )
+import DataCon ( DataCon, dataConWorkId, dataConExistentialTyVars, dataConArgTys )
+import TysWiredIn ( intTyCon, boolTyCon, charTyCon, listTyCon, parrTyCon,
+ tupleTyCon, tupleCon )
import Var ( TyVar, mkTyVar, tyVarKind )
-import Name ( Name, NamedThing(..), nameModuleName, nameModule, nameOccName,
+import Name ( Name, NamedThing(..), nameModuleName, nameModule, nameOccName, nameIsLocalOrFrom,
isWiredInName, wiredInNameTyThing_maybe, nameParent, nameParent_maybe )
import NameEnv
import OccName ( OccName )
import Util ( zipWithEqual, dropList, equalLength, zipLazy )
import Maybes ( expectJust )
import CmdLineOpts ( DynFlag(..) )
+
+import UniqFM (sizeUFM)
+
\end{code}
This module takes
tcImportDecl :: Name -> IfG TyThing
-- Get the TyThing for this Name from an interface file
tcImportDecl name
- = do {
- -- Make sure the interface is loaded
- ; let { nd_doc = ptext SLIT("Need decl for") <+> ppr name }
- ; traceIf (nd_doc <+> char '{') -- Brace matches the later message
- ; loadHomeInterface nd_doc name
-
- -- Get the real name of the thing, with a correct nameParent field.
- -- Before the interface is loaded, we may have a non-committal 'Nothing'
- -- in the namePareent field (made up by IfaceEnv.lookupOrig), but
- -- loading the interface updates the name cache.
- -- We need the right nameParent field in getThing
- ; real_name <- lookupOrig (nameModuleName name) (nameOccName name)
-
- -- Get the decl out of the EPS
- ; main_thing <- ASSERT( real_name == name ) -- Unique should not change!
- getThing real_name
-
- -- Record the import in the type env,
- -- slurp any rules it allows in
- ; recordImportOf main_thing
-
- ; let { extra | getName main_thing == real_name = empty
- | otherwise = brackets (ptext SLIT("when seeking") <+> ppr real_name) }
- ; traceIf (ptext SLIT(" ...imported decl for") <+> ppr main_thing <+> extra <+> char '}')
-
-
- -- Look up the wanted Name in the type envt; it might be
- -- one of the subordinate members of the input thing
- ; if real_name == getName main_thing
- then return main_thing
- else do
- { eps <- getEps
- ; return (expectJust "tcImportDecl" $
- lookupTypeEnv (eps_PTE eps) real_name) }}
-
-recordImportOf :: TyThing -> IfG ()
--- Update the EPS to record the import of the Thing
--- (a) augment the type environment; this is done even for wired-in
--- things, so that we don't go through this rigmarole a second time
--- (b) slurp in any rules to maintain the invariant that any rule
--- whose gates are all in the type envt, is in eps_rule_base
-
-recordImportOf thing
- = do { new_things <- updateEps (\ eps ->
- let { new_things = thing : implicitTyThings thing
- ; new_type_env = extendTypeEnvList (eps_PTE eps) new_things
- -- NB: opportunity for a very subtle loop here!
- -- If working out what the implicitTyThings are involves poking
- -- any of the fork'd thunks in 'thing', then here's what happens
- -- * recordImportOf succeed, extending type-env with a thunk
- -- * the next guy to pull on type-env forces the thunk
- -- * which pokes the suspended forks
- -- * which, to execute, need to consult type-env (to check
- -- entirely unrelated types, perhaps)
- }
- in (eps { eps_PTE = new_type_env }, new_things)
- )
- ; traceIf (text "tcImport: extend type env" <+> ppr new_things)
- }
-
-getThing :: Name -> IfG TyThing
--- Find and typecheck the thing; the Name might be a "subordinate name"
--- of the "main thing" (e.g. the constructor of a data type declaration)
--- The Thing we return is the parent "main thing"
-
-getThing name
| Just thing <- wiredInNameTyThing_maybe name
- = return thing
-
- | otherwise = do -- The normal case, not wired in
- { -- Get the decl from the pool
- mb_decl <- updateEps (\ eps -> selectDecl eps name)
-
- ; case mb_decl of
- Just decl -> initIfaceLcl (nameModuleName name) (tcIfaceDecl decl)
- -- Typecheck it
- -- Side-effects EPS by faulting in any needed decls
- -- (via nested calls to tcImportDecl)
-
-
- Nothing -> do { ioToIOEnv (printErrs (msg defaultErrStyle)); failM }
- -- Declaration not found
- -- No errors-var to accumulate errors in, so just
- -- print out the error right now
-
+ -- This case only happens for tuples, because we pre-populate the eps_PTE
+ -- with other wired-in things. We can't do that for tuples because we
+ -- don't know how many of them we'll find
+ = do { updateEps_ (\ eps -> eps { eps_PTE = extendTypeEnv (eps_PTE eps) thing })
+ ; return thing }
+
+ | otherwise
+ = do { traceIf nd_doc
+
+ -- Load the interface, which should populate the PTE
+ ; loadHomeInterface nd_doc name
+
+ -- Now look it up again; this time we should find it
+ ; eps <- getEps
+ ; case lookupTypeEnv (eps_PTE eps) name of
+ Just thing -> return thing
+ Nothing -> do { ioToIOEnv (printErrs (msg defaultErrStyle)); failM }
+ -- Declaration not found!
+ -- No errors-var to accumulate errors in, so just
+ -- print out the error right now
}
where
- msg = hang (ptext SLIT("Can't find interface-file declaration for") <+> ppr (nameParent name))
- 2 (vcat [ptext SLIT("Probable cause: bug in .hi-boot file, or inconsistent .hi file"),
+ nd_doc = ptext SLIT("Need decl for") <+> ppr name
+ msg = hang (ptext SLIT("Can't find interface-file declaration for") <+> ppr (nameParent name))
+ 2 (vcat [ptext SLIT("Probable cause: bug in .hi-boot file, or inconsistent .hi file"),
ptext SLIT("Use -ddump-if-trace to get an idea of which file caused the error")])
-
-selectDecl :: ExternalPackageState -> Name -> (ExternalPackageState, Maybe IfaceDecl)
--- Use nameParent to get the parent name of the thing
-selectDecl eps@(EPS { eps_decls = Pool decls_map n_in n_out}) name
- = case lookupNameEnv decls_map name of {
- -- This first lookup will usually fail for subordinate names, because
- -- the relevant decl is the parent decl.
- -- But, if we export a data type decl abstractly, its selectors
- -- get separate type signatures in the interface file
- Just decl -> let
- decls' = delFromNameEnv decls_map name
- in
- (eps {eps_decls = Pool decls' n_in (n_out+1)}, Just decl) ;
-
- Nothing ->
- case nameParent_maybe name of {
- Nothing -> (eps, Nothing ) ; -- No "parent"
- Just main_name -> -- Has a parent; try that
-
- case lookupNameEnv decls_map main_name of {
- Just decl -> let
- decls' = delFromNameEnv decls_map main_name
- in
- (eps {eps_decls = Pool decls' n_in (n_out+1)}, Just decl) ;
- Nothing -> (eps, Nothing)
- }}}
\end{code}
%************************************************************************
; if null wired_tcs then returnM ()
else initIfaceTcRn (mapM_ (loadHomeInterface wired_doc) wired_tcs)
- ; eps_var <- getEpsVar
- ; eps <- readMutVar eps_var
-
- -- For interest: report the no-type-constructor case.
- -- Don't report when -fallow-undecidable-instances is on, because then
- -- we call loadImportedInsts when looking up even predicates like (C a)
- -- But without undecidable instances it's rare to see C (a b) and
- -- somethat interesting
-{- (comment out; happens a lot in some code)
-#ifdef DEBUG
- ; dflags <- getDOpts
- ; WARN( not (dopt Opt_AllowUndecidableInstances dflags) && null tc_gates,
- ptext SLIT("Interesting! No tycons in Inst:")
- <+> pprClassPred cls tys )
- return ()
-#endif
--}
- -- Suck in the instances
- ; let { (inst_pool', iface_insts)
- = selectInsts (eps_insts eps) cls_gate tc_gates }
+ -- Now suck in the relevant instances
+ ; iface_insts <- updateEps (selectInsts cls_gate tc_gates)
-- Empty => finish up rapidly, without writing to eps
; if null iface_insts then
- return (eps_inst_env eps)
+ do { eps <- getEps; return (eps_inst_env eps) }
else do
- { writeMutVar eps_var (eps {eps_insts = inst_pool'})
-
- ; traceIf (sep [ptext SLIT("Importing instances for") <+> pprClassPred cls tys,
+ { traceIf (sep [ptext SLIT("Importing instances for") <+> pprClassPred cls tys,
nest 2 (vcat (map ppr iface_insts))])
-- Typecheck the new instances
tcIfaceInst (IfaceInst { ifDFun = dfun_occ })
= tcIfaceExtId (LocalTop dfun_occ)
-selectInsts :: InstPool -> Name -> [Name] -> (InstPool, [(ModuleName, IfaceInst)])
-selectInsts pool@(Pool insts n_in n_out) cls tycons
- = (Pool insts' n_in (n_out + length iface_insts), iface_insts)
+selectInsts :: Name -> [Name] -> ExternalPackageState -> (ExternalPackageState, [(ModuleName, IfaceInst)])
+selectInsts cls tycons eps
+ = (eps { eps_insts = insts', eps_stats = stats' }, iface_insts)
where
+ insts = eps_insts eps
+ stats = eps_stats eps
+ stats' = stats { n_insts_out = n_insts_out stats + length iface_insts }
+
(insts', iface_insts)
= case lookupNameEnv insts cls of {
Nothing -> (insts, []) ;
loadImportedRules hsc_env guts
= initIfaceRules hsc_env guts $ do
{ -- Get new rules
- if_rules <- updateEps (\ eps ->
- let { (new_pool, if_rules) = selectRules (eps_rules eps) (eps_PTE eps) }
- in (eps { eps_rules = new_pool }, if_rules) )
+ if_rules <- updateEps selectRules
; traceIf (ptext SLIT("Importing rules:") <+> vcat (map ppr if_rules))
}
-selectRules :: RulePool -> TypeEnv -> (RulePool, [(ModuleName, IfaceRule)])
+selectRules :: ExternalPackageState -> (ExternalPackageState, [(ModuleName, IfaceRule)])
-- Not terribly efficient. Look at each rule in the pool to see if
-- all its gates are in the type env. If so, take it out of the pool.
-- If not, trim its gates for next time.
-selectRules (Pool rules n_in n_out) type_env
- = (Pool rules' n_in (n_out + length if_rules), if_rules)
+selectRules eps
+ = (eps { eps_rules = rules', eps_stats = stats' }, if_rules)
where
+ stats = eps_stats eps
+ rules = eps_rules eps
+ type_env = eps_PTE eps
+ stats' = stats { n_rules_out = n_rules_out stats + length if_rules }
+
(rules', if_rules) = foldl do_one ([], []) rules
do_one (pool, if_rules) (gates, rule)
%************************************************************************
%* *
+ Getting from Names to TyThings
+%* *
+%************************************************************************
+
+\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) }
+\end{code}
+
+%************************************************************************
+%* *
Bindings
%* *
%************************************************************************
mk_iface_tyvar name kind = mkTyVar name kind
\end{code}
+
module HscMain (
HscResult(..), hscMain, newHscEnv, hscCmmFile, hscBufferFrontEnd
#ifdef GHCI
- , hscStmt, hscTcExpr, hscKcType, hscThing,
+ , hscStmt, hscTcExpr, hscKcType
+ , hscGetInfo, GetInfoResult
, compileExpr
#endif
) where
#ifdef GHCI
import HsSyn ( Stmt(..), LStmt, LHsExpr, LHsType )
-import IfaceSyn ( IfaceDecl )
+import IfaceSyn ( IfaceDecl, IfaceInst )
import CodeOutput ( outputForeignStubs )
import ByteCodeGen ( byteCodeGen, coreExprToBCOs )
import Linker ( HValue, linkExpr )
import TidyPgm ( tidyCoreExpr )
import CorePrep ( corePrepExpr )
import Flattening ( flattenExpr )
-import TcRnDriver ( tcRnStmt, tcRnExpr, tcRnThing, tcRnType )
-import RdrName ( RdrName )
+import TcRnDriver ( tcRnStmt, tcRnExpr, tcRnGetInfo, tcRnType )
+import RdrName ( RdrName, rdrNameOcc )
+import OccName ( occNameUserString )
import Type ( Type )
import PrelNames ( iNTERACTIVE )
import StringBuffer ( stringToStringBuffer )
-- hscNoRecomp definitely expects to have the old interface available
hscNoRecomp hsc_env msg_act have_object
mod location (Just old_iface)
- | hsc_mode hsc_env == OneShot
+ | isOneShot (hsc_mode hsc_env)
= do {
when (verbosity (hsc_dflags hsc_env) > 0) $
hPutStrLn stderr "compilation IS NOT required";
mod location maybe_checked_iface
= do {
-- what target are we shooting for?
- ; let one_shot = hsc_mode hsc_env == OneShot
+ ; let one_shot = isOneShot (hsc_mode hsc_env)
; let dflags = hsc_dflags hsc_env
; let toInterp = dopt_HscLang dflags == HscInterpreted
; let toCore = isJust (ml_hs_file location) &&
\begin{code}
#ifdef GHCI
-hscThing -- like hscStmt, but deals with a single identifier
+type GetInfoResult = (String, (IfaceDecl, Fixity, SrcLoc, [(IfaceInst,SrcLoc)]))
+
+hscGetInfo -- like hscStmt, but deals with a single identifier
:: HscEnv
-> InteractiveContext -- Context for compiling
-> String -- The identifier
- -> IO [(IfaceDecl, Fixity, SrcLoc)]
+ -> IO [GetInfoResult]
-hscThing hsc_env ic str
+hscGetInfo hsc_env ic str
= do maybe_rdr_name <- hscParseIdentifier (hsc_dflags hsc_env) str
case maybe_rdr_name of {
Nothing -> return [];
Just (L _ rdr_name) -> do
- maybe_tc_result <- tcRnThing hsc_env ic rdr_name
+ maybe_tc_result <- tcRnGetInfo hsc_env ic rdr_name
+
+ let -- str' is the the naked occurrence name
+ -- after stripping off qualification and parens (+)
+ str' = occNameUserString (rdrNameOcc rdr_name)
case maybe_tc_result of {
Nothing -> return [] ;
- Just things -> return things
+ Just things -> return [(str', t) | t <- things]
}}
#endif
\end{code}
\begin{code}
module HscTypes (
HscEnv(..), hscEPS,
- GhciMode(..),
+ GhciMode(..), isOneShot,
ModDetails(..),
ModGuts(..), ModImports(..), ForeignStubs(..),
HomePackageTable, HomeModInfo(..), emptyHomePackageTable,
- ExternalPackageState(..),
+ ExternalPackageState(..), EpsStats(..), addEpsInStats,
PackageTypeEnv, PackageIfaceTable, emptyPackageIfaceTable,
lookupIface, lookupIfaceByModName, moduleNameToModule,
emptyModIface,
TyThing(..), tyThingClass, tyThingTyCon, tyThingDataCon, tyThingId,
TypeEnv, lookupType, mkTypeEnv, emptyTypeEnv,
- extendTypeEnvList, extendTypeEnvWithIds, lookupTypeEnv,
+ extendTypeEnv, extendTypeEnvList, extendTypeEnvWithIds, lookupTypeEnv,
typeEnvElts, typeEnvClasses, typeEnvTyCons, typeEnvIds,
WhetherHasOrphans, IsBootInterface, Usage(..),
Dependencies(..), noDependencies,
- Pool(..), emptyPool, DeclPool, InstPool,
- Gated,
- RulePool, RulePoolContents, addRuleToPool,
+ InstPool, Gated, addInstsToPool,
+ RulePool, addRulesToPool,
NameCache(..), OrigNameCache, OrigIParamCache,
Avails, availsToNameSet, availName, availNames,
GenAvailInfo(..), AvailInfo, RdrAvailInfo,
import RdrName ( GlobalRdrEnv, emptyGlobalRdrEnv,
LocalRdrEnv, emptyLocalRdrEnv,
- GlobalRdrElt(..), unQualOK )
-import Name ( Name, NamedThing, getName, nameOccName, nameModule )
+ GlobalRdrElt(..), mkRdrUnqual, lookupGRE_RdrName )
+import Name ( Name, NamedThing, getName, nameOccName, nameModule, nameModuleName )
import NameEnv
import NameSet
import OccName ( OccName, OccEnv, lookupOccEnv, mkOccEnv, emptyOccEnv,
The GhciMode is self-explanatory:
\begin{code}
-data GhciMode = Batch | Interactive | OneShot | IDE
+data GhciMode = Batch -- ghc --make Main
+ | Interactive -- ghc --interactive
+ | OneShot -- ghc Foo.hs
+ | IDE -- Visual Studio etc
deriving Eq
+
+isOneShot :: GhciMode -> Bool
+isOneShot OneShot = True
+isOneShot _other = False
\end{code}
\begin{code}
in error messages.
\begin{code}
-unQualInScope :: GlobalRdrEnv -> Name -> Bool
+unQualInScope :: GlobalRdrEnv -> PrintUnqualified
-- True if 'f' is in scope, and has only one binding,
-- and the thing it is bound to is the name we are looking for
-- (i.e. false if A.f and B.f are both in scope as unqualified 'f')
--
--- Also checks for built-in syntax, which is always 'in scope'
---
--- This fn is only efficient if the shared
--- partial application is used a lot.
-unQualInScope env
- = \n -> n `elemNameSet` unqual_names || isBuiltInSyntaxName n
- where
- unqual_names :: NameSet
- unqual_names = foldOccEnv add emptyNameSet env
- add [gre] unquals | unQualOK gre = addOneToNameSet unquals (gre_name gre)
- add _ unquals = unquals
+-- [Out of date] Also checks for built-in syntax, which is always 'in scope'
+unQualInScope env mod occ
+ = case lookupGRE_RdrName (mkRdrUnqual occ) env of
+ [gre] -> nameModuleName (gre_name gre) == mod
+ other -> False
\end{code}
lookupTypeEnv = lookupNameEnv
-extendTypeEnvList :: TypeEnv -> [TyThing] -> TypeEnv
-- Extend the type environment
-extendTypeEnvList env things
- = foldl extend env things
- where
- extend env thing = extendNameEnv env (getName thing) thing
+extendTypeEnv :: TypeEnv -> TyThing -> TypeEnv
+extendTypeEnv env thing = extendNameEnv env (getName thing) thing
+
+extendTypeEnvList :: TypeEnv -> [TyThing] -> TypeEnv
+extendTypeEnvList env things = foldl extendTypeEnv env things
\end{code}
\begin{code}
data ExternalPackageState
= EPS {
+ eps_is_boot :: !(ModuleEnv (ModuleName, IsBootInterface)),
+ -- In OneShot mode (only), home-package modules accumulate in the
+ -- external package state, and are sucked in lazily.
+ -- For these home-pkg modules (only) we need to record which are
+ -- boot modules. We set this field after loading all the
+ -- explicitly-imported interfaces, but before doing anything else
+ --
+ -- The ModuleName part is not necessary, but it's useful for
+ -- debug prints, and it's convenient because this field comes
+ -- direct from TcRnTypes.ImportAvails.imp_dep_mods
+
eps_PIT :: !PackageIfaceTable,
-- The ModuleIFaces for modules in external packages
-- whose interfaces we have opened
-- Holding pens for stuff that has been read in from file,
-- but not yet slurped into the renamer
- eps_decls :: !DeclPool,
- -- A single, global map of Names to unslurped decls
- -- Decls move from here to eps_PTE
-
eps_insts :: !InstPool,
-- The as-yet un-slurped instance decls
-- Decls move from here to eps_inst_env
-- Each instance is 'gated' by the names that must be
-- available before this instance decl is needed.
- eps_rules :: !RulePool
+ eps_rules :: !RulePool,
-- The as-yet un-slurped rules
+
+ eps_stats :: !EpsStats
}
+
+-- "In" means read from iface files
+-- "Out" means actually sucked in and type-checked
+data EpsStats = EpsStats { n_ifaces_in
+ , n_decls_in, n_decls_out
+ , n_rules_in, n_rules_out
+ , n_insts_in, n_insts_out :: !Int }
\end{code}
The NameCache makes sure that there is just one Unique assigned for
\end{code}
\begin{code}
-data Pool p = Pool p -- The pool itself
- Int -- Number of decls slurped into the map
- Int -- Number of decls slurped out of the map
-
-emptyPool p = Pool p 0 0
-
-instance Outputable p => Outputable (Pool p) where
- ppr (Pool p n_in n_out) -- Debug printing only
- = vcat [ptext SLIT("Pool") <+> int n_in <+> int n_out,
- nest 2 (ppr p)]
-
-type DeclPool = Pool (NameEnv IfaceDecl) -- Keyed by the "main thing" of the decl
-
--------------------------
-type Gated d = ([Name], (ModuleName, d)) -- The [Name] 'gate' the declaration
+type Gated d = ([Name], (ModuleName, d)) -- The [Name] 'gate' the declaration; always non-empty
-- ModuleName records which iface file this
-- decl came from
-type RulePool = Pool RulePoolContents
-type RulePoolContents = [Gated IfaceRule]
+type RulePool = [Gated IfaceRule]
-addRuleToPool :: RulePoolContents
- -> (ModuleName, IfaceRule)
- -> [Name] -- Free vars of rule; always non-empty
- -> RulePoolContents
-addRuleToPool rules rule fvs = (fvs,rule) : rules
+addRulesToPool :: RulePool
+ -> [Gated IfaceRule]
+ -> RulePool
+addRulesToPool rules new_rules = new_rules ++ rules
-------------------------
-type InstPool = Pool (NameEnv [Gated IfaceInst])
+addEpsInStats :: EpsStats -> Int -> Int -> Int -> EpsStats
+-- Add stats for one newly-read interface
+addEpsInStats stats n_decls n_insts n_rules
+ = stats { n_ifaces_in = n_ifaces_in stats + 1
+ , n_decls_in = n_decls_in stats + n_decls
+ , n_insts_in = n_insts_in stats + n_insts
+ , n_rules_in = n_rules_in stats + n_rules }
+
+-------------------------
+type InstPool = NameEnv [Gated IfaceInst]
-- The key of the Pool is the Class
-- The Names are the TyCons in the instance head
-- For example, suppose this is in an interface file
-- instance C T where ...
-- We want to slurp this decl if both C and T are "visible" in
-- the importing module. See "The gating story" in RnIfaces for details.
+
+
+addInstsToPool :: InstPool -> [(Name, Gated IfaceInst)] -> InstPool
+addInstsToPool insts new_insts
+ = foldr add insts new_insts
+ where
+ add :: (Name, Gated IfaceInst) -> NameEnv [Gated IfaceInst] -> NameEnv [Gated IfaceInst]
+ add (cls,new_inst) insts = extendNameEnv_C combine insts cls [new_inst]
+ where
+ combine old_insts _ = new_inst : old_insts
\end{code}
moduleNameUserString, isHomeModule,
unitModuleEnvByName, unitModuleEnv,
lookupModuleEnvByName, moduleEnvElts )
-import Name ( Name, nameSrcLoc, nameOccName, nameModuleName,
+import Name ( Name, nameSrcLoc, nameOccName, nameModuleName, isWiredInName,
nameParent, nameParent_maybe, isExternalName, nameModule )
import NameSet
import NameEnv
-> RnM (GlobalRdrEnv, ImportAvails)
rnImports imports
- = -- PROCESS IMPORT DECLS
+ = do { -- PROCESS IMPORT DECLS
-- Do the non {- SOURCE -} ones first, so that we get a helpful
-- warning for {- SOURCE -} ones that are unnecessary
- getModule `thenM` \ this_mod ->
- doptM Opt_NoImplicitPrelude `thenM` \ opt_no_prelude ->
- let
- all_imports = mk_prel_imports this_mod opt_no_prelude ++ imports
- (source, ordinary) = partition is_source_import all_imports
- is_source_import (L _ (ImportDecl _ is_boot _ _ _)) = is_boot
-
- get_imports = importsFromImportDecl this_mod
- in
- mappM get_imports ordinary `thenM` \ stuff1 ->
- mappM get_imports source `thenM` \ stuff2 ->
+ this_mod <- getModule
+ ; opt_no_prelude <- doptM Opt_NoImplicitPrelude
+ ; let
+ all_imports = mk_prel_imports this_mod opt_no_prelude ++ imports
+ (source, ordinary) = partition is_source_import all_imports
+ is_source_import (L _ (ImportDecl _ is_boot _ _ _)) = is_boot
+
+ get_imports = importsFromImportDecl this_mod
+
+ ; stuff1 <- mappM get_imports ordinary
+ ; stuff2 <- mappM get_imports source
-- COMBINE RESULTS
- let
+ ; let
(imp_gbl_envs, imp_avails) = unzip (stuff1 ++ stuff2)
gbl_env :: GlobalRdrEnv
gbl_env = foldr plusGlobalRdrEnv emptyGlobalRdrEnv imp_gbl_envs
all_avails :: ImportAvails
all_avails = foldr plusImportAvails emptyImportAvails imp_avails
- in
+
-- ALL DONE
- returnM (gbl_env, all_avails)
+ ; return (gbl_env, all_avails) }
where
-- NB: opt_NoImplicitPrelude is slightly different to import Prelude ();
-- because the former doesn't even look at Prelude.hi for instance
= case lookupIface hpt pit (nameModule n) of
Just iface -> mi_dep_fn iface n `seqMaybe` -- Bleat if the thing, *or
mi_dep_fn iface (nameParent n) -- its parent*, is deprec'd
- Nothing -> pprPanic "lookupDeprec" (ppr n)
+ Nothing
+ | isWiredInName n -> Nothing
+ -- We have not necessarily loaded the .hi file for a
+ -- wired-in name (yet), although we *could*.
+ -- And we never deprecate them
+
+ | otherwise -> pprPanic "lookupDeprec" (ppr n)
-- By now all the interfaces should have been loaded
gre_is_used :: NameSet -> GlobalRdrElt -> Bool
dfun_name = idName dfun_id
tcGetInstEnvs :: TcM (InstEnv, InstEnv)
--- Gets both the home-pkg inst env (includes module being compiled)
--- and the external-package inst-env
+-- Gets both the external-package inst-env
+-- and the home-pkg inst env (includes module being compiled)
tcGetInstEnvs = do { eps <- getEps; env <- getGblEnv;
- return (tcg_inst_env env, eps_inst_env eps) }
+ return (eps_inst_env eps, tcg_inst_env env) }
\end{code}
tcLookupLocatedGlobalId, tcLookupLocatedTyCon,
tcLookupLocatedClass, tcLookupLocatedDataCon,
- getInGlobalScope,
-
-- Local environment
tcExtendKindEnv,
tcExtendTyVarEnv, tcExtendTyVarEnv2,
= tcExtendGlobalEnv [AnId id | id <- ids] thing_inside
\end{code}
-A variety of global lookups, when we know what we are looking for.
-
-\begin{code}
-getInGlobalScope :: TcM (Name -> Bool)
--- Get all things in the global environment; used for deciding what
--- rules to suck in. Anything defined in this module (nameIsLocalOrFrom)
--- is certainly in the envt, so we don't bother to look.
-getInGlobalScope
- = do { mod <- getModule
- ; (eps,hpt) <- getEpsAndHpt
- ; return (\n -> nameIsLocalOrFrom mod n ||
- isJust (lookupType hpt (eps_PTE eps) n)) }
-\end{code}
-
-
\begin{code}
tcExtendRecEnv :: [(Name,TyThing)] -> TcM r -> TcM r
-- Extend the global environments for the type/class knot tying game
module TcRnDriver (
#ifdef GHCI
mkExportEnv, getModuleContents, tcRnStmt,
- tcRnThing, tcRnExpr, tcRnType,
+ tcRnGetInfo, tcRnExpr, tcRnType,
#endif
tcRnModule,
tcTopSrcDecls,
import TcRules ( tcRules )
import TcForeign ( tcForeignImports, tcForeignExports )
import TcInstDcls ( tcInstDecls1, tcInstDecls2 )
-import TcIface ( tcExtCoreBindings )
+import TcIface ( tcExtCoreBindings, loadImportedInsts )
import TcSimplify ( tcSimplifyTop )
import TcTyClsDecls ( tcTyAndClassDecls )
import LoadIface ( loadOrphanModules )
import TyCon ( tyConHasGenerics )
import SrcLoc ( SrcLoc, srcLocSpan, Located(..), noLoc )
import Outputable
-import HscTypes ( ModGuts(..), HscEnv(..),
- GhciMode(..), Dependencies(..), noDependencies,
+import HscTypes ( ModGuts(..), HscEnv(..), ExternalPackageState( eps_is_boot ),
+ GhciMode(..), isOneShot, Dependencies(..), noDependencies,
Deprecs( NoDeprecs ), plusDeprecs,
ForeignStubs(NoStubs), TypeEnv,
- extendTypeEnvWithIds, typeEnvIds, typeEnvTyCons,
+ extendTypeEnvWithIds, typeEnvIds, typeEnvTyCons,
emptyFixityEnv
)
#ifdef GHCI
import TcMType ( zonkTcType )
import TcMatches ( tcStmtsAndThen, TcStmtCtxt(..) )
import TcSimplify ( tcSimplifyInteractive, tcSimplifyInfer )
-import TcType ( Type, mkForAllTys, mkFunTys, mkTyConApp, tyVarsOfType )
+import TcType ( Type, mkForAllTys, mkFunTys, mkTyConApp, tyVarsOfType, tyClsNamesOfDFunHead )
import TcEnv ( tcLookupTyCon, tcLookupId, tcLookupGlobal )
import RnTypes ( rnLHsType )
-import Inst ( tcStdSyntaxName )
+import Inst ( tcStdSyntaxName, tcGetInstEnvs )
+import InstEnv ( DFunId, classInstances, instEnvElts )
import RnExpr ( rnStmts, rnLExpr )
import RnNames ( exportsToAvails )
import LoadIface ( loadSrcInterface )
import IfaceSyn ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..),
- IfaceExtName(..), IfaceConDecls(..),
- tyThingToIfaceDecl )
+ IfaceExtName(..), IfaceConDecls(..), IfaceInst(..),
+ tyThingToIfaceDecl, dfunToIfaceInst )
import RnEnv ( lookupOccRn, dataTcOccs, lookupFixityRn )
import Id ( Id, isImplicitId, globalIdDetails )
import FieldLabel ( fieldLabelTyCon )
import MkId ( unsafeCoerceId )
import DataCon ( dataConTyCon )
+import TyCon ( tyConName )
import TysWiredIn ( mkListTy, unitTy )
import IdInfo ( GlobalIdDetails(..) )
import SrcLoc ( interactiveSrcLoc, unLoc )
import NameEnv ( delListFromNameEnv )
import PrelNames ( iNTERACTIVE, ioTyConName, printName, monadNames, itName, returnIOName )
import Module ( ModuleName, lookupModuleEnvByName )
-import HscTypes ( InteractiveContext(..),
- HomeModInfo(..), typeEnvElts,
+import HscTypes ( InteractiveContext(..), ExternalPackageState( eps_PTE ),
+ HomeModInfo(..), typeEnvElts, typeEnvClasses,
TyThing(..), availName, availNames, icPrintUnqual,
ModIface(..), ModDetails(..) )
import BasicTypes ( RecFlag(..), Fixity )
addSrcSpan loc $
do { -- Deal with imports; sets tcg_rdr_env, tcg_imports
(rdr_env, imports) <- rnImports import_decls ;
+
+ -- In one-shot mode, record boot-file info in the EPS
+ ifM (isOneShot (hsc_mode hsc_env)) $
+ updateEps_ (\eps -> eps { eps_is_boot = imp_dep_mods imports }) ;
+
+ -- Update the gbl env
updGblEnv ( \ gbl -> gbl { tcg_rdr_env = rdr_env,
tcg_imports = tcg_imports gbl `plusImportAvails` imports })
$ do {
%************************************************************************
%* *
- The interactive interface
+ Type-checking external-core modules
%* *
%************************************************************************
\begin{code}
-#ifdef GHCI
-tcRnStmt :: HscEnv
- -> InteractiveContext
- -> LStmt RdrName
- -> IO (Maybe (InteractiveContext, [Name], LHsExpr Id))
- -- The returned [Name] is the same as the input except for
- -- ExprStmt, in which case the returned [Name] is [itName]
- --
- -- The returned TypecheckedHsExpr is of type IO [ () ],
- -- a list of the bound values, coerced to ().
+tcRnExtCore :: HscEnv
+ -> HsExtCore RdrName
+ -> IO (Messages, Maybe ModGuts)
+ -- Nothing => some error occurred
-tcRnStmt hsc_env ictxt rdr_stmt
- = initTcPrintErrors hsc_env iNTERACTIVE $
- setInteractiveContext ictxt $ do {
+tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds)
+ -- The decls are IfaceDecls; all names are original names
+ = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;
- -- Rename; use CmdLineMode because tcRnStmt is only used interactively
- ([rn_stmt], fvs) <- rnStmts DoExpr [rdr_stmt] ;
- traceRn (text "tcRnStmt" <+> vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs]) ;
- failIfErrsM ;
-
- -- The real work is done here
- (bound_ids, tc_expr) <- tcUserStmt rn_stmt ;
-
- traceTc (text "tcs 1") ;
- let { -- Make all the bound ids "global" ids, now that
- -- they're notionally top-level bindings. This is
- -- important: otherwise when we come to compile an expression
- -- using these ids later, the byte code generator will consider
- -- the occurrences to be free rather than global.
- global_ids = map (globaliseId VanillaGlobal) bound_ids ;
-
- -- Update the interactive context
- rn_env = ic_rn_local_env ictxt ;
- type_env = ic_type_env ictxt ;
+ initTc hsc_env this_mod $ do {
- bound_names = map idName global_ids ;
- new_rn_env = extendLocalRdrEnv rn_env bound_names ;
+ let { ldecls = map noLoc decls } ;
- -- Remove any shadowed bindings from the type_env;
- -- they are inaccessible but might, I suppose, cause
- -- a space leak if we leave them there
- shadowed = [ n | name <- bound_names,
- let rdr_name = mkRdrUnqual (nameOccName name),
- Just n <- [lookupLocalRdrEnv rn_env rdr_name] ] ;
+ -- Deal with the type declarations; first bring their stuff
+ -- into scope, then rname them, then type check them
+ (rdr_env, imports) <- importsFromLocalDecls (mkFakeGroup ldecls) ;
- filtered_type_env = delListFromNameEnv type_env shadowed ;
- new_type_env = extendTypeEnvWithIds filtered_type_env global_ids ;
+ updGblEnv (\gbl -> gbl { tcg_rdr_env = rdr_env `plusGlobalRdrEnv` tcg_rdr_env gbl,
+ tcg_imports = imports `plusImportAvails` tcg_imports gbl })
+ $ do {
- new_ic = ictxt { ic_rn_local_env = new_rn_env,
- ic_type_env = new_type_env }
- } ;
+ rn_decls <- rnTyClDecls ldecls ;
+ failIfErrsM ;
- dumpOptTcRn Opt_D_dump_tc
- (vcat [text "Bound Ids" <+> pprWithCommas ppr global_ids,
- text "Typechecked expr" <+> ppr tc_expr]) ;
+ -- Dump trace of renaming part
+ rnDump (ppr rn_decls) ;
- returnM (new_ic, bound_names, tc_expr)
- }
-\end{code}
+ -- Typecheck them all together so that
+ -- any mutually recursive types are done right
+ tcg_env <- checkNoErrs (tcTyAndClassDecls rn_decls) ;
+ -- Make the new type env available to stuff slurped from interface files
+ setGblEnv tcg_env $ do {
+
+ -- Now the core bindings
+ core_binds <- initIfaceExtCore (tcExtCoreBindings this_mod src_binds) ;
-Here is the grand plan, implemented in tcUserStmt
+ -- Wrap up
+ let {
+ bndrs = bindersOfBinds core_binds ;
+ my_exports = mkNameSet (map idName bndrs) ;
+ -- ToDo: export the data types also?
- What you type The IO [HValue] that hscStmt returns
- ------------- ------------------------------------
- let pat = expr ==> let pat = expr in return [coerce HVal x, coerce HVal y, ...]
- bindings: [x,y,...]
+ final_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) bndrs ;
- pat <- expr ==> expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...]
- bindings: [x,y,...]
+ mod_guts = ModGuts { mg_module = this_mod,
+ mg_usages = [], -- ToDo: compute usage
+ mg_dir_imps = [], -- ??
+ mg_deps = noDependencies, -- ??
+ mg_exports = my_exports,
+ mg_types = final_type_env,
+ mg_insts = tcg_insts tcg_env,
+ mg_rules = [],
+ mg_binds = core_binds,
- expr (of IO type) ==> expr >>= \ it -> return [coerce HVal it]
- [NB: result not printed] bindings: [it]
-
- expr (of non-IO type, ==> let it = expr in print it >> return [coerce HVal it]
- result showable) bindings: [it]
+ -- Stubs
+ mg_rdr_env = emptyGlobalRdrEnv,
+ mg_fix_env = emptyFixityEnv,
+ mg_deprecs = NoDeprecs,
+ mg_foreign = NoStubs
+ } } ;
- expr (of non-IO type,
- result not showable) ==> error
+ tcCoreDump mod_guts ;
+ return mod_guts
+ }}}}
-\begin{code}
----------------------------
-tcUserStmt :: LStmt Name -> TcM ([Id], LHsExpr Id)
-tcUserStmt (L _ (ExprStmt expr _))
- = newUnique `thenM` \ uniq ->
- let
- fresh_it = itName uniq
- the_bind = noLoc $ FunBind (noLoc fresh_it) False
- [ mkSimpleMatch [] expr placeHolderType ]
- in
- tryTcLIE_ (do { -- Try this if the other fails
- traceTc (text "tcs 1b") ;
- tc_stmts [
- nlLetStmt [HsBindGroup (unitBag the_bind) [] NonRecursive],
- nlExprStmt (nlHsApp (nlHsVar printName)
- (nlHsVar fresh_it))
- ] })
- (do { -- Try this first
- traceTc (text "tcs 1a") ;
- tc_stmts [nlBindStmt (nlVarPat fresh_it) expr] })
+mkFakeGroup decls -- Rather clumsy; lots of unused fields
+ = HsGroup { hs_tyclds = decls, -- This is the one we want
+ hs_valds = [], hs_fords = [],
+ hs_instds = [], hs_fixds = [], hs_depds = [],
+ hs_ruleds = [], hs_defds = [] }
+\end{code}
-tcUserStmt stmt = tc_stmts [stmt]
----------------------------
-tc_stmts stmts
- = do { ioTyCon <- tcLookupTyCon ioTyConName ;
- let {
- ret_ty = mkListTy unitTy ;
- io_ret_ty = mkTyConApp ioTyCon [ret_ty] ;
+%************************************************************************
+%* *
+ Type-checking the top level of a module
+%* *
+%************************************************************************
- names = map unLoc (collectStmtsBinders stmts) ;
+\begin{code}
+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
+ (tc_envs, lie) <- getLIE (tc_rn_src_decls decls) ;
- stmt_ctxt = SC { sc_what = DoExpr,
- sc_rhs = check_rhs,
- sc_body = check_body,
- sc_ty = ret_ty } ;
+ -- tcSimplifyTop deals with constant or ambiguous InstIds.
+ -- How could there be ambiguous ones? They can only arise if a
+ -- top-level decl falls under the monomorphism
+ -- restriction, and no subsequent decl instantiates its
+ -- type. (Usually, ambiguous type variables are resolved
+ -- during the generalisation step.)
+ traceTc (text "Tc8") ;
+ inst_binds <- setEnvs tc_envs (tcSimplifyTop lie) ;
+ -- Setting the global env exposes the instances to tcSimplifyTop
+ -- Setting the local env exposes the local Ids to tcSimplifyTop,
+ -- so that we get better error messages (monomorphism restriction)
- check_rhs rhs rhs_ty = tcCheckRho rhs (mkTyConApp ioTyCon [rhs_ty]) ;
- check_body body = tcCheckRho body io_ret_ty ;
+ -- Backsubstitution. This must be done last.
+ -- Even tcSimplifyTop may do some unification.
+ traceTc (text "Tc9") ;
+ let { (tcg_env, _) = tc_envs ;
+ TcGblEnv { tcg_type_env = type_env, tcg_binds = binds,
+ tcg_rules = rules, tcg_fords = fords } = tcg_env } ;
- -- mk_return builds the expression
- -- returnIO @ [()] [coerce () x, .., coerce () z]
- --
- -- Despite the inconvenience of building the type applications etc,
- -- this *has* to be done in type-annotated post-typecheck form
- -- because we are going to return a list of *polymorphic* values
- -- coerced to type (). If we built a *source* stmt
- -- return [coerce x, ..., coerce z]
- -- then the type checker would instantiate x..z, and we wouldn't
- -- get their *polymorphic* values. (And we'd get ambiguity errs
- -- if they were overloaded, since they aren't applied to anything.)
- mk_return ret_id ids = nlHsApp (noLoc $ TyApp (nlHsVar ret_id) [ret_ty])
- (noLoc $ ExplicitList unitTy (map mk_item ids)) ;
- mk_item id = nlHsApp (noLoc $ TyApp (nlHsVar unsafeCoerceId) [idType id, unitTy])
- (nlHsVar id) ;
+ (bind_ids, binds', fords', rules') <- zonkTopDecls (binds `unionBags` inst_binds)
+ rules fords ;
- io_ty = mkTyConApp ioTyCon []
- } ;
+ let { final_type_env = extendTypeEnvWithIds type_env bind_ids } ;
- -- OK, we're ready to typecheck the stmts
- traceTc (text "tcs 2") ;
- ((ids, tc_expr), lie) <- getLIE $ do {
- (ids, tc_stmts) <- tcStmtsAndThen combine stmt_ctxt stmts $
- do {
- -- Look up the names right in the middle,
- -- where they will all be in scope
- ids <- mappM tcLookupId names ;
- ret_id <- tcLookupId returnIOName ; -- return @ IO
- return (ids, [nlResultStmt (mk_return ret_id ids)]) } ;
+ -- Make the new type env available to stuff slurped from interface files
+ writeMutVar (tcg_type_env_var tcg_env) final_type_env ;
- io_ids <- mappM (tcStdSyntaxName DoOrigin io_ty) monadNames ;
- return (ids, noLoc (HsDo DoExpr tc_stmts io_ids io_ret_ty))
- } ;
+ return (tcg_env { tcg_type_env = final_type_env,
+ tcg_binds = binds', tcg_rules = rules', tcg_fords = fords' })
+ }
- -- Simplify the context right here, so that we fail
- -- if there aren't enough instances. Notably, when we see
- -- e
- -- we use recoverTc_ to try it <- e
- -- and then let it = e
- -- It's the simplify step that rejects the first.
- traceTc (text "tcs 3") ;
- const_binds <- tcSimplifyInteractive lie ;
+tc_rn_src_decls :: [LHsDecl RdrName] -> TcM (TcGblEnv, TcLclEnv)
+-- Loops around dealing with each top level inter-splice group
+-- in turn, until it's dealt with the entire module
+tc_rn_src_decls ds
+ = do { let { (first_group, group_tail) = findSplice ds } ;
+ -- If ds is [] we get ([], Nothing)
- -- Build result expression and zonk it
- let { expr = mkHsLet const_binds tc_expr } ;
- zonked_expr <- zonkTopLExpr expr ;
- zonked_ids <- zonkTopBndrs ids ;
+ -- Type check the decls up to, but not including, the first splice
+ tc_envs@(tcg_env,tcl_env) <- tcRnGroup first_group ;
- -- None of the Ids should be of unboxed type, because we
- -- cast them all to HValues in the end!
- mappM bad_unboxed (filter (isUnLiftedType . idType) zonked_ids) ;
+ -- Bale out if errors; for example, error recovery when checking
+ -- the RHS of 'main' can mean that 'main' is not in the envt for
+ -- the subsequent checkMain test
+ failIfErrsM ;
- return (zonked_ids, zonked_expr)
- }
- where
- combine stmt (ids, stmts) = (ids, stmt:stmts)
- bad_unboxed id = addErr (sep [ptext SLIT("GHCi can't bind a variable of unlifted type:"),
- nest 2 (ppr id <+> dcolon <+> ppr (idType id))])
+ setEnvs tc_envs $
+
+ -- If there is no splice, we're nearly done
+ case group_tail of {
+ Nothing -> do { -- Last thing: check for `main'
+ tcg_env <- checkMain ;
+ return (tcg_env, tcl_env)
+ } ;
+
+ -- If there's a splice, we must carry on
+ Just (SpliceDecl splice_expr, rest_ds) -> do {
+#ifndef GHCI
+ failWithTc (text "Can't do a top-level splice; need a bootstrapped compiler")
+#else
+
+ -- Rename the splice expression, and get its supporting decls
+ (rn_splice_expr, splice_fvs) <- rnLExpr splice_expr ;
+ failIfErrsM ; -- Don't typecheck if renaming failed
+
+ -- Execute the splice
+ spliced_decls <- tcSpliceDecls rn_splice_expr ;
+
+ -- Glue them on the front of the remaining decls and loop
+ setGblEnv (tcg_env `addTcgDUs` usesOnly splice_fvs) $
+ tc_rn_src_decls (spliced_decls ++ rest_ds)
+#endif /* GHCI */
+ }}}
\end{code}
-tcRnExpr just finds the type of an expression
+%************************************************************************
+%* *
+ Type-checking the top level of a module
+%* *
+%************************************************************************
+
+tcRnGroup takes a bunch of top-level source-code declarations, and
+ * renames them
+ * gets supporting declarations from interface files
+ * typechecks them
+ * zonks them
+ * and augments the TcGblEnv with the results
+
+In Template Haskell it may be called repeatedly for each group of
+declarations. It expects there to be an incoming TcGblEnv in the
+monad; it augments it and returns the new TcGblEnv.
\begin{code}
-tcRnExpr :: HscEnv
- -> InteractiveContext
- -> LHsExpr RdrName
- -> IO (Maybe Type)
-tcRnExpr hsc_env ictxt rdr_expr
- = initTcPrintErrors hsc_env iNTERACTIVE $
- setInteractiveContext ictxt $ do {
+tcRnGroup :: HsGroup RdrName -> TcM (TcGblEnv, TcLclEnv)
+ -- Returns the variables free in the decls, for unused-binding reporting
+tcRnGroup decls
+ = do { -- Rename the declarations
+ (tcg_env, rn_decls) <- rnTopSrcDecls decls ;
+ setGblEnv tcg_env $ do {
- (rn_expr, fvs) <- rnLExpr rdr_expr ;
- failIfErrsM ;
+ -- Typecheck the declarations
+ tcTopSrcDecls rn_decls
+ }}
- -- Now typecheck the expression;
- -- it might have a rank-2 type (e.g. :t runST)
- ((tc_expr, res_ty), lie) <- getLIE (tcInferRho rn_expr) ;
- ((qtvs, _, dict_ids), lie_top) <- getLIE (tcSimplifyInfer smpl_doc (tyVarsOfType res_ty) lie) ;
- tcSimplifyInteractive lie_top ;
+------------------------------------------------
+rnTopSrcDecls :: HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name)
+rnTopSrcDecls group
+ = do { -- Bring top level binders into scope
+ (rdr_env, imports) <- importsFromLocalDecls group ;
+ updGblEnv (\gbl -> gbl { tcg_rdr_env = rdr_env `plusGlobalRdrEnv` tcg_rdr_env gbl,
+ tcg_imports = imports `plusImportAvails` tcg_imports gbl })
+ $ do {
- let { all_expr_ty = mkForAllTys qtvs $
- mkFunTys (map idType dict_ids) $
- res_ty } ;
- zonkTcType all_expr_ty
- }
- where
- smpl_doc = ptext SLIT("main expression")
-\end{code}
+ traceRn (ptext SLIT("rnTopSrcDecls") <+> ppr rdr_env) ;
+ failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations
-tcRnExpr just finds the kind of a type
+ -- Rename the source decls
+ (tcg_env, rn_decls) <- rnSrcDecls group ;
+ failIfErrsM ;
-\begin{code}
-tcRnType :: HscEnv
- -> InteractiveContext
- -> LHsType RdrName
- -> IO (Maybe Kind)
-tcRnType hsc_env ictxt rdr_type
- = initTcPrintErrors hsc_env iNTERACTIVE $
- setInteractiveContext ictxt $ do {
+ -- Dump trace of renaming part
+ rnDump (ppr rn_decls) ;
- rn_type <- rnLHsType doc rdr_type ;
- failIfErrsM ;
+ return (tcg_env, rn_decls)
+ }}
- -- Now kind-check the type
- (ty', kind) <- kcHsType rn_type ;
- return kind
- }
- where
- doc = ptext SLIT("In GHCi input")
-\end{code}
+------------------------------------------------
+tcTopSrcDecls :: HsGroup Name -> TcM (TcGblEnv, TcLclEnv)
+tcTopSrcDecls
+ (HsGroup { hs_tyclds = tycl_decls,
+ hs_instds = inst_decls,
+ hs_fords = foreign_decls,
+ hs_defds = default_decls,
+ hs_ruleds = rule_decls,
+ hs_valds = val_binds })
+ = do { -- Type-check the type and class decls, and all imported decls
+ -- The latter come in via tycl_decls
+ traceTc (text "Tc2") ;
-\begin{code}
-tcRnThing :: HscEnv
- -> InteractiveContext
- -> RdrName
- -> IO (Maybe [(IfaceDecl, Fixity, SrcLoc)])
--- Look up a RdrName and return all the TyThings it might be
--- A capitalised RdrName is given to us in the DataName namespace,
--- but we want to treat it as *both* a data constructor
--- *and* as a type or class constructor;
--- hence the call to dataTcOccs, and we return up to two results
-tcRnThing hsc_env ictxt rdr_name
- = initTcPrintErrors hsc_env iNTERACTIVE $
- setInteractiveContext ictxt $ do {
+ tcg_env <- checkNoErrs (tcTyAndClassDecls tycl_decls) ;
+ -- tcTyAndClassDecls recovers internally, but if anything gave rise to
+ -- an error we'd better stop now, to avoid a cascade
+
+ -- Make these type and class decls available to stuff slurped from interface files
+ writeMutVar (tcg_type_env_var tcg_env) (tcg_type_env tcg_env) ;
- -- If the identifier is a constructor (begins with an
- -- upper-case letter), then we need to consider both
- -- constructor and type class identifiers.
- let { rdr_names = dataTcOccs rdr_name } ;
- -- results :: [(Messages, Maybe Name)]
- results <- mapM (tryTc . lookupOccRn) rdr_names ;
+ setGblEnv tcg_env $ do {
+ -- Source-language instances, including derivings,
+ -- and import the supporting declarations
+ traceTc (text "Tc3") ;
+ (tcg_env, inst_infos, deriv_binds) <- tcInstDecls1 tycl_decls inst_decls ;
+ setGblEnv tcg_env $ do {
- -- The successful lookups will be (Just name)
- let { (warns_s, good_names) = unzip [ (msgs, name)
- | (msgs, Just name) <- results] ;
- errs_s = [msgs | (msgs, Nothing) <- results] } ;
+ -- Foreign import declarations next. No zonking necessary
+ -- here; we can tuck them straight into the global environment.
+ traceTc (text "Tc4") ;
+ (fi_ids, fi_decls) <- tcForeignImports foreign_decls ;
+ tcExtendGlobalValEnv fi_ids $ do {
- -- Fail if nothing good happened, else add warnings
- if null good_names then
- -- No lookup succeeded, so
- -- pick the first error message and report it
- -- ToDo: If one of the errors is "could be Foo.X or Baz.X",
- -- while the other is "X is not in scope",
- -- we definitely want the former; but we might pick the latter
- do { addMessages (head errs_s) ; failM }
- else -- Add deprecation warnings
- mapM_ addMessages warns_s ;
+ -- Default declarations
+ traceTc (text "Tc4a") ;
+ default_tys <- tcDefaults default_decls ;
+ updGblEnv (\gbl -> gbl { tcg_default = default_tys }) $ do {
- -- And lookup up the entities, avoiding duplicates, which arise
- -- because constructors and record selectors are represented by
- -- their parent declaration
- let { do_one name = do { thing <- tcLookupGlobal name
- ; let decl = toIfaceDecl ictxt thing
- ; fixity <- lookupFixityRn name
- ; return (decl, fixity, getSrcLoc thing) } ;
- -- For the SrcLoc, the 'thing' has better info than
- -- the 'name' because getting the former forced the
- -- declaration to be loaded into the cache
- cmp (d1,_,_) (d2,_,_) = ifName d1 `compare` ifName d2 } ;
- results <- mapM do_one good_names ;
- return (fst (removeDups cmp results))
- }
+ -- Value declarations next
+ -- We also typecheck any extra binds that came out
+ -- of the "deriving" process (deriv_binds)
+ traceTc (text "Tc5") ;
+ (tc_val_binds, lcl_env) <- tcTopBinds (val_binds ++ deriv_binds) ;
+ setLclTypeEnv lcl_env $ do {
-toIfaceDecl :: InteractiveContext -> TyThing -> IfaceDecl
-toIfaceDecl ictxt thing
- = tyThingToIfaceDecl True -- Discard IdInfo
- emptyNameSet -- Show data cons
- ext_nm (munge thing)
- where
- unqual = icPrintUnqual ictxt
- ext_nm n | unqual n = LocalTop (nameOccName n) -- What a hack
- | otherwise = ExtPkg (nameModuleName n) (nameOccName n)
+ -- Second pass over class and instance declarations,
+ traceTc (text "Tc6") ;
+ (tcl_env, inst_binds) <- tcInstDecls2 tycl_decls inst_infos ;
+ showLIE (text "after instDecls2") ;
- -- munge transforms a thing to it's "parent" thing
- munge (ADataCon dc) = ATyCon (dataConTyCon dc)
- munge (AnId id) = case globalIdDetails id of
- RecordSelId lbl -> ATyCon (fieldLabelTyCon lbl)
- ClassOpId cls -> AClass cls
- other -> AnId id
- munge other_thing = other_thing
-\end{code}
+ -- Foreign exports
+ -- They need to be zonked, so we return them
+ traceTc (text "Tc7") ;
+ (foe_binds, foe_decls) <- tcForeignExports foreign_decls ;
+ -- Rules
+ rules <- tcRules rule_decls ;
-\begin{code}
-setInteractiveContext :: InteractiveContext -> TcRn a -> TcRn a
-setInteractiveContext icxt thing_inside
- = traceTc (text "setIC" <+> ppr (ic_type_env icxt)) `thenM_`
- (updGblEnv (\env -> env {tcg_rdr_env = ic_rn_gbl_env icxt,
- tcg_type_env = ic_type_env icxt}) $
- updLclEnv (\env -> env {tcl_rdr = ic_rn_local_env icxt}) $
- thing_inside)
-#endif /* GHCI */
+ -- Wrap up
+ traceTc (text "Tc7a") ;
+ tcg_env <- getGblEnv ;
+ let { all_binds = tc_val_binds `unionBags`
+ inst_binds `unionBags`
+ foe_binds ;
+
+ -- Extend the GblEnv with the (as yet un-zonked)
+ -- bindings, rules, foreign decls
+ tcg_env' = tcg_env { tcg_binds = tcg_binds tcg_env `unionBags` all_binds,
+ tcg_rules = tcg_rules tcg_env ++ rules,
+ tcg_fords = tcg_fords tcg_env ++ foe_decls ++ fi_decls } } ;
+ return (tcg_env', lcl_env)
+ }}}}}}
\end{code}
+
%************************************************************************
%* *
- Type-checking external-core modules
+ Checking for 'main'
%* *
%************************************************************************
\begin{code}
-tcRnExtCore :: HscEnv
- -> HsExtCore RdrName
- -> IO (Messages, Maybe ModGuts)
- -- Nothing => some error occurred
-
-tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds)
- -- The decls are IfaceDecls; all names are original names
- = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;
-
- initTc hsc_env this_mod $ do {
-
- let { ldecls = map noLoc decls } ;
+checkMain
+ = do { ghci_mode <- getGhciMode ;
+ tcg_env <- getGblEnv ;
- -- Deal with the type declarations; first bring their stuff
- -- into scope, then rname them, then type check them
- (rdr_env, imports) <- importsFromLocalDecls (mkFakeGroup ldecls) ;
+ mb_main_mod <- readMutVar v_MainModIs ;
+ mb_main_fn <- readMutVar v_MainFunIs ;
+ let { main_mod = case mb_main_mod of {
+ Just mod -> mkModuleName mod ;
+ Nothing -> mAIN_Name } ;
+ main_fn = case mb_main_fn of {
+ Just fn -> mkRdrUnqual (mkVarOcc (mkFastString fn)) ;
+ Nothing -> main_RDR_Unqual } } ;
+
+ check_main ghci_mode tcg_env main_mod main_fn
+ }
- updGblEnv (\gbl -> gbl { tcg_rdr_env = rdr_env `plusGlobalRdrEnv` tcg_rdr_env gbl,
- tcg_imports = imports `plusImportAvails` tcg_imports gbl })
- $ do {
- rn_decls <- rnTyClDecls ldecls ;
- failIfErrsM ;
+check_main ghci_mode tcg_env main_mod main_fn
+ -- If we are in module Main, check that 'main' is defined.
+ -- It may be imported from another module!
+ --
+ -- ToDo: We have to return the main_name separately, because it's a
+ -- bona fide 'use', and should be recorded as such, but the others
+ -- aren't
+ --
+ -- Blimey: a whole page of code to do this...
+ | mod_name /= main_mod
+ = return tcg_env
- -- Dump trace of renaming part
- rnDump (ppr rn_decls) ;
+ | otherwise
+ = addErrCtxt mainCtxt $
+ do { mb_main <- lookupSrcOcc_maybe main_fn
+ -- Check that 'main' is in scope
+ -- It might be imported from another module!
+ ; case mb_main of {
+ Nothing -> do { complain_no_main
+ ; return tcg_env } ;
+ Just main_name -> do
+ { let { rhs = nlHsApp (nlHsVar runIOName) (nlHsVar main_name) }
+ -- :Main.main :: IO () = runIO main
- -- Typecheck them all together so that
- -- any mutually recursive types are done right
- tcg_env <- checkNoErrs (tcTyAndClassDecls rn_decls) ;
- -- Make the new type env available to stuff slurped from interface files
+ ; (main_expr, ty) <- addSrcSpan (srcLocSpan (getSrcLoc main_name)) $
+ tcInferRho rhs
- setGblEnv tcg_env $ do {
-
- -- Now the core bindings
- core_binds <- initIfaceExtCore (tcExtCoreBindings this_mod src_binds) ;
+ ; let { root_main_id = mkExportedLocalId rootMainName ty ;
+ main_bind = noLoc (VarBind root_main_id main_expr) }
- -- Wrap up
- let {
- bndrs = bindersOfBinds core_binds ;
- my_exports = mkNameSet (map idName bndrs) ;
- -- ToDo: export the data types also?
+ ; return (tcg_env { tcg_binds = tcg_binds tcg_env
+ `snocBag` main_bind,
+ tcg_dus = tcg_dus tcg_env
+ `plusDU` usesOnly (unitFV main_name)
+ })
+ }}}
+ where
+ mod_name = moduleName (tcg_mod tcg_env)
+
+ complain_no_main | ghci_mode == Interactive = return ()
+ | otherwise = failWithTc noMainMsg
+ -- In interactive mode, don't worry about the absence of 'main'
+ -- In other modes, fail altogether, so that we don't go on
+ -- and complain a second time when processing the export list.
- final_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) bndrs ;
+ mainCtxt = ptext SLIT("When checking the type of the main function") <+> quotes (ppr main_fn)
+ noMainMsg = ptext SLIT("The main function") <+> quotes (ppr main_fn)
+ <+> ptext SLIT("is not defined in module") <+> quotes (ppr main_mod)
+\end{code}
- mod_guts = ModGuts { mg_module = this_mod,
- mg_usages = [], -- ToDo: compute usage
- mg_dir_imps = [], -- ??
- mg_deps = noDependencies, -- ??
- mg_exports = my_exports,
- mg_types = final_type_env,
- mg_insts = tcg_insts tcg_env,
- mg_rules = [],
- mg_binds = core_binds,
- -- Stubs
- mg_rdr_env = emptyGlobalRdrEnv,
- mg_fix_env = emptyFixityEnv,
- mg_deprecs = NoDeprecs,
- mg_foreign = NoStubs
- } } ;
+%*********************************************************
+%* *
+ GHCi stuff
+%* *
+%*********************************************************
- tcCoreDump mod_guts ;
+\begin{code}
+#ifdef GHCI
+setInteractiveContext :: InteractiveContext -> TcRn a -> TcRn a
+setInteractiveContext icxt thing_inside
+ = traceTc (text "setIC" <+> ppr (ic_type_env icxt)) `thenM_`
+ (updGblEnv (\env -> env {tcg_rdr_env = ic_rn_gbl_env icxt,
+ tcg_type_env = ic_type_env icxt}) $
+ updLclEnv (\env -> env {tcl_rdr = ic_rn_local_env icxt}) $
+ thing_inside)
+\end{code}
- return mod_guts
- }}}}
-mkFakeGroup decls -- Rather clumsy; lots of unused fields
- = HsGroup { hs_tyclds = decls, -- This is the one we want
- hs_valds = [], hs_fords = [],
- hs_instds = [], hs_fixds = [], hs_depds = [],
- hs_ruleds = [], hs_defds = [] }
-\end{code}
+\begin{code}
+tcRnStmt :: HscEnv
+ -> InteractiveContext
+ -> LStmt RdrName
+ -> IO (Maybe (InteractiveContext, [Name], LHsExpr Id))
+ -- The returned [Name] is the same as the input except for
+ -- ExprStmt, in which case the returned [Name] is [itName]
+ --
+ -- The returned TypecheckedHsExpr is of type IO [ () ],
+ -- a list of the bound values, coerced to ().
+tcRnStmt hsc_env ictxt rdr_stmt
+ = initTcPrintErrors hsc_env iNTERACTIVE $
+ setInteractiveContext ictxt $ do {
-%************************************************************************
-%* *
- Type-checking the top level of a module
-%* *
-%************************************************************************
+ -- Rename; use CmdLineMode because tcRnStmt is only used interactively
+ ([rn_stmt], fvs) <- rnStmts DoExpr [rdr_stmt] ;
+ traceRn (text "tcRnStmt" <+> vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs]) ;
+ failIfErrsM ;
+
+ -- The real work is done here
+ (bound_ids, tc_expr) <- tcUserStmt rn_stmt ;
+
+ traceTc (text "tcs 1") ;
+ let { -- Make all the bound ids "global" ids, now that
+ -- they're notionally top-level bindings. This is
+ -- important: otherwise when we come to compile an expression
+ -- using these ids later, the byte code generator will consider
+ -- the occurrences to be free rather than global.
+ global_ids = map (globaliseId VanillaGlobal) bound_ids ;
+
+ -- Update the interactive context
+ rn_env = ic_rn_local_env ictxt ;
+ type_env = ic_type_env ictxt ;
-\begin{code}
-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
- (tc_envs, lie) <- getLIE (tc_rn_src_decls decls) ;
+ bound_names = map idName global_ids ;
+ new_rn_env = extendLocalRdrEnv rn_env bound_names ;
- -- tcSimplifyTop deals with constant or ambiguous InstIds.
- -- How could there be ambiguous ones? They can only arise if a
- -- top-level decl falls under the monomorphism
- -- restriction, and no subsequent decl instantiates its
- -- type. (Usually, ambiguous type variables are resolved
- -- during the generalisation step.)
- traceTc (text "Tc8") ;
- inst_binds <- setEnvs tc_envs (tcSimplifyTop lie) ;
- -- Setting the global env exposes the instances to tcSimplifyTop
- -- Setting the local env exposes the local Ids to tcSimplifyTop,
- -- so that we get better error messages (monomorphism restriction)
+ -- Remove any shadowed bindings from the type_env;
+ -- they are inaccessible but might, I suppose, cause
+ -- a space leak if we leave them there
+ shadowed = [ n | name <- bound_names,
+ let rdr_name = mkRdrUnqual (nameOccName name),
+ Just n <- [lookupLocalRdrEnv rn_env rdr_name] ] ;
- -- Backsubstitution. This must be done last.
- -- Even tcSimplifyTop may do some unification.
- traceTc (text "Tc9") ;
- let { (tcg_env, _) = tc_envs ;
- TcGblEnv { tcg_type_env = type_env, tcg_binds = binds,
- tcg_rules = rules, tcg_fords = fords } = tcg_env } ;
+ filtered_type_env = delListFromNameEnv type_env shadowed ;
+ new_type_env = extendTypeEnvWithIds filtered_type_env global_ids ;
- (bind_ids, binds', fords', rules') <- zonkTopDecls (binds `unionBags` inst_binds)
- rules fords ;
+ new_ic = ictxt { ic_rn_local_env = new_rn_env,
+ ic_type_env = new_type_env }
+ } ;
- let { final_type_env = extendTypeEnvWithIds type_env bind_ids } ;
+ dumpOptTcRn Opt_D_dump_tc
+ (vcat [text "Bound Ids" <+> pprWithCommas ppr global_ids,
+ text "Typechecked expr" <+> ppr tc_expr]) ;
- -- Make the new type env available to stuff slurped from interface files
- writeMutVar (tcg_type_env_var tcg_env) final_type_env ;
+ returnM (new_ic, bound_names, tc_expr)
+ }
+\end{code}
- return (tcg_env { tcg_type_env = final_type_env,
- tcg_binds = binds', tcg_rules = rules', tcg_fords = fords' })
- }
-tc_rn_src_decls :: [LHsDecl RdrName] -> TcM (TcGblEnv, TcLclEnv)
--- Loops around dealing with each top level inter-splice group
--- in turn, until it's dealt with the entire module
-tc_rn_src_decls ds
- = do { let { (first_group, group_tail) = findSplice ds } ;
- -- If ds is [] we get ([], Nothing)
+Here is the grand plan, implemented in tcUserStmt
- -- Type check the decls up to, but not including, the first splice
- tc_envs@(tcg_env,tcl_env) <- tcRnGroup first_group ;
+ What you type The IO [HValue] that hscStmt returns
+ ------------- ------------------------------------
+ let pat = expr ==> let pat = expr in return [coerce HVal x, coerce HVal y, ...]
+ bindings: [x,y,...]
- -- Bale out if errors; for example, error recovery when checking
- -- the RHS of 'main' can mean that 'main' is not in the envt for
- -- the subsequent checkMain test
- failIfErrsM ;
+ pat <- expr ==> expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...]
+ bindings: [x,y,...]
- setEnvs tc_envs $
+ expr (of IO type) ==> expr >>= \ it -> return [coerce HVal it]
+ [NB: result not printed] bindings: [it]
+
+ expr (of non-IO type, ==> let it = expr in print it >> return [coerce HVal it]
+ result showable) bindings: [it]
- -- If there is no splice, we're nearly done
- case group_tail of {
- Nothing -> do { -- Last thing: check for `main'
- tcg_env <- checkMain ;
- return (tcg_env, tcl_env)
- } ;
+ expr (of non-IO type,
+ result not showable) ==> error
- -- If there's a splice, we must carry on
- Just (SpliceDecl splice_expr, rest_ds) -> do {
-#ifndef GHCI
- failWithTc (text "Can't do a top-level splice; need a bootstrapped compiler")
-#else
- -- Rename the splice expression, and get its supporting decls
- (rn_splice_expr, splice_fvs) <- rnLExpr splice_expr ;
- failIfErrsM ; -- Don't typecheck if renaming failed
+\begin{code}
+---------------------------
+tcUserStmt :: LStmt Name -> TcM ([Id], LHsExpr Id)
+tcUserStmt (L _ (ExprStmt expr _))
+ = newUnique `thenM` \ uniq ->
+ let
+ fresh_it = itName uniq
+ the_bind = noLoc $ FunBind (noLoc fresh_it) False
+ [ mkSimpleMatch [] expr placeHolderType ]
+ in
+ tryTcLIE_ (do { -- Try this if the other fails
+ traceTc (text "tcs 1b") ;
+ tc_stmts [
+ nlLetStmt [HsBindGroup (unitBag the_bind) [] NonRecursive],
+ nlExprStmt (nlHsApp (nlHsVar printName)
+ (nlHsVar fresh_it))
+ ] })
+ (do { -- Try this first
+ traceTc (text "tcs 1a") ;
+ tc_stmts [nlBindStmt (nlVarPat fresh_it) expr] })
- -- Execute the splice
- spliced_decls <- tcSpliceDecls rn_splice_expr ;
+tcUserStmt stmt = tc_stmts [stmt]
- -- Glue them on the front of the remaining decls and loop
- setGblEnv (tcg_env `addTcgDUs` usesOnly splice_fvs) $
- tc_rn_src_decls (spliced_decls ++ rest_ds)
-#endif /* GHCI */
- }}}
-\end{code}
+---------------------------
+tc_stmts stmts
+ = do { ioTyCon <- tcLookupTyCon ioTyConName ;
+ let {
+ ret_ty = mkListTy unitTy ;
+ io_ret_ty = mkTyConApp ioTyCon [ret_ty] ;
+ names = map unLoc (collectStmtsBinders stmts) ;
-%************************************************************************
-%* *
- Type-checking the top level of a module
-%* *
-%************************************************************************
+ stmt_ctxt = SC { sc_what = DoExpr,
+ sc_rhs = check_rhs,
+ sc_body = check_body,
+ sc_ty = ret_ty } ;
-tcRnGroup takes a bunch of top-level source-code declarations, and
- * renames them
- * gets supporting declarations from interface files
- * typechecks them
- * zonks them
- * and augments the TcGblEnv with the results
+ check_rhs rhs rhs_ty = tcCheckRho rhs (mkTyConApp ioTyCon [rhs_ty]) ;
+ check_body body = tcCheckRho body io_ret_ty ;
-In Template Haskell it may be called repeatedly for each group of
-declarations. It expects there to be an incoming TcGblEnv in the
-monad; it augments it and returns the new TcGblEnv.
+ -- mk_return builds the expression
+ -- returnIO @ [()] [coerce () x, .., coerce () z]
+ --
+ -- Despite the inconvenience of building the type applications etc,
+ -- this *has* to be done in type-annotated post-typecheck form
+ -- because we are going to return a list of *polymorphic* values
+ -- coerced to type (). If we built a *source* stmt
+ -- return [coerce x, ..., coerce z]
+ -- then the type checker would instantiate x..z, and we wouldn't
+ -- get their *polymorphic* values. (And we'd get ambiguity errs
+ -- if they were overloaded, since they aren't applied to anything.)
+ mk_return ret_id ids = nlHsApp (noLoc $ TyApp (nlHsVar ret_id) [ret_ty])
+ (noLoc $ ExplicitList unitTy (map mk_item ids)) ;
+ mk_item id = nlHsApp (noLoc $ TyApp (nlHsVar unsafeCoerceId) [idType id, unitTy])
+ (nlHsVar id) ;
-\begin{code}
-tcRnGroup :: HsGroup RdrName -> TcM (TcGblEnv, TcLclEnv)
- -- Returns the variables free in the decls, for unused-binding reporting
-tcRnGroup decls
- = do { -- Rename the declarations
- (tcg_env, rn_decls) <- rnTopSrcDecls decls ;
- setGblEnv tcg_env $ do {
+ io_ty = mkTyConApp ioTyCon []
+ } ;
- -- Typecheck the declarations
- tcTopSrcDecls rn_decls
- }}
+ -- OK, we're ready to typecheck the stmts
+ traceTc (text "tcs 2") ;
+ ((ids, tc_expr), lie) <- getLIE $ do {
+ (ids, tc_stmts) <- tcStmtsAndThen combine stmt_ctxt stmts $
+ do {
+ -- Look up the names right in the middle,
+ -- where they will all be in scope
+ ids <- mappM tcLookupId names ;
+ ret_id <- tcLookupId returnIOName ; -- return @ IO
+ return (ids, [nlResultStmt (mk_return ret_id ids)]) } ;
-------------------------------------------------
-rnTopSrcDecls :: HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name)
-rnTopSrcDecls group
- = do { -- Bring top level binders into scope
- (rdr_env, imports) <- importsFromLocalDecls group ;
- updGblEnv (\gbl -> gbl { tcg_rdr_env = rdr_env `plusGlobalRdrEnv` tcg_rdr_env gbl,
- tcg_imports = imports `plusImportAvails` tcg_imports gbl })
- $ do {
+ io_ids <- mappM (tcStdSyntaxName DoOrigin io_ty) monadNames ;
+ return (ids, noLoc (HsDo DoExpr tc_stmts io_ids io_ret_ty))
+ } ;
- traceRn (ptext SLIT("rnTopSrcDecls") <+> ppr rdr_env) ;
- failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations
+ -- Simplify the context right here, so that we fail
+ -- if there aren't enough instances. Notably, when we see
+ -- e
+ -- we use recoverTc_ to try it <- e
+ -- and then let it = e
+ -- It's the simplify step that rejects the first.
+ traceTc (text "tcs 3") ;
+ const_binds <- tcSimplifyInteractive lie ;
- -- Rename the source decls
- (tcg_env, rn_decls) <- rnSrcDecls group ;
- failIfErrsM ;
+ -- Build result expression and zonk it
+ let { expr = mkHsLet const_binds tc_expr } ;
+ zonked_expr <- zonkTopLExpr expr ;
+ zonked_ids <- zonkTopBndrs ids ;
- -- Dump trace of renaming part
- rnDump (ppr rn_decls) ;
+ -- None of the Ids should be of unboxed type, because we
+ -- cast them all to HValues in the end!
+ mappM bad_unboxed (filter (isUnLiftedType . idType) zonked_ids) ;
- return (tcg_env, rn_decls)
- }}
+ return (zonked_ids, zonked_expr)
+ }
+ where
+ combine stmt (ids, stmts) = (ids, stmt:stmts)
+ bad_unboxed id = addErr (sep [ptext SLIT("GHCi can't bind a variable of unlifted type:"),
+ nest 2 (ppr id <+> dcolon <+> ppr (idType id))])
+\end{code}
-------------------------------------------------
-tcTopSrcDecls :: HsGroup Name -> TcM (TcGblEnv, TcLclEnv)
-tcTopSrcDecls
- (HsGroup { hs_tyclds = tycl_decls,
- hs_instds = inst_decls,
- hs_fords = foreign_decls,
- hs_defds = default_decls,
- hs_ruleds = rule_decls,
- hs_valds = val_binds })
- = do { -- Type-check the type and class decls, and all imported decls
- -- The latter come in via tycl_decls
- traceTc (text "Tc2") ;
- tcg_env <- checkNoErrs (tcTyAndClassDecls tycl_decls) ;
- -- tcTyAndClassDecls recovers internally, but if anything gave rise to
- -- an error we'd better stop now, to avoid a cascade
-
- -- Make these type and class decls available to stuff slurped from interface files
- writeMutVar (tcg_type_env_var tcg_env) (tcg_type_env tcg_env) ;
+tcRnExpr just finds the type of an expression
+\begin{code}
+tcRnExpr :: HscEnv
+ -> InteractiveContext
+ -> LHsExpr RdrName
+ -> IO (Maybe Type)
+tcRnExpr hsc_env ictxt rdr_expr
+ = initTcPrintErrors hsc_env iNTERACTIVE $
+ setInteractiveContext ictxt $ do {
- setGblEnv tcg_env $ do {
- -- Source-language instances, including derivings,
- -- and import the supporting declarations
- traceTc (text "Tc3") ;
- (tcg_env, inst_infos, deriv_binds) <- tcInstDecls1 tycl_decls inst_decls ;
- setGblEnv tcg_env $ do {
+ (rn_expr, fvs) <- rnLExpr rdr_expr ;
+ failIfErrsM ;
- -- Foreign import declarations next. No zonking necessary
- -- here; we can tuck them straight into the global environment.
- traceTc (text "Tc4") ;
- (fi_ids, fi_decls) <- tcForeignImports foreign_decls ;
- tcExtendGlobalValEnv fi_ids $ do {
+ -- Now typecheck the expression;
+ -- it might have a rank-2 type (e.g. :t runST)
+ ((tc_expr, res_ty), lie) <- getLIE (tcInferRho rn_expr) ;
+ ((qtvs, _, dict_ids), lie_top) <- getLIE (tcSimplifyInfer smpl_doc (tyVarsOfType res_ty) lie) ;
+ tcSimplifyInteractive lie_top ;
- -- Default declarations
- traceTc (text "Tc4a") ;
- default_tys <- tcDefaults default_decls ;
- updGblEnv (\gbl -> gbl { tcg_default = default_tys }) $ do {
-
- -- Value declarations next
- -- We also typecheck any extra binds that came out
- -- of the "deriving" process (deriv_binds)
- traceTc (text "Tc5") ;
- (tc_val_binds, lcl_env) <- tcTopBinds (val_binds ++ deriv_binds) ;
- setLclTypeEnv lcl_env $ do {
+ let { all_expr_ty = mkForAllTys qtvs $
+ mkFunTys (map idType dict_ids) $
+ res_ty } ;
+ zonkTcType all_expr_ty
+ }
+ where
+ smpl_doc = ptext SLIT("main expression")
+\end{code}
- -- Second pass over class and instance declarations,
- traceTc (text "Tc6") ;
- (tcl_env, inst_binds) <- tcInstDecls2 tycl_decls inst_infos ;
- showLIE (text "after instDecls2") ;
+tcRnExpr just finds the kind of a type
- -- Foreign exports
- -- They need to be zonked, so we return them
- traceTc (text "Tc7") ;
- (foe_binds, foe_decls) <- tcForeignExports foreign_decls ;
+\begin{code}
+tcRnType :: HscEnv
+ -> InteractiveContext
+ -> LHsType RdrName
+ -> IO (Maybe Kind)
+tcRnType hsc_env ictxt rdr_type
+ = initTcPrintErrors hsc_env iNTERACTIVE $
+ setInteractiveContext ictxt $ do {
- -- Rules
- rules <- tcRules rule_decls ;
+ rn_type <- rnLHsType doc rdr_type ;
+ failIfErrsM ;
- -- Wrap up
- traceTc (text "Tc7a") ;
- tcg_env <- getGblEnv ;
- let { all_binds = tc_val_binds `unionBags`
- inst_binds `unionBags`
- foe_binds ;
+ -- Now kind-check the type
+ (ty', kind) <- kcHsType rn_type ;
+ return kind
+ }
+ where
+ doc = ptext SLIT("In GHCi input")
- -- Extend the GblEnv with the (as yet un-zonked)
- -- bindings, rules, foreign decls
- tcg_env' = tcg_env { tcg_binds = tcg_binds tcg_env `unionBags` all_binds,
- tcg_rules = tcg_rules tcg_env ++ rules,
- tcg_fords = tcg_fords tcg_env ++ foe_decls ++ fi_decls } } ;
- return (tcg_env', lcl_env)
- }}}}}}
+#endif /* GHCi */
\end{code}
-%*********************************************************
-%* *
- mkGlobalContext: make up an interactive context
-
- Used for initialising the lexical environment
- of the interactive read-eval-print loop
-%* *
-%*********************************************************
+%************************************************************************
+%* *
+ More GHCi stuff, to do with browsing and getting info
+%* *
+%************************************************************************
\begin{code}
#ifdef GHCI
mkExportEnv :: HscEnv -> [ModuleName] -- Expose these modules' exports only
-> IO GlobalRdrEnv
-
mkExportEnv hsc_env exports
= do { mb_envs <- initTcPrintErrors hsc_env iNTERACTIVE $
mappM getModuleExports exports
-- so it had better be a home module
= do { hpt <- getHpt
; case lookupModuleEnvByName hpt mod of
- Just mod_info -> return (map (toIfaceDecl ictxt) $
+ Just mod_info -> return (map toIfaceDecl $
filter wantToSee $
typeEnvElts $
md_types (hm_details mod_info))
get_decl avail
= do { thing <- tcLookupGlobal (availName avail)
- ; return (filter_decl (availOccs avail) (toIfaceDecl ictxt thing)) }
+ ; return (filter_decl (availOccs avail) (toIfaceDecl thing)) }
---------------------
filter_decl occs decl@(IfaceClass {ifSigs = sigs})
---------------------
noRdrEnvErr mod = ptext SLIT("No top-level environment available for module")
<+> quotes (ppr mod)
-#endif
\end{code}
-%************************************************************************
-%* *
- Checking for 'main'
-%* *
-%************************************************************************
-
\begin{code}
-checkMain
- = do { ghci_mode <- getGhciMode ;
- tcg_env <- getGblEnv ;
+tcRnGetInfo :: HscEnv
+ -> InteractiveContext
+ -> RdrName
+ -> IO (Maybe [(IfaceDecl,
+ Fixity, SrcLoc,
+ [(IfaceInst, SrcLoc)])])
+-- Used to implemnent :info in GHCi
+--
+-- Look up a RdrName and return all the TyThings it might be
+-- A capitalised RdrName is given to us in the DataName namespace,
+-- but we want to treat it as *both* a data constructor
+-- *and* as a type or class constructor;
+-- hence the call to dataTcOccs, and we return up to two results
+tcRnGetInfo hsc_env ictxt rdr_name
+ = initTcPrintErrors hsc_env iNTERACTIVE $
+ setInteractiveContext ictxt $ do {
- mb_main_mod <- readMutVar v_MainModIs ;
- mb_main_fn <- readMutVar v_MainFunIs ;
- let { main_mod = case mb_main_mod of {
- Just mod -> mkModuleName mod ;
- Nothing -> mAIN_Name } ;
- main_fn = case mb_main_fn of {
- Just fn -> mkRdrUnqual (mkVarOcc (mkFastString fn)) ;
- Nothing -> main_RDR_Unqual } } ;
-
- check_main ghci_mode tcg_env main_mod main_fn
- }
+ -- If the identifier is a constructor (begins with an
+ -- upper-case letter), then we need to consider both
+ -- constructor and type class identifiers.
+ let { rdr_names = dataTcOccs rdr_name } ;
+ -- results :: [(Messages, Maybe Name)]
+ results <- mapM (tryTc . lookupOccRn) rdr_names ;
-check_main ghci_mode tcg_env main_mod main_fn
- -- If we are in module Main, check that 'main' is defined.
- -- It may be imported from another module!
- --
- -- ToDo: We have to return the main_name separately, because it's a
- -- bona fide 'use', and should be recorded as such, but the others
- -- aren't
- --
- -- Blimey: a whole page of code to do this...
- | mod_name /= main_mod
- = return tcg_env
+ traceRn (text "xx" <+> vcat [ppr rdr_names, ppr (map snd results)]);
+ -- The successful lookups will be (Just name)
+ let { (warns_s, good_names) = unzip [ (msgs, name)
+ | (msgs, Just name) <- results] ;
+ errs_s = [msgs | (msgs, Nothing) <- results] } ;
- | otherwise
- = addErrCtxt mainCtxt $
- do { mb_main <- lookupSrcOcc_maybe main_fn
- -- Check that 'main' is in scope
- -- It might be imported from another module!
- ; case mb_main of {
- Nothing -> do { complain_no_main
- ; return tcg_env } ;
- Just main_name -> do
- { let { rhs = nlHsApp (nlHsVar runIOName) (nlHsVar main_name) }
- -- :Main.main :: IO () = runIO main
+ -- Fail if nothing good happened, else add warnings
+ if null good_names then
+ -- No lookup succeeded, so
+ -- pick the first error message and report it
+ -- ToDo: If one of the errors is "could be Foo.X or Baz.X",
+ -- while the other is "X is not in scope",
+ -- we definitely want the former; but we might pick the latter
+ do { addMessages (head errs_s) ; failM }
+ else -- Add deprecation warnings
+ mapM_ addMessages warns_s ;
+
+ -- And lookup up the entities, avoiding duplicates, which arise
+ -- because constructors and record selectors are represented by
+ -- their parent declaration
+ let { do_one name = do { thing <- tcLookupGlobal name
+ ; let decl = toIfaceDecl thing
+ ; fixity <- lookupFixityRn name
+ ; insts <- lookupInsts thing
+ ; return (decl, fixity, getSrcLoc thing,
+ map mk_inst insts) } ;
+ -- For the SrcLoc, the 'thing' has better info than
+ -- the 'name' because getting the former forced the
+ -- declaration to be loaded into the cache
+ mk_inst dfun = (dfunToIfaceInst dfun, getSrcLoc dfun) ;
+ cmp (d1,_,_,_) (d2,_,_,_) = ifName d1 `compare` ifName d2 } ;
+ results <- mapM do_one good_names ;
+ return (fst (removeDups cmp results))
+ }
- ; (main_expr, ty) <- addSrcSpan (srcLocSpan (getSrcLoc main_name)) $
- tcInferRho rhs
+lookupInsts :: TyThing -> TcM [DFunId]
+lookupInsts (AClass cls)
+ = do { loadImportedInsts cls [] -- [] means load all instances for cls
+ ; inst_envs <- tcGetInstEnvs
+ ; return [df | (_,_,df) <- classInstances inst_envs cls] }
+
+lookupInsts (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
+ ; mapM_ (\c -> loadImportedInsts c [])
+ (typeEnvClasses (eps_PTE eps))
+ ; (pkg_ie, home_ie) <- tcGetInstEnvs -- Search all
+ ; return (get home_ie ++ get pkg_ie) }
+ where
+ get ie = [df | (_,_,df) <- instEnvElts ie, relevant df]
+ relevant df = tc_name `elemNameSet` tyClsNamesOfDFunHead (idType df)
+ tc_name = tyConName tc
- ; let { root_main_id = mkExportedLocalId rootMainName ty ;
- main_bind = noLoc (VarBind root_main_id main_expr) }
+lookupInsts other = return []
- ; return (tcg_env { tcg_binds = tcg_binds tcg_env
- `snocBag` main_bind,
- tcg_dus = tcg_dus tcg_env
- `plusDU` usesOnly (unitFV main_name)
- })
- }}}
+
+toIfaceDecl :: TyThing -> IfaceDecl
+toIfaceDecl thing
+ = tyThingToIfaceDecl True -- Discard IdInfo
+ emptyNameSet -- Show data cons
+ ext_nm (munge thing)
where
- mod_name = moduleName (tcg_mod tcg_env)
-
- complain_no_main | ghci_mode == Interactive = return ()
- | otherwise = failWithTc noMainMsg
- -- In interactive mode, don't worry about the absence of 'main'
- -- In other modes, fail altogether, so that we don't go on
- -- and complain a second time when processing the export list.
+ ext_nm n = ExtPkg (nameModuleName n) (nameOccName n)
- mainCtxt = ptext SLIT("When checking the type of the main function") <+> quotes (ppr main_fn)
- noMainMsg = ptext SLIT("The main function") <+> quotes (ppr main_fn)
- <+> ptext SLIT("is not defined in module") <+> quotes (ppr main_mod)
-\end{code}
+ -- munge transforms a thing to it's "parent" thing
+ munge (ADataCon dc) = ATyCon (dataConTyCon dc)
+ munge (AnId id) = case globalIdDetails id of
+ RecordSelId lbl -> ATyCon (fieldLabelTyCon lbl)
+ ClassOpId cls -> AClass cls
+ other -> AnId id
+ munge other_thing = other_thing
+#endif /* GHCI */
+\end{code}
%************************************************************************
%* *
getEps :: TcRnIf gbl lcl ExternalPackageState
getEps = do { env <- getTopEnv; readMutVar (hsc_EPS env) }
-setEps :: ExternalPackageState -> TcRnIf gbl lcl ()
-setEps eps = do { env <- getTopEnv; writeMutVar (hsc_EPS env) eps }
+-- Updating the EPS. This should be an atomic operation.
+-- Note the delicate 'seq' which forces the EPS before putting it in the
+-- variable. Otherwise what happens is that we get
+-- write eps_var (....(unsafeRead eps_var)....)
+-- and if the .... is strict, that's obviously bottom. By forcing it beforehand
+-- we make the unsafeRead happen before we update the variable.
updateEps :: (ExternalPackageState -> (ExternalPackageState, a))
-> TcRnIf gbl lcl a
-updateEps upd_fn = do { eps_var <- getEpsVar
+updateEps upd_fn = do { traceIf (text "updating EPS")
+ ; eps_var <- getEpsVar
; eps <- readMutVar eps_var
; let { (eps', val) = upd_fn eps }
- ; writeMutVar eps_var eps'
+ ; seq eps' (writeMutVar eps_var eps')
; return val }
updateEps_ :: (ExternalPackageState -> ExternalPackageState)
-> TcRnIf gbl lcl ()
-updateEps_ upd_fn = do { eps_var <- getEpsVar
- ; updMutVar eps_var upd_fn }
+updateEps_ upd_fn = do { traceIf (text "updating EPS_")
+ ; eps_var <- getEpsVar
+ ; eps <- readMutVar eps_var
+ ; let { eps' = upd_fn eps }
+ ; seq eps' (writeMutVar eps_var eps') }
getHpt :: TcRnIf gbl lcl HomePackageTable
getHpt = do { env <- getTopEnv; return (hsc_HPT env) }
initIfaceTcRn thing_inside
= do { tcg_env <- getGblEnv
; let { if_env = IfGblEnv {
- if_rec_types = Just (tcg_mod tcg_env, get_type_env),
- if_is_boot = imp_dep_mods (tcg_imports tcg_env) }
+ if_rec_types = Just (tcg_mod tcg_env, get_type_env) }
; get_type_env = readMutVar (tcg_type_env_var tcg_env) }
; setEnvs (if_env, ()) thing_inside }
= do { tcg_env <- getGblEnv
; let { mod = tcg_mod tcg_env
; if_env = IfGblEnv {
- if_rec_types = Just (mod, return (tcg_type_env tcg_env)),
- if_is_boot = imp_dep_mods (tcg_imports tcg_env) }
+ if_rec_types = Just (mod, return (tcg_type_env tcg_env)) }
; if_lenv = IfLclEnv { if_mod = moduleName mod,
if_tv_env = emptyOccEnv,
if_id_env = emptyOccEnv }
-- Used when checking the up-to-date-ness of the old Iface
-- Initialise the environment with no useful info at all
initIfaceCheck hsc_env do_this
- = do { let { gbl_env = IfGblEnv { if_is_boot = emptyModuleEnv,
- if_rec_types = Nothing } ;
+ = do { let { gbl_env = IfGblEnv { if_rec_types = Nothing } ;
}
; initTcRnIf 'i' hsc_env gbl_env () do_this
}
-- No type envt from the current module, but we do know the module dependencies
initIfaceTc hsc_env iface do_this
= do { tc_env_var <- newIORef emptyTypeEnv
- ; let { gbl_env = IfGblEnv { if_is_boot = mkModDeps (dep_mods (mi_deps iface)),
- if_rec_types = Just (mod, readMutVar tc_env_var) } ;
+ ; let { gbl_env = IfGblEnv { if_rec_types = Just (mod, readMutVar tc_env_var) } ;
; if_lenv = IfLclEnv { if_mod = moduleName mod,
if_tv_env = emptyOccEnv,
if_id_env = emptyOccEnv }
-- We have available the type envt of the module being compiled, and we must use it
initIfaceRules hsc_env guts do_this
= do { let {
- is_boot = mkModDeps (dep_mods (mg_deps guts))
- -- Urgh! But we do somehow need to get the info
- -- on whether (for this particular compilation) we should
- -- import a hi-boot file or not.
- ; type_info = (mg_module guts, return (mg_types guts))
- ; gbl_env = IfGblEnv { if_is_boot = is_boot,
- if_rec_types = Just type_info } ;
+ type_info = (mg_module guts, return (mg_types guts))
+ ; gbl_env = IfGblEnv { if_rec_types = Just type_info } ;
}
-- Run the thing; any exceptions just bubble out from here
-- was originally a hi-boot file.
-- We need the module name so we can test when it's appropriate
-- to look in this env.
- if_rec_types :: Maybe (Module, IfG TypeEnv),
+ if_rec_types :: Maybe (Module, IfG TypeEnv)
-- Allows a read effect, so it can be in a mutable
-- variable; c.f. handling the external package type env
-- Nothing => interactive stuff, no loops possible
-
- if_is_boot :: ModuleEnv (ModuleName, IsBootInterface)
- -- Tells what we know about boot interface files
- -- When we're importing a module we know absolutely
- -- nothing about, so we assume it's from
- -- another package, where we aren't doing
- -- dependency tracking. So it won't be a hi-boot file.
}
data IfLclEnv
tcImprove :: Avails -> TcM Bool -- False <=> no change
-- Perform improvement using all the predicates in Avails
tcImprove avails
- = tcGetInstEnvs `thenM` \ (home_ie, pkg_ie) ->
+ = tcGetInstEnvs `thenM` \ inst_envs ->
let
preds = [ (pred, pp_loc)
| inst <- keysFM avails,
-- NB that (?x::t1) and (?x::t2) will be held separately in avails
-- so that improve will see them separate
eqns = improve get_insts preds
- get_insts clas = classInstances home_ie clas ++ classInstances pkg_ie clas
+ get_insts clas = classInstances inst_envs clas
in
if null eqns then
returnM True
DFunId, InstEnv,
emptyInstEnv, extendInstEnv,
- lookupInstEnv,
+ lookupInstEnv, instEnvElts,
classInstances, simpleDFunClassTyCon, checkFunDeps
) where
import FunDeps ( checkClsFD )
import TyCon ( TyCon )
import Outputable
-import UniqFM ( UniqFM, lookupUFM, emptyUFM, addToUFM_C )
+import UniqFM ( UniqFM, lookupUFM, emptyUFM, addToUFM_C, eltsUFM )
import Id ( idType )
import CmdLineOpts
import Util ( notNull )
emptyInstEnv :: InstEnv
emptyInstEnv = emptyUFM
-classInstances :: InstEnv -> Class -> [InstEnvElt]
-classInstances env cls = case lookupUFM env cls of
- Just (ClsIE insts _) -> insts
- Nothing -> []
+instEnvElts :: InstEnv -> [InstEnvElt]
+instEnvElts ie = [elt | ClsIE elts _ <- eltsUFM ie, elt <- elts]
+
+classInstances :: (InstEnv,InstEnv) -> Class -> [InstEnvElt]
+classInstances (pkg_ie, home_ie) cls
+ = get home_ie ++ get pkg_ie
+ where
+ get env = case lookupUFM env cls of
+ Just (ClsIE insts _) -> insts
+ Nothing -> []
extendInstEnv :: InstEnv -> DFunId -> InstEnv
extendInstEnv inst_env dfun_id
-> Maybe [DFunId] -- Nothing <=> ok
-- Just dfs <=> conflict with dfs
-- Check wheher adding DFunId would break functional-dependency constraints
-checkFunDeps (pkg_ie, home_ie) dfun
+checkFunDeps inst_envs dfun
| null bad_fundeps = Nothing
| otherwise = Just bad_fundeps
where
(ins_tvs, _, clas, ins_tys) = tcSplitDFunTy (idType dfun)
ins_tv_set = mkVarSet ins_tvs
- cls_inst_env = classInstances home_ie clas ++ classInstances pkg_ie clas
+ cls_inst_env = classInstances inst_envs clas
bad_fundeps = badFunDeps cls_inst_env clas ins_tv_set ins_tys
badFunDeps :: [InstEnvElt] -> Class
#include "HsVersions.h"
-import {-# SOURCE #-} Name( Name )
+import {-# SOURCE #-} Module( ModuleName )
+import {-# SOURCE #-} OccName( OccName )
import CmdLineOpts ( opt_PprStyle_Debug, opt_PprUserLength )
import FastString
| PartWay Int -- 0 => stop
-type PrintUnqualified = Name -> Bool
+type PrintUnqualified = ModuleName -> OccName -> Bool
-- This function tells when it's ok to print
-- a (Global) name unqualified
alwaysQualify,neverQualify :: PrintUnqualified
-alwaysQualify n = False
-neverQualify n = True
+alwaysQualify m n = False
+neverQualify m n = True
defaultUserStyle = mkUserStyle alwaysQualify AllTheWay
\end{code}
\begin{code}
-unqualStyle :: PprStyle -> Name -> Bool
-unqualStyle (PprUser unqual _) n = unqual n
-unqualStyle other n = False
+unqualStyle :: PprStyle -> PrintUnqualified
+unqualStyle (PprUser unqual _) m n = unqual m n
+unqualStyle other m n = False
codeStyle :: PprStyle -> Bool
codeStyle (PprCode _) = True
#include "HsVersions.h"
-import {-# SOURCE #-} Name ( Name )
-
import Unique ( Uniquable(..), Unique, getKey#, mkUniqueGrimily )
import Panic
import FastTypes
projects / ghc-hetmet.git / commitdiff