)
import PrelInfo ( fractionalClassKeys, derivingOccurrences, wiredInThingEnv )
import Type ( namesOfType, funTyCon )
-import ErrUtils ( printErrorsAndWarnings, dumpIfSet )
-import Bag ( isEmptyBag, bagToList )
+import ErrUtils ( dumpIfSet )
+import Bag ( bagToList )
import FiniteMap ( FiniteMap, eltsFM, fmToList, emptyFM, lookupFM,
addToFM_C, elemFM, addToFM
)
-> Module -> RdrNameHsModule
-> IO (PersistentCompilerState, Maybe (ModIface, [RenamedHsDecl]))
-renameModule dflags finder hit hst old_pcs this_module
- this_mod@(HsModule _ _ _ _ _ _ loc)
+renameModule dflags finder hit hst old_pcs this_module rdr_module
= -- Initialise the renamer monad
do {
- ((maybe_rn_stuff, dump_action), (rn_warns_bag, rn_errs_bag), new_pcs)
- <- initRn dflags finder hit hst old_pcs this_module loc (rename this_module this_mod) ;
-
- -- Check for warnings
- printErrorsAndWarnings (rn_warns_bag, rn_errs_bag) ;
+ (new_pcs, errors_found, (maybe_rn_stuff, dump_action))
+ <- initRn dflags finder hit hst old_pcs this_module (rename this_module rdr_module) ;
-- Dump any debugging output
dump_action ;
-- Return results
- if not (isEmptyBag rn_errs_bag) then
+ if errors_found then
return (old_pcs, Nothing)
else
return (new_pcs, maybe_rn_stuff)
getImportedInstDecls, getImportedRules,
lookupFixityRn,
importDecl, ImportDeclResult(..), recordLocalSlurps,
- mkImportInfo, getSlurped
+ mkImportInfo, getSlurped,
+
+ recompileRequired
)
where
#include "HsVersions.h"
-import CmdLineOpts ( opt_NoPruneDecls, opt_NoPruneTyDecls, opt_IgnoreIfacePragmas )
+import CmdLineOpts ( DynFlags, opt_NoPruneDecls, opt_NoPruneTyDecls, opt_IgnoreIfacePragmas )
import HscTypes
import HsSyn ( HsDecl(..), InstDecl(..), HsType(..) )
import HsImpExp ( ImportDecl(..) )
where
go_for_it exports = (mod_name, has_orphans, is_boot, exports) : so_far
- mod_iface = lookupIface hit pit mod_name
+ mod_iface = lookupTableByModName hit pit mod_name `orElse` panic "mkImportInfo"
mod = mi_module mod_iface
is_lib_module = not (isModuleInThisPackage mod)
version_info = mi_version mod_iface
%* *
%********************************************************
+@recompileRequired@ is called from the HscMain. It checks whether
+a recompilation is required. It needs access to the persistent state,
+finder, etc, because it may have to load lots of interface files to
+check their versions.
+
\begin{code}
type RecompileRequired = Bool
upToDate = False -- Recompile not required
outOfDate = True -- Recompile required
-recompileRequired :: Module -> Bool -> Maybe ModIface -> RnMG RecompileRequired
-recompileRequired mod source_unchanged maybe_iface
- = traceRn (text "Considering whether compilation is required for" <+> ppr mod <> colon) `thenRn_`
+recompileRequired :: DynFlags -> Finder
+ -> HomeIfaceTable -> HomeSymbolTable
+ -> PersistentCompilerState
+ -> Module
+ -> Bool -- Source unchanged
+ -> Maybe ModIface -- Old interface, if any
+ -> IO (PersistentCompilerState, Bool, RecompileRequired)
+ -- True <=> errors happened
+recompileRequired dflags finder hit hst pcs mod source_unchanged maybe_iface
+ = initRn dflags finder hit hst pcs mod $
+ traceRn (text "Considering whether compilation is required for" <+> ppr mod <> colon) `thenRn_`
-- CHECK WHETHER THE SOURCE HAS CHANGED
if not source_unchanged then
returnRn outOfDate ;
Just iface -> -- Source code unchanged and no errors yet... carry on
- getHomeIfaceTableRn `thenRn` \ hit ->
- checkList [checkModUsage hit u | u <- mi_usages iface]
+ checkList [checkModUsage u | u <- mi_usages iface]
checkList :: [RnMG RecompileRequired] -> RnMG RecompileRequired
checkList [] = returnRn upToDate
\end{code}
\begin{code}
-checkModUsage :: HomeIfaceTable -> ImportVersion Name -> RnMG RecompileRequired
+checkModUsage :: ImportVersion Name -> RnMG RecompileRequired
-- Given the usage information extracted from the old
-- M.hi file for the module being compiled, figure out
-- whether M needs to be recompiled.
-checkModUsage hit (mod_name, _, _, NothingAtAll)
+checkModUsage (mod_name, _, _, NothingAtAll)
-- If CurrentModule.hi contains
-- import Foo :: ;
-- then that simply records that Foo lies below CurrentModule in the
-- In this case we don't even want to open Foo's interface.
= up_to_date (ptext SLIT("Nothing used from:") <+> ppr mod_name)
-checkModUsage hit (mod_name, _, _, whats_imported)
+checkModUsage (mod_name, _, _, whats_imported)
= tryLoadInterface doc_str mod_name ImportBySystem `thenRn` \ (ifaces, maybe_err) ->
case maybe_err of {
Just err -> out_of_date (sep [ptext SLIT("Can't find version number for module"),
-- the current module doesn't need that import and it's been deleted
Nothing ->
+
+ getHomeIfaceTableRn `thenRn` \ hit ->
let
mod_details = lookupTableByModName hit (iPIT ifaces) mod_name
`orElse` panic "checkModUsage"
HomeSymbolTable, PackageSymbolTable,
PersistentCompilerState(..), GlobalRdrEnv,
HomeIfaceTable, PackageIfaceTable,
- RdrAvailInfo, ModIface )
+ RdrAvailInfo )
import BasicTypes ( Version, defaultFixity )
import ErrUtils ( addShortErrLocLine, addShortWarnLocLine,
pprBagOfErrors, ErrMsg, WarnMsg, Message
NameEnv, lookupNameEnv, emptyNameEnv, unitNameEnv,
extendNameEnvList
)
-import Module ( Module, ModuleName, lookupModuleEnvByName )
+import Module ( Module, ModuleName )
import NameSet
import CmdLineOpts ( DynFlags, DynFlag(..), dopt )
-import SrcLoc ( SrcLoc, generatedSrcLoc )
+import SrcLoc ( SrcLoc, generatedSrcLoc, noSrcLoc )
import Unique ( Unique )
import FiniteMap ( FiniteMap, emptyFM )
import Bag ( Bag, emptyBag, isEmptyBag, snocBag )
import UniqSupply
import Outputable
import PrelNames ( mkUnboundName )
-import Maybes ( maybeToBool, seqMaybe, orElse )
+import Maybes ( maybeToBool, seqMaybe )
+import ErrUtils ( printErrorsAndWarnings )
infixr 9 `thenRn`, `thenRn_`
\end{code}
%************************************************************************
\begin{code}
-initRn :: DynFlags
- -> Finder
- -> HomeIfaceTable
- -> HomeSymbolTable
+initRn :: DynFlags -> Finder
+ -> HomeIfaceTable -> HomeSymbolTable
-> PersistentCompilerState
- -> Module
- -> SrcLoc
+ -> Module
-> RnMG t
- -> IO (t, (Bag WarnMsg, Bag ErrMsg), PersistentCompilerState)
+ -> IO (PersistentCompilerState, Bool, t)
+ -- True <=> found errors
-initRn dflags finder hit hst pcs mod loc do_rn
+initRn dflags finder hit hst pcs mod do_rn
= do
let prs = pcs_PRS pcs
let pst = pcs_PST pcs
+ let ifaces = Ifaces { iPIT = pcs_PIT pcs,
+ iDecls = prsDecls prs,
+ iInsts = prsInsts prs,
+ iRules = prsRules prs,
+
+ iImpModInfo = emptyFM,
+ iSlurp = unitNameSet (mkUnboundName dummyRdrVarName),
+ -- Pretend that the dummy unbound name has already been
+ -- slurped. This is what's returned for an out-of-scope name,
+ -- and we don't want thereby to try to suck it in!
+ iVSlurp = []
+ }
let uniqs = prsNS prs
names_var <- newIORef (uniqs, origNames (prsOrig prs),
origIParam (prsOrig prs))
errs_var <- newIORef (emptyBag,emptyBag)
- iface_var <- newIORef (initIfaces pcs)
+ iface_var <- newIORef ifaces
let rn_down = RnDown { rn_mod = mod,
- rn_loc = loc,
+ rn_loc = noSrcLoc,
rn_finder = finder,
rn_dflags = dflags,
let new_pcs = pcs { pcs_PIT = iPIT new_ifaces,
pcs_PRS = new_prs }
- return (res, (warns, errs), new_pcs)
+ -- Check for warnings
+ printErrorsAndWarnings (warns, errs) ;
+
+ return (new_pcs, not (isEmptyBag errs), res)
is_done :: HomeSymbolTable -> PackageSymbolTable -> Name -> Bool
-- Returns True iff the name is in either symbol table
is_done hst pst n = maybeToBool (lookupTypeEnv pst n `seqMaybe` lookupTypeEnv hst n)
-lookupIface :: HomeIfaceTable -> PackageIfaceTable -> ModuleName -> ModIface
-lookupIface hit pit mod = lookupModuleEnvByName hit mod `orElse`
- lookupModuleEnvByName pit mod `orElse`
- pprPanic "lookupIface" (ppr mod)
-
-initIfaces :: PersistentCompilerState -> Ifaces
-initIfaces (PCS { pcs_PIT = pit, pcs_PRS = prs })
- = Ifaces { iPIT = pit,
- iDecls = prsDecls prs,
- iInsts = prsInsts prs,
- iRules = prsRules prs,
-
- iImpModInfo = emptyFM,
- iSlurp = unitNameSet (mkUnboundName dummyRdrVarName),
- -- Pretend that the dummy unbound name has already been
- -- slurped. This is what's returned for an out-of-scope name,
- -- and we don't want thereby to try to suck it in!
- iVSlurp = []
- }
-
-
-initRnMS :: GlobalRdrEnv -> LocalFixityEnv -> RnMode -> RnMS r -> RnM d r
initRnMS rn_env fixity_env mode thing_inside rn_down g_down
= let
s_down = SDown { rn_genv = rn_env, rn_lenv = emptyRdrEnv,
import CmdLineOpts ( DynFlag(..), DynFlags )
import TcMonad
-import TcEnv ( TcEnv, tcSetInstEnv, getTcGST, newDFunName )
+import TcEnv ( TcEnv, tcSetInstEnv, newDFunName )
import TcGenDeriv -- Deriv stuff
import InstEnv ( InstInfo(..), InstEnv,
pprInstInfo, simpleDFunClassTyCon, extendInstEnv )
import RnEnv ( bindLocatedLocalsRn )
import RnMonad ( --RnNameSupply,
renameSourceCode, thenRn, mapRn, returnRn )
-import HscTypes ( DFunId, GlobalSymbolTable, PersistentRenamerState )
+import HscTypes ( DFunId, PersistentRenamerState )
import BasicTypes ( Fixity )
-import Bag ( Bag, emptyBag, unionBags, listToBag )
import Class ( classKey, Class )
import ErrUtils ( dumpIfSet_dyn, Message )
import MkId ( mkDictFunId )
-import Id ( mkVanillaId, idType )
+import Id ( idType )
import DataCon ( dataConArgTys, isNullaryDataCon, isExistentialDataCon )
import PrelInfo ( needsDataDeclCtxtClassKeys )
import Maybes ( maybeToBool, catMaybes )
import Module ( Module )
-import Name ( Name, isLocallyDefined, getSrcLoc, NamedThing(..) )
+import Name ( Name, isLocallyDefined, getSrcLoc )
import RdrName ( RdrName )
import TyCon ( tyConTyVars, tyConDataCons, tyConDerivings,
tyConTheta, maybeTyConSingleCon, isDataTyCon,
- isEnumerationTyCon, isAlgTyCon, TyCon
+ isEnumerationTyCon, TyCon
)
import Type ( TauType, PredType(..), mkTyVarTys, mkTyConApp,
- mkSigmaTy, splitDFunTy, mkDictTy,
- isUnboxedType, splitAlgTyConApp, classesToPreds
+ splitDFunTy, isUnboxedType
)
-import TysWiredIn ( voidTy )
import Var ( TyVar )
import PrelNames
-import Bag ( bagToList )
import Util ( zipWithEqual, sortLt, thenCmp )
import ListSetOps ( removeDups, assoc )
import Outputable
import CmdLineOpts ( DynFlag(..), dopt )
-import HsSyn ( HsDecl(..), InstDecl(..), TyClDecl(..), InPat(..),
- MonoBinds(..), HsExpr(..), HsLit(..), Sig(..), Match(..),
+import HsSyn ( HsDecl(..), InstDecl(..), TyClDecl(..),
+ MonoBinds(..), HsExpr(..), HsLit(..), Sig(..),
andMonoBindList, collectMonoBinders, isClassDecl
)
-import HsTypes ( HsType (..), HsTyVarBndr(..), toHsTyVar )
import RnHsSyn ( RenamedHsBinds, RenamedInstDecl, RenamedHsDecl, RenamedMonoBinds,
RenamedTyClDecl, RenamedHsType,
extractHsTyVars, maybeGenericMatch
LIE, emptyLIE, plusLIE, plusLIEs )
import TcDeriv ( tcDeriving )
import TcEnv ( TcEnv, tcExtendGlobalValEnv,
- tcExtendTyVarEnvForMeths, TyThing (..),
+ tcExtendTyVarEnvForMeths,
tcAddImportedIdInfo, tcInstId, tcLookupClass,
newDFunName, tcExtendTyVarEnv
)
import InstEnv ( InstInfo(..), InstEnv, pprInstInfo, classDataCon,
simpleInstInfoTyCon, simpleInstInfoTy, isLocalInst,
extendInstEnv )
-import TcMonoType ( tcTyVars, tcHsSigType, tcHsType, kcHsSigType )
+import TcMonoType ( tcTyVars, tcHsSigType, kcHsSigType )
import TcSimplify ( tcSimplifyAndCheck )
import TcType ( zonkTcSigTyVars )
import HscTypes ( PersistentCompilerState(..), HomeSymbolTable, DFunId,
ModDetails(..) )
-import Bag ( emptyBag, unitBag, unionBags, unionManyBags,
- foldBag, Bag, listToBag
- )
+import Bag ( unionManyBags )
import Class ( Class, DefMeth(..), classBigSig )
import Var ( idName, idType )
-import Maybes ( maybeToBool, expectJust )
+import Maybes ( maybeToBool )
import MkId ( mkDictFunId )
import Generics ( validGenericInstanceType )
import Module ( Module, foldModuleEnv )
import TyCon ( TyCon, isSynTyCon, tyConDerivings )
import Type ( mkTyVarTys, splitDFunTy, isTyVarTy,
splitTyConApp_maybe, splitDictTy,
- splitAlgTyConApp_maybe, classesToPreds, classesOfPreds,
+ splitAlgTyConApp_maybe,
unUsgTy, tyVarsOfTypes, mkClassPred, mkTyVarTy,
getClassTys_maybe
)
import VarSet ( mkVarSet, varSetElems )
import TysWiredIn ( genericTyCons, isFFIArgumentTy, isFFIResultTy )
import PrelNames ( cCallableClassKey, cReturnableClassKey, hasKey )
-import Name ( Name, NameEnv, extendNameEnv_C, emptyNameEnv,
- plusNameEnv_C, nameEnvElts )
-import FiniteMap ( mapFM )
+import Name ( Name )
import SrcLoc ( SrcLoc )
import VarSet ( varSetElems )
-import UniqFM ( mapUFM )
import Unique ( Uniquable(..) )
import BasicTypes ( NewOrData(..), Fixity )
import ErrUtils ( dumpIfSet_dyn )
assocElts, extendAssoc_C,
equivClassesByUniq, minusList
)
-import List ( intersect, (\\), partition )
+import List ( partition )
import Outputable
\end{code}
)
import TcMonad
-import Inst ( emptyLIE, plusLIE )
+import Inst ( plusLIE )
import TcBinds ( tcTopBinds )
import TcClassDcl ( tcClassDecls2, mkImplicitClassBinds )
import TcDefaults ( tcDefaults )
import Name ( Name, nameOccName, isLocallyDefined, isGlobalName,
toRdrName, nameEnvElts, emptyNameEnv, lookupNameEnv
)
-import TyCon ( TyCon, isDataTyCon, tyConName, tyConGenInfo )
+import TyCon ( tyConGenInfo, isClassTyCon )
import OccName ( isSysOcc )
-import TyCon ( TyCon, isClassTyCon )
-import Class ( Class )
import PrelNames ( mAIN_Name, mainName )
-import UniqSupply ( UniqSupply )
-import Maybes ( maybeToBool, thenMaybe )
+import Maybes ( thenMaybe )
import Util
import BasicTypes ( EP(..), Fixity )
-import Bag ( Bag, isEmptyBag )
+import Bag ( isEmptyBag )
import Outputable
import HscTypes ( PersistentCompilerState(..), HomeSymbolTable, HomeIfaceTable,
PackageSymbolTable, PackageIfaceTable, DFunId, ModIface(..),
let
classes = tcEnvClasses env
tycons = tcEnvTyCons env -- INCLUDES tycons derived from classes
- local_classes = filter isLocallyDefined classes
local_tycons = [ tc | tc <- tycons,
isLocallyDefined tc,
not (isClassTyCon tc)
dump_tc results
= vcat [ppr (tc_binds results),
- pp_rules (tc_rules results) --,
--- ppr_gen_tycons (tc_tycons results)
+ pp_rules (tc_rules results),
+ ppr_gen_tycons [tc | ATyCon tc <- nameEnvElts (tc_env results)]
]
dump_sigs results -- Print type signatures
projects / ghc-hetmet.git / commitdiff