import List ( nub )
import Char ( ord, isAlphaNum )
+import Util ( unJust )
import HscTypes ( ModuleLocation(..) )
import FastTypes
summarise mod location
= if isModuleInThisPackage mod
then do
- let source_fn = hs_preprocd_file location
- -- ToDo:
- -- ppsource_fn <- preprocess source_fn
+ let source_fn = unJust (ml_hspp_file location) "summarise"
modsrc <- readFile source_fn
let imps = getImports modsrc
fp = fingerprint modsrc
-----------------------------------------------------------------------------
--- $Id: DriverPipeline.hs,v 1.12 2000/10/30 13:46:24 sewardj Exp $
+-- $Id: DriverPipeline.hs,v 1.13 2000/10/30 18:13:15 sewardj Exp $
--
-- GHC Driver
--
ohi <- readIORef v_Output_hi
hisuf <- readIORef v_Hi_suf
let hifile = case ohi of
- Nothing -> current_dir ++ {-ToDo: modname!!-}basename
- ++ hisuf
+ Nothing -> current_dir ++ "/" ++ basename
+ ++ "." ++ hisuf
Just fn -> fn
-- figure out if the source has changed, for recompilation avoidance.
-- build a bogus ModuleLocation to pass to hscMain.
let location = ModuleLocation {
- hs_preprocd_file = input_fn,
- hi_file = hifile,
- obj_file = o_file
+ ml_hs_file = Nothing,
+ ml_hspp_file = Just input_fn,
+ ml_hi_file = Just hifile,
+ ml_obj_file = Just o_file
}
-- get the DynFlags
init_dyn_flags <- readIORef v_InitDynFlags
writeIORef v_DynFlags init_dyn_flags
-
- let input_fn = case ms_ppsource summary of
- Just (ppsource, fingerprint) -> ppsource
- Nothing -> hs_preprocd_file (ms_location summary)
+
+ let location = ms_location summary
+ let input_fn = unJust (ml_hs_file location) "compile:hs"
when verb (hPutStrLn stderr ("compile: input file " ++ input_fn))
-- run the compiler
hsc_result <- hscMain dyn_flags{ hscOutName = output_fn }
(panic "compile:source_unchanged")
- (ms_location summary) old_iface hst hit pcs
+ location old_iface hst hit pcs
case hsc_result of {
HscFail pcs -> return (CompErrs pcs);
Nothing -> return (CompOK details Nothing pcs);
Just iface -> do
- let (basename, _) = splitFilename (hs_preprocd_file (ms_location summary))
+ let (basename, _) = splitFilename input_fn
maybe_stub_o <- dealWithStubs basename maybe_stub_h maybe_stub_c
let stub_unlinked = case maybe_stub_o of
Nothing -> []
return (Just (mkHomeModule mod_name,
ModuleLocation{
- hs_preprocd_file = source_fn,
- hi_file = hifile,
- obj_file = o_file
+ ml_hspp_file = Nothing,
+ ml_hs_file = Just source_fn,
+ ml_hi_file = Just hifile,
+ ml_obj_file = Just o_file
}
))
Just (pkg_name,path) ->
return (Just (mkModule mod_name pkg_name,
ModuleLocation{
- hs_preprocd_file = "error:_package_module;_no_source",
- hi_file = path ++ '/':hi,
- obj_file = "error:_package_module;_no_object"
+ ml_hspp_file = Nothing,
+ ml_hs_file = Nothing,
+ ml_hi_file = Just (path ++ '/':hi),
+ ml_obj_file = Nothing
}
))
import Module ( ModuleName, moduleName, mkModuleInThisPackage )
import CmdLineOpts
import ErrUtils ( dumpIfSet_dyn )
+import Util ( unJust )
import UniqSupply ( mkSplitUniqSupply )
import Bag ( emptyBag )
hscMain dflags source_unchanged location maybe_old_iface hst hit pcs
= do {
+ putStrLn ( "hscMain: location =\n" ++ show location);
putStrLn "checking old iface ...";
(pcs_ch, check_errs, (recomp_reqd, maybe_checked_iface))
- <- checkOldIface dflags hit hst pcs (hi_file location)
+ <- checkOldIface dflags hit hst pcs (unJust (ml_hi_file location) "hscMain")
source_unchanged maybe_old_iface;
if check_errs then
return (HscFail pcs_ch)
;
-- putStrLn ("toInterp = " ++ show toInterp);
-- PARSE
- maybe_parsed <- myParseModule dflags (hs_preprocd_file location);
+ maybe_parsed
+ <- myParseModule dflags (unJust (ml_hspp_file location) "hscRecomp:hspp");
case maybe_parsed of {
Nothing -> return (HscFail pcs_ch);
Just rdr_module -> do {
Just (fif, sdoc) -> Just fif; Nothing -> Nothing
;
-- Write the interface file
- writeIface maybe_final_iface
+ writeIface (unJust (ml_hi_file location) "hscRecomp:hi") maybe_final_iface
;
-- do the rest of code generation/emission
(maybe_stub_h_filename, maybe_stub_c_filename, maybe_ibinds)
\begin{code}
data ModuleLocation
= ModuleLocation {
- hs_preprocd_file :: FilePath, -- location after preprocessing
- hi_file :: FilePath,
- obj_file :: FilePath
+ ml_hs_file :: Maybe FilePath,
+ ml_hspp_file :: Maybe FilePath, -- path of preprocessed source
+ ml_hi_file :: Maybe FilePath,
+ ml_obj_file :: Maybe FilePath
}
deriving Show
%************************************************************************
\begin{code}
-writeIface :: Maybe ModIface -> IO ()
-writeIface Nothing
+writeIface :: FilePath -> Maybe ModIface -> IO ()
+writeIface hi_path Nothing
= return ()
-writeIface (Just mod_iface)
- = do { maybe_found <- findModule mod_name ;
- ; case maybe_found of {
- Nothing -> printErrs (text "Can't write interface file for" <+> ppr mod_name) ;
- Just (_, locn) ->
-
- do { let filename = hi_file locn
- ; if_hdl <- openFile filename WriteMode
+writeIface hi_path (Just mod_iface)
+ = do { if_hdl <- openFile hi_path WriteMode
; printForIface if_hdl (pprIface mod_iface)
; hClose if_hdl
- }}}
- where
- mod_name = moduleName (mi_module mod_iface)
+ }
pprIface :: ModIface -> SDoc
pprIface iface
instDeclFVs, tyClDeclFVs, ruleDeclFVs
)
-import CmdLineOpts ( DynFlags, DynFlag(..) )
+import CmdLineOpts ( DynFlags, DynFlag(..), dopt )
import RnMonad
import RnNames ( getGlobalNames )
import RnSource ( rnSourceDecls, rnTyClDecl, rnIfaceRuleDecl, rnInstDecl )
import RnIfaces ( slurpImpDecls, mkImportInfo,
getInterfaceExports, closeDecls,
- RecompileRequired, recompileRequired
+ RecompileRequired, outOfDate, recompileRequired
)
import RnHiFiles ( readIface, removeContext,
loadExports, loadFixDecls, loadDeprecs )
lookupOrigNames, lookupGlobalRn, newGlobalName
)
import Module ( Module, ModuleName, WhereFrom(..),
- moduleNameUserString, moduleName, moduleEnvElts
+ moduleNameUserString, moduleName,
+ mkModuleInThisPackage, mkModuleName, moduleEnvElts
)
import Name ( Name, isLocallyDefined, NamedThing(..), getSrcLoc,
nameOccName, nameModule,
-- True <=> errors happened
checkOldIface dflags hit hst pcs iface_path source_unchanged maybe_iface
- = initRn dflags hit hst pcs (panic "checkOldIface: bogus mod") $
-
- -- Load the old interface file, if we havn't already got it
- loadOldIface iface_path maybe_iface `thenRn` \ maybe_iface2 ->
-
- -- Check versions
- recompileRequired iface_path source_unchanged maybe_iface2 `thenRn` \ recompile ->
-
- returnRn (recompile, maybe_iface2)
+ = case maybe_iface of
+ Just old_iface -> -- Use the one we already have
+ startRn (mi_module old_iface) $
+ check_versions old_iface
+ Nothing -- try and read it from a file
+ -> do read_result <- readIface do_traceRn iface_path
+ case read_result of
+ Left err -> -- Old interface file not found, or garbled; give up
+ return (pcs, False, (outOfDate, Nothing))
+ Right parsed_iface
+ -> startRn (pi_mod parsed_iface) $
+ loadOldIface parsed_iface `thenRn` \ m_iface ->
+ check_versions m_iface
+ where
+ check_versions :: ModIface -> RnMG (RecompileRequired, Maybe ModIface)
+ check_versions iface
+ = -- Check versions
+ recompileRequired iface_path source_unchanged iface
+ `thenRn` \ recompile ->
+ returnRn (recompile, Just iface)
+
+ do_traceRn = dopt Opt_D_dump_rn_trace dflags
+ ioTraceRn sdoc = if do_traceRn then printErrs sdoc else return ()
+ startRn mod = initRn dflags hit hst pcs mod
\end{code}
+I think the following function should now have a more representative name,
+but what?
\begin{code}
-loadOldIface :: FilePath -> Maybe ModIface -> RnMG (Maybe ModIface)
-loadOldIface iface_path (Just iface)
- = returnRn (Just iface)
-
-loadOldIface iface_path Nothing
- = -- LOAD THE OLD INTERFACE FILE
- -- call readIface ...
- readIface iface_path `thenRn` \ read_result ->
- case read_result of {
- Left err -> -- Old interface file not found, or garbled, so we'd better bail out
- traceRn (vcat [ptext SLIT("No old interface file:"), err]) `thenRn_`
- returnRn Nothing ;
-
- Right iface ->
-
- -- RENAME IT
+loadOldIface :: ParsedIface -> RnMG ModIface
+
+loadOldIface parsed_iface
+ = let iface = parsed_iface
+ in -- RENAME IT
let mod = pi_mod iface
doc_str = ptext SLIT("need usage info from") <+> ppr mod
in
loadHomeRules (pi_rules iface) `thenRn` \ rules ->
loadHomeInsts (pi_insts iface) `thenRn` \ insts ->
returnRn (decls, rules, insts)
- ) `thenRn` \ ((decls_vers, new_decls), (rule_vers, new_rules), new_insts) ->
+ )
+ `thenRn` \ ((decls_vers, new_decls), (rule_vers, new_rules), new_insts) ->
mapRn loadHomeUsage (pi_usages iface) `thenRn` \ usages ->
- loadExports (pi_exports iface) `thenRn` \ (export_vers, avails) ->
+ loadExports (pi_exports iface) `thenRn` \ (export_vers, avails) ->
loadFixDecls mod (pi_fixity iface) `thenRn` \ fix_env ->
loadDeprecs mod (pi_deprecs iface) `thenRn` \ deprec_env ->
let
mi_globals = panic "No mi_globals in old interface"
}
in
- returnRn (Just mod_iface)
- }
+ returnRn mod_iface
\end{code}
\begin{code}
#include "HsVersions.h"
-import CmdLineOpts ( opt_IgnoreIfacePragmas )
+import CmdLineOpts ( DynFlag(..), opt_IgnoreIfacePragmas )
import HscTypes ( ModuleLocation(..),
ModIface(..), emptyModIface,
VersionInfo(..),
import FastString ( mkFastString )
import ErrUtils ( Message )
import Finder ( findModule )
+import Util ( unJust )
import Lex
import FiniteMap
import Outputable
import Bag
+
+import Monad ( when )
\end{code}
= returnRn []
\end{code}
-
-
%*********************************************************
%* *
\subsection{Reading an interface file}
findAndReadIface doc_str mod_name hi_boot_file
= traceRn trace_msg `thenRn_`
ioToRnM (findModule mod_name) `thenRn` \ maybe_found ->
-
+ doptRn Opt_D_dump_rn_trace `thenRn` \ rn_trace ->
case maybe_found of
Right (Just (wanted_mod,locn))
- -> readIface (hi_file locn ++ if hi_boot_file then "-boot" else "")
+ -> ioToRnM_no_fail (
+ readIface rn_trace
+ (unJust (ml_hi_file locn) "findAndReadIface"
+ ++ if hi_boot_file then "-boot" else "")
+ )
`thenRn` \ read_result ->
case read_result of
Left bad -> returnRn (Left bad)
@readIface@ tries just the one file.
\begin{code}
-readIface :: String -> RnM d (Either Message ParsedIface)
+readIface :: Bool -> String -> IO (Either Message ParsedIface)
-- Nothing <=> file not found, or unreadable, or illegible
-- Just x <=> successfully found and parsed
-readIface file_path
- = traceRn (ptext SLIT("readIFace") <+> text file_path) `thenRn_`
- ioToRnM (hGetStringBuffer False file_path) `thenRn` \ read_result ->
- case read_result of
- Right contents ->
- case parseIface contents
+readIface tr file_path
+ = when tr (printErrs (ptext SLIT("readIFace") <+> text file_path))
+ >>
+ ((hGetStringBuffer False file_path >>= \ contents ->
+ case parseIface contents
PState{ bol = 0#, atbol = 1#,
context = [],
glasgow_exts = 1#,
loc = mkSrcLoc (mkFastString file_path) 1 } of
- POk _ (PIface iface) -> returnRn (Right iface)
+ POk _ (PIface iface) -> return (Right iface)
PFailed err -> bale_out err
parse_result -> bale_out empty
-- This last case can happen if the interface file is (say) empty
-- in which case the parser thinks it looks like an IdInfo or
-- something like that. Just an artefact of the fact that the
-- parser is used for several purposes at once.
-
- Left io_err -> bale_out (text (show io_err))
+ )
+ `catch`
+ (\ io_err -> bale_out (text (show io_err))))
where
- bale_out err = returnRn (Left (badIfaceFile file_path err))
+ bale_out err = return (Left (badIfaceFile file_path err))
\end{code}
recompileRequired :: FilePath -- Only needed for debug msgs
-> Bool -- Source unchanged
- -> Maybe ModIface -- Old interface, if any
+ -> ModIface -- Old interface
-> RnMG RecompileRequired
-recompileRequired iface_path source_unchanged maybe_iface
+recompileRequired iface_path source_unchanged iface
= traceRn (text "Considering whether compilation is required for" <+> text iface_path <> colon) `thenRn_`
-- CHECK WHETHER THE SOURCE HAS CHANGED
else
-- CHECK WHETHER WE HAVE AN OLD IFACE
- case maybe_iface of
- Nothing -> traceRn (nest 4 (ptext SLIT("No old interface file"))) `thenRn_`
- returnRn outOfDate ;
-
- Just iface -> -- Source code unchanged and no errors yet... carry on
- checkList [checkModUsage u | u <- mi_usages iface]
+ -- Source code unchanged and no errors yet... carry on
+ checkList [checkModUsage u | u <- mi_usages iface]
checkList :: [RnMG RecompileRequired] -> RnMG RecompileRequired
checkList [] = returnRn upToDate
ioToRnM io rn_down g_down = (io >>= \ ok -> return (Right ok))
`catch`
(\ err -> return (Left err))
+
+ioToRnM_no_fail :: IO r -> RnM d r
+ioToRnM_no_fail io rn_down g_down
+ = (io >>= \ ok -> return ok)
+ `catch`
+ (\ err -> panic "ioToRnM_no_fail: the I/O operation failed!")
traceRn :: SDoc -> RnM d ()
traceRn msg
-- for-loop
nTimes,
+ -- maybe-ish
+ unJust,
+
-- sorting
IF_NOT_GHC(quicksort COMMA stableSortLt COMMA mergesort COMMA)
sortLt,
#include "HsVersions.h"
-import IO ( hPutStrLn, stderr )
import List ( zipWith4 )
+import Maybe ( Maybe(..) )
import Panic ( panic )
import IOExts ( IORef, newIORef, unsafePerformIO )
import FastTypes
nTimes n f = f . nTimes (n-1) f
\end{code}
+%************************************************************************
+%* *
+\subsection{Maybe-ery}
+%* *
+%************************************************************************
+
+\begin{code}
+unJust :: Maybe a -> String -> a
+unJust (Just x) who = x
+unJust Nothing who = panic ("unJust of Nothing, called by " ++ who)
+\end{code}
%************************************************************************
%* *
projects / ghc-hetmet.git / commitdiff