X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcompMan%2FCompManager.lhs;h=ce6302afb07b780fbd30d90d37badfbd59aec558;hb=423d477bfecd490de1449c59325c8776f91d7aac;hp=db192192cbe7572c8622234bf496cd85eef1eda8;hpb=948e7f388748078a8d9a324b284da7c4029f7060;p=ghc-hetmet.git diff --git a/ghc/compiler/compMan/CompManager.lhs b/ghc/compiler/compMan/CompManager.lhs index db19219..ce6302a 100644 --- a/ghc/compiler/compMan/CompManager.lhs +++ b/ghc/compiler/compMan/CompManager.lhs @@ -4,7 +4,6 @@ % The Compilation Manager % \begin{code} -{-# OPTIONS -fvia-C #-} module CompManager ( ModuleGraph, ModSummary(..), @@ -25,9 +24,7 @@ module CompManager ( cmSetContext, -- :: CmState -> DynFlags -> [String] -> [String] -> IO CmState cmGetContext, -- :: CmState -> IO ([String],[String]) - cmInfoThing, -- :: CmState -> DynFlags -> String - -- -> IO (CmState, [(TyThing,Fixity)]) - + cmInfoThing, -- :: CmState -> String -> IO (CmState, [(TyThing,Fixity)]) cmBrowseModule, -- :: CmState -> IO [TyThing] CmRunResult(..), @@ -37,6 +34,9 @@ module CompManager ( cmTypeOfExpr, -- :: CmState -> DynFlags -> String -- -> IO (CmState, Maybe String) + cmKindOfType, -- :: CmState -> DynFlags -> String + -- -> IO (CmState, Maybe String) + cmTypeOfName, -- :: CmState -> Name -> IO (Maybe String) HValue, @@ -44,13 +44,10 @@ module CompManager ( -- -> IO (CmState, Maybe HValue) cmGetModInfo, -- :: CmState -> (ModuleGraph, HomePackageTable) - findModuleLinkable_maybe, -- Exported to InteractiveUI cmSetDFlags, cmGetBindings, -- :: CmState -> [TyThing] cmGetPrintUnqual, -- :: CmState -> PrintUnqualified - - sandboxIO -- Should be somewhere else #endif ) where @@ -59,7 +56,7 @@ where import DriverPipeline ( CompResult(..), preprocess, compile, link ) import HscMain ( newHscEnv ) -import DriverState ( v_Output_file, v_NoHsMain ) +import DriverState ( v_Output_file, v_NoHsMain, v_MainModIs ) import DriverPhases import Finder import HscTypes @@ -84,9 +81,10 @@ import Maybes ( expectJust, orElse, mapCatMaybes ) import DATA_IOREF ( readIORef ) #ifdef GHCI -import HscMain ( hscThing, hscStmt, hscTcExpr ) +import HscMain ( hscThing, hscStmt, hscTcExpr, hscKcType ) import TcRnDriver ( mkExportEnv, getModuleContents ) import IfaceSyn ( IfaceDecl ) +import RdrName ( GlobalRdrEnv, plusGlobalRdrEnv ) import Name ( Name ) import NameEnv import Id ( idType ) @@ -96,6 +94,7 @@ import BasicTypes ( Fixity ) import Linker ( HValue, unload, extendLinkEnv ) import GHC.Exts ( unsafeCoerce# ) import Foreign +import SrcLoc ( SrcLoc ) import Control.Exception as Exception ( Exception, try ) #endif @@ -179,17 +178,25 @@ cmSetContext -> [String] -- and the just the exports from these -> IO CmState cmSetContext cmstate toplevs exports = do - let old_ic = cm_ic cmstate - - mb_export_env <- mkExportEnv (cm_hsc cmstate) - (map mkModuleName exports) - - case mb_export_env of - Nothing -> return cmstate -- Error already reported; do a no-op - Just export_env -> - return cmstate{ cm_ic = old_ic { ic_toplev_scope = toplevs, - ic_exports = exports, - ic_rn_gbl_env = export_env } } + let old_ic = cm_ic cmstate + hsc_env = cm_hsc cmstate + hpt = hsc_HPT hsc_env + + export_env <- mkExportEnv hsc_env (map mkModuleName exports) + toplev_envs <- mapM (mkTopLevEnv hpt) toplevs + + let all_env = foldr plusGlobalRdrEnv export_env toplev_envs + return cmstate{ cm_ic = old_ic { ic_toplev_scope = toplevs, + ic_exports = exports, + ic_rn_gbl_env = all_env } } + +mkTopLevEnv :: HomePackageTable -> String -> IO GlobalRdrEnv +mkTopLevEnv hpt mod + = case lookupModuleEnvByName hpt (mkModuleName mod) of + Nothing -> throwDyn (ProgramError ("mkTopLevEnv: not a home module " ++ mod)) + Just details -> case hm_globals details of + Nothing -> throwDyn (ProgramError ("mkTopLevEnv: not interpreted " ++ mod)) + Just env -> return env cmGetContext :: CmState -> IO ([String],[String]) cmGetContext CmState{cm_ic=ic} = @@ -212,7 +219,7 @@ cmSetDFlags cm_state dflags -- A string may refer to more than one TyThing (eg. a constructor, -- and type constructor), so we return a list of all the possible TyThings. -cmInfoThing :: CmState -> String -> IO [(IfaceDecl,Fixity)] +cmInfoThing :: CmState -> String -> IO [(IfaceDecl,Fixity,SrcLoc)] cmInfoThing cmstate id = hscThing (cm_hsc cmstate) (cm_ic cmstate) id @@ -310,14 +317,27 @@ cmTypeOfExpr cmstate expr case maybe_stuff of Nothing -> return Nothing - Just ty -> return (Just str) + Just ty -> return (Just res_str) where - str = showSDocForUser unqual (text expr <+> dcolon <+> ppr tidy_ty) + res_str = showSDocForUser unqual (text expr <+> dcolon <+> ppr tidy_ty) unqual = icPrintUnqual (cm_ic cmstate) tidy_ty = tidyType emptyTidyEnv ty ----------------------------------------------------------------------------- +-- cmKindOfType: returns a string representing the kind of a type + +cmKindOfType :: CmState -> String -> IO (Maybe String) +cmKindOfType cmstate str + = do maybe_stuff <- hscKcType (cm_hsc cmstate) (cm_ic cmstate) str + case maybe_stuff of + Nothing -> return Nothing + Just kind -> return (Just res_str) + where + res_str = showSDocForUser unqual (text str <+> dcolon <+> ppr kind) + unqual = icPrintUnqual (cm_ic cmstate) + +----------------------------------------------------------------------------- -- cmTypeOfName: returns a string representing the type of a name. cmTypeOfName :: CmState -> Name -> IO (Maybe String) @@ -437,8 +457,11 @@ cmLoadModules cmstate1 mg2unsorted let verb = verbosity dflags -- Find out if we have a Main module - let a_root_is_Main - = any ((=="Main").moduleNameUserString.modSummaryName) + mb_main_mod <- readIORef v_MainModIs + let + main_mod = mb_main_mod `orElse` "Main" + a_root_is_Main + = any ((==main_mod).moduleNameUserString.modSummaryName) mg2unsorted let mg2unsorted_names = map modSummaryName mg2unsorted @@ -567,7 +590,7 @@ cmLoadModules cmstate1 mg2unsorted let do_linking = a_root_is_Main || no_hs_main when (ghci_mode == Batch && isJust ofile && not do_linking && verb > 0) $ - hPutStrLn stderr "Warning: output was redirected with -o, but no output will be generated\nbecause there is no Main module." + hPutStrLn stderr ("Warning: output was redirected with -o, but no output will be generated\nbecause there is no " ++ main_mod ++ " module.") -- link everything together linkresult <- link ghci_mode dflags do_linking (hsc_HPT hsc_env3) @@ -924,7 +947,8 @@ upsweep_mod hsc_env oldUI summary1 reachable_inc_me | otherwise = False compresult <- compile hsc_env_strictDC this_mod location - source_unchanged have_object mb_old_iface + (ms_hs_date summary1) + source_unchanged have_object mb_old_iface case compresult of