import Module
import UniqFM
import Name
+import NameEnv
import NameSet
import TyCon
import SrcLoc
import HscTypes
+import ListSetOps
import Outputable
-import Breakpoints
#ifdef GHCI
import Linker
import IdInfo
import {- Kind parts of -} Type
import BasicTypes
-import Data.Maybe
#endif
import FastString
import Control.Monad ( unless )
import Data.Maybe ( isJust )
+import Foreign.Ptr ( Ptr )
+
\end{code}
-- Must be done after processing the exports
tcg_env <- checkHiBootIface tcg_env boot_iface ;
+ -- Make the new type env available to stuff slurped from interface files
+ -- Must do this after checkHiBootIface, because the latter might add new
+ -- bindings for boot_dfuns, which may be mentioned in imported unfoldings
+ writeMutVar (tcg_type_env_var tcg_env) (tcg_type_env tcg_env) ;
+
-- Rename the Haddock documentation
tcg_env <- rnHaddock module_info maybe_doc tcg_env ;
mg_deprecs = NoDeprecs,
mg_foreign = NoStubs,
mg_hpc_info = noHpcInfo,
- mg_dbg_sites = noDbgSites
+ mg_modBreaks = emptyModBreaks
} } ;
tcCoreDump mod_guts ;
tcg_rules = rules',
tcg_fords = fords' } } ;
- -- Make the new type env available to stuff slurped from interface files
- writeMutVar (tcg_type_env_var tcg_env) final_type_env ;
-
return (tcg_env' { tcg_binds = tcg_binds tcg_env' })
}
| otherwise
= do { traceTc (text "checkHiBootIface" <+> (ppr boot_type_env $$ ppr boot_insts $$
- ppr local_export_set $$ ppr boot_exports)) ;
- ; mapM_ check_export (concatMap availNames boot_exports)
- ; dfun_binds <- mapM check_inst boot_insts
+ ppr boot_exports)) ;
+
+ -- Check the exports of the boot module, one by one
+ ; mapM_ check_export boot_exports
+
+ -- Check instance declarations
+ ; mb_dfun_prs <- mapM check_inst boot_insts
+ ; let tcg_env' = tcg_env { tcg_binds = binds `unionBags` dfun_binds,
+ tcg_type_env = extendTypeEnvWithIds local_type_env boot_dfuns }
+ dfun_prs = catMaybes mb_dfun_prs
+ boot_dfuns = map fst dfun_prs
+ dfun_binds = listToBag [ noLoc $ VarBind boot_dfun (nlHsVar dfun)
+ | (boot_dfun, dfun) <- dfun_prs ]
+
+ -- Check for no family instances
; unless (null boot_fam_insts) $
panic ("TcRnDriver.checkHiBootIface: Cannot handle family " ++
"instances in boot files yet...")
-- FIXME: Why? The actual comparison is not hard, but what would
-- be the equivalent to the dfun bindings returned for class
-- instances? We can't easily equate tycons...
- ; return (tcg_env { tcg_binds = binds `unionBags` unionManyBags dfun_binds }) }
+
+ ; return tcg_env' }
where
- check_export name -- Name is exported by the boot iface
- | name `elem` dfun_names = return ()
- | isWiredInName name = return () -- No checking for wired-in names. In particular,
- -- 'error' is handled by a rather gross hack
- -- (see comments in GHC.Err.hs-boot)
- | isImplicitTyThing boot_thing = return ()
+ check_export boot_avail -- boot_avail is exported by the boot iface
+ | name `elem` dfun_names = return ()
+ | isWiredInName name = return () -- No checking for wired-in names. In particular,
+ -- 'error' is handled by a rather gross hack
+ -- (see comments in GHC.Err.hs-boot)
+
+ -- Check that the actual module exports the same thing
+ | not (null missing_names)
+ = addErrTc (missingBootThing (head missing_names) "exported by")
+
+ -- If the boot module does not *define* the thing, we are done
+ -- (it simply re-exports it, and names match, so nothing further to do)
+ | isNothing mb_boot_thing = return ()
+
+ -- Check that the actual module also defines the thing, and
+ -- then compare the definitions
| Just real_thing <- lookupTypeEnv local_type_env name
- = do { checkTc (name `elemNameSet` local_export_set)
- (missingBootThing boot_thing "exported by")
-
- ; let boot_decl = tyThingToIfaceDecl boot_thing
+ = do { let boot_decl = tyThingToIfaceDecl (fromJust mb_boot_thing)
real_decl = tyThingToIfaceDecl real_thing
; checkTc (checkBootDecl boot_decl real_decl)
- (bootMisMatch boot_thing boot_decl real_decl) }
+ (bootMisMatch real_thing boot_decl real_decl) }
-- The easiest way to check compatibility is to convert to
-- iface syntax, where we already have good comparison functions
| otherwise
- = addErrTc (missingBootThing boot_thing "defined in")
+ = addErrTc (missingBootThing name "defined in")
where
- boot_thing = lookupTypeEnv boot_type_env name
- `orElse` pprPanic "checkHiBootIface" (ppr name)
-
+ name = availName boot_avail
+ mb_boot_thing = lookupTypeEnv boot_type_env name
+ missing_names = case lookupNameEnv local_export_env name of
+ Nothing -> [name]
+ Just avail -> availNames boot_avail `minusList` availNames avail
+
dfun_names = map getName boot_insts
- local_export_set :: NameSet
- local_export_set = availsToNameSet local_exports
+ local_export_env :: NameEnv AvailInfo
+ local_export_env = availsToNameEnv local_exports
+ check_inst :: Instance -> TcM (Maybe (Id, Id))
+ -- Returns a pair of the boot dfun in terms of the equivalent real dfun
check_inst boot_inst
= case [dfun | inst <- local_insts,
let dfun = instanceDFunId inst,
idType dfun `tcEqType` boot_inst_ty ] of
- [] -> do { addErrTc (instMisMatch boot_inst); return emptyBag }
- (dfun:_) -> return (unitBag $ noLoc $ VarBind local_boot_dfun (nlHsVar dfun))
+ [] -> do { addErrTc (instMisMatch boot_inst); return Nothing }
+ (dfun:_) -> return (Just (local_boot_dfun, dfun))
where
boot_dfun = instanceDFunId boot_inst
boot_inst_ty = idType boot_dfun
checkMain :: TcM TcGblEnv
-- If we are in module Main, check that 'main' is defined.
checkMain
- = do { ghc_mode <- getGhcMode ;
- tcg_env <- getGblEnv ;
+ = do { tcg_env <- getGblEnv ;
dflags <- getDOpts ;
let { main_mod = mainModIs dflags ;
main_fn = case mainFunIs dflags of {
Just fn -> mkRdrUnqual (mkVarOccFS (mkFastString fn)) ;
Nothing -> main_RDR_Unqual } } ;
- check_main ghc_mode tcg_env main_mod main_fn
+ check_main dflags tcg_env main_mod main_fn
}
-check_main ghc_mode tcg_env main_mod main_fn
+check_main dflags tcg_env main_mod main_fn
| mod /= main_mod
= traceTc (text "checkMain not" <+> ppr main_mod <+> ppr mod) >>
return tcg_env
where
mod = tcg_mod tcg_env
- complain_no_main | ghc_mode == Interactive = return ()
- | otherwise = failWithTc noMainMsg
+ complain_no_main | ghcLink dflags == LinkInMemory = 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.
ic = hsc_IC hsc_env
checkMods = ic_toplev_scope ic ++ ic_exports ic
in
- initTc hsc_env HsSrcFile iNTERACTIVE (tcGetModuleExports mod checkMods)
+ initTc hsc_env HsSrcFile False iNTERACTIVE (tcGetModuleExports mod checkMods)
-- Get the export avail info and also load all orphan and family-instance
-- modules. Finally, check that the family instances of all modules in the
return good_names
}
-tcRnRecoverDataCon :: HscEnv -> a -> IO (Maybe DataCon)
-tcRnRecoverDataCon hsc_env a
+tcRnRecoverDataCon :: HscEnv -> Ptr () -> IO (Maybe DataCon)
+tcRnRecoverDataCon hsc_env ptr
= initTcPrintErrors hsc_env iNTERACTIVE $
- setInteractiveContext hsc_env (hsc_IC hsc_env) $
- do name <- recoverDataCon a
+ setInteractiveContext hsc_env (hsc_IC hsc_env) $ do
+ name <- dataConInfoPtrToName ptr
tcLookupDataCon name
tcRnLookupName :: HscEnv -> Name -> IO (Maybe TyThing)