-- * Flags and settings
DynFlags(..), DynFlag(..), GhcMode(..), HscTarget(..), dopt,
parseDynamicFlags,
+ initPackages,
getSessionDynFlags,
setSessionDynFlags,
setMsgHandler,
-- * Targets
- Target(..),
+ Target(..), TargetId(..),
setTargets,
getTargets,
addTarget,
+ removeTarget,
guessTarget,
- -- * Loading/compiling the program
+ -- * Loading\/compiling the program
depanal,
- load, SuccessFlag(..), -- also does depanal
+ load, LoadHowMuch(..), SuccessFlag(..), -- also does depanal
workingDirectoryChanged,
+ checkModule, CheckedModule(..),
-- * Inspecting the module structure of the program
ModuleGraph, ModSummary(..),
#endif
-- * Abstract syntax elements
+
+ -- ** Modules
Module, mkModule, pprModule,
+
+ -- ** Identifiers
+ Name,
+ Id, idType,
+
+ -- ** Type constructors
+ TyCon,
+
+ -- ** Data constructors
+ DataCon,
+
+ -- ** Classes
+ Class,
+
+ -- ** Types and Kinds
Type, dropForAlls,
Kind,
- Name, Id, TyCon, Class, DataCon,
+
+ -- ** Entities
TyThing(..),
- idType,
- -- used by DriverMkDepend:
+ -- * Exceptions
+ GhcException(..), showGhcException,
+
+ -- * Miscellaneous
sessionHscEnv,
cyclicModuleErr,
) where
import Linker ( HValue, extendLinkEnv )
import NameEnv ( lookupNameEnv )
import TcRnDriver ( mkExportEnv, getModuleContents )
-import RdrName ( GlobalRdrEnv, plusGlobalRdrEnv )
+import RdrName ( plusGlobalRdrEnv )
import HscMain ( hscGetInfo, GetInfoResult,
hscStmt, hscTcExpr, hscKcType )
import Type ( tidyType )
import IfaceSyn ( IfaceDecl )
#endif
+import Packages ( initPackages )
+import RdrName ( GlobalRdrEnv )
+import HsSyn ( HsModule, LHsBinds )
import Type ( Kind, Type, dropForAlls )
import Id ( Id, idType )
import TyCon ( TyCon )
import Class ( Class )
import DataCon ( DataCon )
import Name ( Name )
+import RdrName ( RdrName )
import NameEnv ( nameEnvElts )
+import SrcLoc ( Located )
import DriverPipeline
import DriverPhases ( Phase(..), isHaskellSrcFilename, startPhase )
import GetImports ( getImports )
import Packages ( isHomePackage )
import Finder
-import HscMain ( newHscEnv )
+import HscMain ( newHscEnv, hscFileCheck, HscResult(..) )
import HscTypes
import DynFlags
import StaticFlags
import FiniteMap
import Panic
import Digraph
-import ErrUtils ( showPass )
+import ErrUtils ( showPass, Messages, putMsg, debugTraceMsg )
import qualified ErrUtils
import Util
-import StringBuffer ( StringBuffer(..), hGetStringBuffer, lexemeToString )
+import StringBuffer ( StringBuffer, hGetStringBuffer )
import Outputable
import SysTools ( cleanTempFilesExcept )
-import BasicTypes ( SuccessFlag(..), succeeded )
+import BasicTypes ( SuccessFlag(..), succeeded, failed )
import Maybes ( orElse, expectJust, mapCatMaybes )
import Directory ( getModificationTime, doesFileExist )
import Maybe ( isJust, isNothing, fromJust )
import Maybes ( expectJust )
import List ( partition, nub )
+import qualified List
import Monad ( unless, when, foldM )
import System ( exitWith, ExitCode(..) )
import Time ( ClockTime )
import EXCEPTION as Exception hiding (handle)
-import GLAEXTS ( Int(..) )
import DATA_IOREF
import IO
import Prelude hiding (init)
hFlush stdout
case exception of
-- an IO exception probably isn't our fault, so don't panic
- IOException _ -> hPutStrLn stderr (show exception)
+ IOException _ -> putMsg (show exception)
AsyncException StackOverflow ->
- hPutStrLn stderr "stack overflow: use +RTS -K<size> to increase it"
- _other -> hPutStr stderr (show (Panic (show exception)))
+ putMsg "stack overflow: use +RTS -K<size> to increase it"
+ _other -> putMsg (show (Panic (show exception)))
exitWith (ExitFailure 1)
) $
case dyn of
PhaseFailed _ code -> exitWith code
Interrupted -> exitWith (ExitFailure 1)
- _ -> do hPutStrLn stderr (show (dyn :: GhcException))
+ _ -> do putMsg (show (dyn :: GhcException))
exitWith (ExitFailure 1)
) $
inner
-- | Starts a new session. A session consists of a set of loaded
-- modules, a set of options (DynFlags), and an interactive context.
--- ToDo: GhcMode should say "keep typechecked code" and/or "keep renamed
+-- ToDo: GhcMode should say "keep typechecked code" and\/or "keep renamed
-- code".
newSession :: GhcMode -> IO Session
newSession mode = do
-- | Sets the targets for this session. Each target may be a module name
-- or a filename. The targets correspond to the set of root modules for
--- the program/library. Unloading the current program is achieved by
+-- the program\/library. Unloading the current program is achieved by
-- setting the current set of targets to be empty, followed by load.
setTargets :: Session -> [Target] -> IO ()
setTargets s targets = modifySession s (\h -> h{ hsc_targets = targets })
getTargets :: Session -> IO [Target]
getTargets s = withSession s (return . hsc_targets)
--- Add another target, or update an existing target with new content.
+-- | Add another target
addTarget :: Session -> Target -> IO ()
addTarget s target
= modifySession s (\h -> h{ hsc_targets = target : hsc_targets h })
--- Remove a target
--- removeTarget :: Session -> Module -> IO ()
+-- | Remove a target
+removeTarget :: Session -> TargetId -> IO ()
+removeTarget s target_id
+ = modifySession s (\h -> h{ hsc_targets = filter (hsc_targets h) })
+ where
+ filter targets = [ t | t@(Target id _) <- targets, id /= target_id ]
-- Attempts to guess what Target a string refers to. This function implements
-- the --make/GHCi command-line syntax for filenames:
-- -----------------------------------------------------------------------------
-- Loading the program
--- | The result of load.
-data LoadResult
- = LoadOk Errors -- ^ all specified targets were loaded successfully.
- | LoadFailed Errors -- ^ not all modules were loaded.
-
-type Errors = [String]
-
-{-
-data ErrMsg = ErrMsg {
- errMsgSeverity :: Severity, -- warning, error, etc.
- errMsgSpans :: [SrcSpan],
- errMsgShortDoc :: Doc,
- errMsgExtraInfo :: Doc
- }
--}
-
-- Perform a dependency analysis starting from the current targets
-- and update the session with the new module graph.
depanal :: Session -> [Module] -> IO ()
old_graph = hsc_mod_graph hsc_env
showPass dflags "Chasing dependencies"
- when (verbosity dflags >= 1 && gmode == BatchCompile) $
- hPutStrLn stderr (showSDoc (hcat [
+ when (gmode == BatchCompile) $
+ debugTraceMsg dflags 1 (showSDoc (hcat [
text "Chasing modules from: ",
hcat (punctuate comma (map pprTarget targets))]))
graph <- downsweep hsc_env old_graph excluded_mods
writeIORef ref hsc_env{ hsc_mod_graph=graph }
+{-
+-- | The result of load.
+data LoadResult
+ = LoadOk Errors -- ^ all specified targets were loaded successfully.
+ | LoadFailed Errors -- ^ not all modules were loaded.
+
+type Errors = [String]
+
+data ErrMsg = ErrMsg {
+ errMsgSeverity :: Severity, -- warning, error, etc.
+ errMsgSpans :: [SrcSpan],
+ errMsgShortDoc :: Doc,
+ errMsgExtraInfo :: Doc
+ }
+-}
+
+data LoadHowMuch
+ = LoadAllTargets
+ | LoadUpTo Module
+ | LoadDependenciesOf Module
-- | Try to load the program. If a Module is supplied, then just
-- attempt to load up to this target. If no Module is supplied,
-- then try to load all targets.
-load :: Session -> Maybe Module -> IO SuccessFlag
-load s@(Session ref) maybe_mod
+load :: Session -> LoadHowMuch -> IO SuccessFlag
+load s@(Session ref) how_much
= do
-- Dependency analysis first. Note that this fixes the module graph:
-- even if we don't get a fully successful upsweep, the full module
evaluate pruned_hpt
- when (verb >= 2) $
- putStrLn (showSDoc (text "Stable obj:" <+> ppr stable_obj $$
+ debugTraceMsg dflags 2 (showSDoc (text "Stable obj:" <+> ppr stable_obj $$
text "Stable BCO:" <+> ppr stable_bco))
-- Unload any modules which are going to be re-linked this time around.
-- This graph should be cycle-free.
-- If we're restricting the upsweep to a portion of the graph, we
-- also want to retain everything that is still stable.
- let full_mg, partial_mg :: [SCC ModSummary]
+ let full_mg :: [SCC ModSummary]
full_mg = topSortModuleGraph False mod_graph Nothing
- partial_mg = topSortModuleGraph False mod_graph maybe_mod
+
+ maybe_top_mod = case how_much of
+ LoadUpTo m -> Just m
+ LoadDependenciesOf m -> Just m
+ _ -> Nothing
+
+ partial_mg0 :: [SCC ModSummary]
+ partial_mg0 = topSortModuleGraph False mod_graph maybe_top_mod
+
+ -- LoadDependenciesOf m: we want the upsweep to stop just
+ -- short of the specified module (unless the specified module
+ -- is stable).
+ partial_mg
+ | LoadDependenciesOf mod <- how_much
+ = ASSERT( case last partial_mg0 of
+ AcyclicSCC ms -> ms_mod ms == mod; _ -> False )
+ List.init partial_mg0
+ | otherwise
+ = partial_mg0
stable_mg =
[ AcyclicSCC ms
then
-- Easy; just relink it all.
- do when (verb >= 2) $
- hPutStrLn stderr "Upsweep completely successful."
+ do debugTraceMsg dflags 2 "Upsweep completely successful."
-- Clean up after ourselves
cleanTempFilesExcept dflags (ppFilesFromSummaries modsDone)
mod_graph
do_linking = a_root_is_Main || no_hs_main
- when (ghci_mode == BatchCompile && isJust ofile && not do_linking
- && verb > 0) $
- hPutStrLn stderr ("Warning: output was redirected with -o, " ++
+ when (ghci_mode == BatchCompile && isJust ofile && not do_linking) $
+ debugTraceMsg dflags 1 ("Warning: output was redirected with -o, " ++
"but no output will be generated\n" ++
"because there is no " ++ main_mod ++ " module.")
-- Tricky. We need to back out the effects of compiling any
-- half-done cycles, both so as to clean up the top level envs
-- and to avoid telling the interactive linker to link them.
- do when (verb >= 2) $
- hPutStrLn stderr "Upsweep partially successful."
+ do debugTraceMsg dflags 2 "Upsweep partially successful."
let modsDone_names
= map ms_mod modsDone
-- source file, but that doesn't do any harm.
ppFilesFromSummaries summaries = [ fn | Just fn <- map ms_hspp_file summaries ]
+-- -----------------------------------------------------------------------------
+-- Check module
+
+data CheckedModule =
+ CheckedModule { parsedSource :: ParsedSource,
+ -- ToDo: renamedSource
+ typecheckedSource :: Maybe TypecheckedSource
+ }
+
+type ParsedSource = Located (HsModule RdrName)
+type TypecheckedSource = (LHsBinds Id, GlobalRdrEnv)
+
+-- | This is the way to get access to parsed and typechecked source code
+-- for a module. 'checkModule' loads all the dependencies of the specified
+-- module in the Session, and then attempts to typecheck the module. If
+-- successful, it returns the abstract syntax for the module.
+checkModule :: Session -> Module -> (Messages -> IO ())
+ -> IO (Maybe CheckedModule)
+checkModule session@(Session ref) mod msg_act = do
+ -- load up the dependencies first
+ r <- load session (LoadDependenciesOf mod)
+ if (failed r) then return Nothing else do
+
+ -- now parse & typecheck the module
+ hsc_env <- readIORef ref
+ let mg = hsc_mod_graph hsc_env
+ case [ ms | ms <- mg, ms_mod ms == mod ] of
+ [] -> return Nothing
+ (ms:_) -> do
+ r <- hscFileCheck hsc_env msg_act ms
+ case r of
+ HscFail ->
+ return Nothing
+ HscChecked parsed tcd ->
+ return (Just (CheckedModule parsed tcd) )
+
-----------------------------------------------------------------------------
-- Unloading
unload :: HscEnv -> [Linkable] -> IO ()
unload hsc_env stable_linkables -- Unload everthing *except* 'stable_linkables'
= case ghcMode (hsc_dflags hsc_env) of
- BatchCompile -> return ()
+ BatchCompile -> return ()
+ JustTypecheck -> return ()
#ifdef GHCI
Interactive -> Linker.unload (hsc_dflags hsc_env) stable_linkables
#else
upsweep hsc_env old_hpt stable_mods cleanup
(CyclicSCC ms:_)
- = do hPutStrLn stderr (showSDoc (cyclicModuleErr ms))
+ = do putMsg (showSDoc (cyclicModuleErr ms))
return (Failed, hsc_env, [])
upsweep hsc_env old_hpt stable_mods cleanup
-> Maybe Module
-> [SCC ModSummary]
-- Calculate SCCs of the module graph, possibly dropping the hi-boot nodes
+-- The resulting list of strongly-connected-components is in topologically
+-- sorted order, starting with the module(s) at the bottom of the
+-- dependency graph (ie compile them first) and ending with the ones at
+-- the top.
--
-- Drop hi-boot nodes (first boolean arg)?
--
return (dflags', "<buffer>", buf)
--- code adapted from the file-based version in DriverUtil
-getOptionsFromStringBuffer :: StringBuffer -> [String]
-getOptionsFromStringBuffer buffer@(StringBuffer _ len# _) =
- let
- ls = lines (lexemeToString buffer (I# len#)) -- lazy, so it's ok
- in
- look ls
- where
- look [] = []
- look (l':ls) = do
- let l = removeSpaces l'
- case () of
- () | null l -> look ls
- | prefixMatch "#" l -> look ls
- | prefixMatch "{-# LINE" l -> look ls -- -}
- | Just opts <- matchOptions l
- -> opts ++ look ls
- | otherwise -> []
-
-----------------------------------------------------------------------------
-- Error messages
-----------------------------------------------------------------------------
projects / ghc-hetmet.git / blobdiff