import Type hiding (typeKind)
import TcType hiding (typeKind)
import Id
-import Var hiding (setIdType)
+import Var
import TysPrim ( alphaTyVars )
import TyCon
import Class
import Control.Monad
import System.Exit ( exitWith, ExitCode(..) )
import System.Time ( ClockTime, getClockTime )
-import Control.Exception as Exception hiding (handle)
+import Exception
import Data.IORef
import System.FilePath
import System.IO
import System.IO.Error ( try, isDoesNotExistError )
+#if __GLASGOW_HASKELL__ >= 609
+import Data.Typeable (cast)
+#endif
import Prelude hiding (init)
-- the top level of your program. The default handlers output the error
-- message(s) to stderr and exit cleanly.
defaultErrorHandler :: DynFlags -> IO a -> IO a
-defaultErrorHandler dflags inner =
+defaultErrorHandler dflags inner =
-- top-level exception handler: any unrecognised exception is a compiler bug.
+#if __GLASGOW_HASKELL__ < 609
handle (\exception -> do
- hFlush stdout
- case exception of
- -- an IO exception probably isn't our fault, so don't panic
- IOException _ ->
- fatalErrorMsg dflags (text (show exception))
- AsyncException StackOverflow ->
- fatalErrorMsg dflags (text "stack overflow: use +RTS -K<size> to increase it")
- _other ->
- fatalErrorMsg dflags (text (show (Panic (show exception))))
- exitWith (ExitFailure 1)
+ hFlush stdout
+ case exception of
+ -- an IO exception probably isn't our fault, so don't panic
+ IOException _ ->
+ fatalErrorMsg dflags (text (show exception))
+ AsyncException StackOverflow ->
+ fatalErrorMsg dflags (text "stack overflow: use +RTS -K<size> to increase it")
+ ExitException _ -> throw exception
+ _ ->
+ fatalErrorMsg dflags (text (show (Panic (show exception))))
+ exitWith (ExitFailure 1)
+ ) $
+#else
+ handle (\(SomeException exception) -> do
+ hFlush stdout
+ case cast exception of
+ -- an IO exception probably isn't our fault, so don't panic
+ Just (ioe :: IOException) ->
+ fatalErrorMsg dflags (text (show ioe))
+ _ -> case cast exception of
+ Just StackOverflow ->
+ fatalErrorMsg dflags (text "stack overflow: use +RTS -K<size> to increase it")
+ _ -> case cast exception of
+ Just (ex :: ExitCode) -> throw ex
+ _ ->
+ fatalErrorMsg dflags
+ (text (show (Panic (show exception))))
+ exitWith (ExitFailure 1)
) $
+#endif
-- program errors: messages with locations attached. Sometimes it is
-- convenient to just throw these as exceptions.
- handleDyn (\dyn -> do printBagOfErrors dflags (unitBag dyn)
- exitWith (ExitFailure 1)) $
+ handleErrMsg
+ (\em -> do printBagOfErrors dflags (unitBag em)
+ exitWith (ExitFailure 1)) $
-- error messages propagated as exceptions
- handleDyn (\dyn -> do
+ handleGhcException
+ (\ge -> do
hFlush stdout
- case dyn of
+ case ge of
PhaseFailed _ code -> exitWith code
Interrupted -> exitWith (ExitFailure 1)
- _ -> do fatalErrorMsg dflags (text (show (dyn :: GhcException)))
+ _ -> do fatalErrorMsg dflags (text (show ge))
exitWith (ExitFailure 1)
) $
inner
defaultCleanupHandler :: DynFlags -> IO a -> IO a
defaultCleanupHandler dflags inner =
-- make sure we clean up after ourselves
- later (do cleanTempFiles dflags
+ inner `onException`
+ (do cleanTempFiles dflags
cleanTempDirs dflags
)
-- exceptions will be blocked while we clean the temporary files,
-- so there shouldn't be any difficulty if we receive further
-- signals.
- inner
-- | Starts a new session. A session consists of a set of loaded
guessTarget file Nothing
| isHaskellSrcFilename file
= return (Target (TargetFile file Nothing) Nothing)
+ | looksLikeModuleName file
+ = return (Target (TargetModule (mkModuleName file)) Nothing)
| otherwise
= do exists <- doesFileExist hs_file
if exists
if exists
then return (Target (TargetFile lhs_file Nothing) Nothing)
else do
- return (Target (TargetModule (mkModuleName file)) Nothing)
+ throwGhcException
+ (ProgramError (showSDoc $
+ text "target" <+> quotes (text file) <+>
+ text "is not a module name or a source file"))
where
hs_file = file <.> "hs"
lhs_file = file <.> "lhs"
reachableBackwards :: ModuleName -> [ModSummary] -> [ModSummary]
reachableBackwards mod summaries
- = [ ms | (ms,_,_) <- map vertex_fn nodes_we_want ]
- where
- -- all the nodes reachable by traversing the edges backwards
- -- from the root node:
- nodes_we_want = reachable (transposeG graph) root
-
- -- the rest just sets up the graph:
- (nodes, lookup_key) = moduleGraphNodes False summaries
- (graph, vertex_fn, key_fn) = graphFromEdges' nodes
- root
- | Just key <- lookup_key HsBootFile mod, Just v <- key_fn key = v
- | otherwise = panic "reachableBackwards"
+ = [ ms | (ms,_,_) <- reachableG (transposeG graph) root ]
+ where -- the rest just sets up the graph:
+ (graph, lookup_node) = moduleGraphNodes False summaries
+ root = expectJust "reachableBackwards" (lookup_node HsBootFile mod)
-- ---------------------------------------------------------------------------
-- Topological sort of the module graph
+type SummaryNode = (ModSummary, Int, [Int])
+
topSortModuleGraph
:: Bool -- Drop hi-boot nodes? (see below)
-> [ModSummary]
-- the a source-import of Foo is an import of Foo
-- The resulting graph has no hi-boot nodes, but can by cyclic
-topSortModuleGraph drop_hs_boot_nodes summaries Nothing
- = stronglyConnComp (fst (moduleGraphNodes drop_hs_boot_nodes summaries))
-topSortModuleGraph drop_hs_boot_nodes summaries (Just mod)
- = stronglyConnComp (map vertex_fn (reachable graph root))
- where
- -- restrict the graph to just those modules reachable from
- -- the specified module. We do this by building a graph with
- -- the full set of nodes, and determining the reachable set from
- -- the specified node.
- (nodes, lookup_key) = moduleGraphNodes drop_hs_boot_nodes summaries
- (graph, vertex_fn, key_fn) = graphFromEdges' nodes
- root
- | Just key <- lookup_key HsSrcFile mod, Just v <- key_fn key = v
- | otherwise = throwDyn (ProgramError "module does not exist")
+topSortModuleGraph drop_hs_boot_nodes summaries mb_root_mod
+ = map (fmap summaryNodeSummary) $ stronglyConnCompG initial_graph
+ where
+ (graph, lookup_node) = moduleGraphNodes drop_hs_boot_nodes summaries
+
+ initial_graph = case mb_root_mod of
+ Nothing -> graph
+ Just root_mod ->
+ -- restrict the graph to just those modules reachable from
+ -- the specified module. We do this by building a graph with
+ -- the full set of nodes, and determining the reachable set from
+ -- the specified node.
+ let root | Just node <- lookup_node HsSrcFile root_mod, graph `hasVertexG` node = node
+ | otherwise = ghcError (ProgramError "module does not exist")
+ in graphFromEdgedVertices (seq root (reachableG graph root))
+
+summaryNodeKey :: SummaryNode -> Int
+summaryNodeKey (_, k, _) = k
+
+summaryNodeSummary :: SummaryNode -> ModSummary
+summaryNodeSummary (s, _, _) = s
moduleGraphNodes :: Bool -> [ModSummary]
- -> ([(ModSummary, Int, [Int])], HscSource -> ModuleName -> Maybe Int)
-moduleGraphNodes drop_hs_boot_nodes summaries = (nodes, lookup_key)
- where
- -- Drop hs-boot nodes by using HsSrcFile as the key
- hs_boot_key | drop_hs_boot_nodes = HsSrcFile
- | otherwise = HsBootFile
-
- -- We use integers as the keys for the SCC algorithm
- nodes :: [(ModSummary, Int, [Int])]
- nodes = [(s, expectJust "topSort" $
- lookup_key (ms_hsc_src s) (ms_mod_name s),
- out_edge_keys hs_boot_key (map unLoc (ms_srcimps s)) ++
- out_edge_keys HsSrcFile (map unLoc (ms_imps s)) ++
- (-- see [boot-edges] below
- if drop_hs_boot_nodes || ms_hsc_src s == HsBootFile
- then []
- else case lookup_key HsBootFile (ms_mod_name s) of
- Nothing -> []
- Just k -> [k])
- )
- | s <- summaries
- , not (isBootSummary s && drop_hs_boot_nodes) ]
- -- Drop the hi-boot ones if told to do so
-
- -- [boot-edges] if this is a .hs and there is an equivalent
- -- .hs-boot, add a link from the former to the latter. This
- -- has the effect of detecting bogus cases where the .hs-boot
- -- depends on the .hs, by introducing a cycle. Additionally,
- -- it ensures that we will always process the .hs-boot before
- -- the .hs, and so the HomePackageTable will always have the
- -- most up to date information.
-
- key_map :: NodeMap Int
- key_map = listToFM ([(moduleName (ms_mod s), ms_hsc_src s)
- | s <- summaries]
- `zip` [1..])
-
- lookup_key :: HscSource -> ModuleName -> Maybe Int
- lookup_key hs_src mod = lookupFM key_map (mod, hs_src)
-
- out_edge_keys :: HscSource -> [ModuleName] -> [Int]
- out_edge_keys hi_boot ms = mapCatMaybes (lookup_key hi_boot) ms
- -- If we want keep_hi_boot_nodes, then we do lookup_key with
- -- the IsBootInterface parameter True; else False
+ -> (Graph SummaryNode, HscSource -> ModuleName -> Maybe SummaryNode)
+moduleGraphNodes drop_hs_boot_nodes summaries = (graphFromEdgedVertices nodes, lookup_node)
+ where
+ numbered_summaries = zip summaries [1..]
+
+ lookup_node :: HscSource -> ModuleName -> Maybe SummaryNode
+ lookup_node hs_src mod = lookupFM node_map (mod, hs_src)
+
+ lookup_key :: HscSource -> ModuleName -> Maybe Int
+ lookup_key hs_src mod = fmap summaryNodeKey (lookup_node hs_src mod)
+
+ node_map :: NodeMap SummaryNode
+ node_map = listToFM [ ((moduleName (ms_mod s), ms_hsc_src s), node)
+ | node@(s, _, _) <- nodes ]
+
+ -- We use integers as the keys for the SCC algorithm
+ nodes :: [SummaryNode]
+ nodes = [ (s, key, out_keys)
+ | (s, key) <- numbered_summaries
+ -- Drop the hi-boot ones if told to do so
+ , not (isBootSummary s && drop_hs_boot_nodes)
+ , let out_keys = out_edge_keys hs_boot_key (map unLoc (ms_srcimps s)) ++
+ out_edge_keys HsSrcFile (map unLoc (ms_imps s)) ++
+ (-- see [boot-edges] below
+ if drop_hs_boot_nodes || ms_hsc_src s == HsBootFile
+ then []
+ else case lookup_key HsBootFile (ms_mod_name s) of
+ Nothing -> []
+ Just k -> [k]) ]
+
+ -- [boot-edges] if this is a .hs and there is an equivalent
+ -- .hs-boot, add a link from the former to the latter. This
+ -- has the effect of detecting bogus cases where the .hs-boot
+ -- depends on the .hs, by introducing a cycle. Additionally,
+ -- it ensures that we will always process the .hs-boot before
+ -- the .hs, and so the HomePackageTable will always have the
+ -- most up to date information.
+
+ -- Drop hs-boot nodes by using HsSrcFile as the key
+ hs_boot_key | drop_hs_boot_nodes = HsSrcFile
+ | otherwise = HsBootFile
+
+ out_edge_keys :: HscSource -> [ModuleName] -> [Int]
+ out_edge_keys hi_boot ms = mapCatMaybes (lookup_key hi_boot) ms
+ -- If we want keep_hi_boot_nodes, then we do lookup_key with
+ -- the IsBootInterface parameter True; else False
type NodeKey = (ModuleName, HscSource) -- The nodes of the graph are
-- in which case there can be repeats
downsweep hsc_env old_summaries excl_mods allow_dup_roots
= -- catch error messages and return them
- handleDyn (\err_msg -> printBagOfErrors (hsc_dflags hsc_env) (unitBag err_msg) >> return Nothing) $ do
+ handleErrMsg
+ (\err_msg -> printBagOfErrors (hsc_dflags hsc_env) (unitBag err_msg) >> return Nothing) $ do
rootSummaries <- mapM getRootSummary roots
let root_map = mkRootMap rootSummaries
checkDuplicates root_map
= do exists <- doesFileExist file
if exists
then summariseFile hsc_env old_summaries file mb_phase maybe_buf
- else throwDyn $ mkPlainErrMsg noSrcSpan $
+ else throwErrMsg $ mkPlainErrMsg noSrcSpan $
text "can't find file:" <+> text file
getRootSummary (Target (TargetModule modl) maybe_buf)
= do maybe_summary <- summariseModule hsc_env old_summary_map False
if ms_hs_date old_summary == src_timestamp
then do -- update the object-file timestamp
obj_timestamp <-
- if isObjectTarget (hscTarget (hsc_dflags hsc_env)) -- #1205
+ if isObjectTarget (hscTarget (hsc_dflags hsc_env)) -- bug #1205
then getObjTimestamp location False
else return Nothing
return old_summary{ ms_obj_date = obj_timestamp }
-- Drop external-pkg
ASSERT(modulePackageId mod /= thisPackage dflags)
return Nothing
- where
err -> noModError dflags loc wanted_mod err
-- Not found
(srcimps, the_imps, L mod_loc mod_name) <- getImports dflags' buf hspp_fn src_fn
when (mod_name /= wanted_mod) $
- throwDyn $ mkPlainErrMsg mod_loc $
+ throwErrMsg $ mkPlainErrMsg mod_loc $
text "File name does not match module name:"
$$ text "Saw:" <+> quotes (ppr mod_name)
$$ text "Expected:" <+> quotes (ppr wanted_mod)
noModError :: DynFlags -> SrcSpan -> ModuleName -> FindResult -> IO ab
-- ToDo: we don't have a proper line number for this error
noModError dflags loc wanted_mod err
- = throwDyn $ mkPlainErrMsg loc $ cannotFindModule dflags wanted_mod err
+ = throwErrMsg $ mkPlainErrMsg loc $ cannotFindModule dflags wanted_mod err
noHsFileErr :: SrcSpan -> String -> a
noHsFileErr loc path
- = throwDyn $ mkPlainErrMsg loc $ text "Can't find" <+> text path
+ = throwErrMsg $ mkPlainErrMsg loc $ text "Can't find" <+> text path
packageModErr :: ModuleName -> a
packageModErr mod
- = throwDyn $ mkPlainErrMsg noSrcSpan $
+ = throwErrMsg $ mkPlainErrMsg noSrcSpan $
text "module" <+> quotes (ppr mod) <+> text "is a package module"
multiRootsErr :: [ModSummary] -> IO ()
multiRootsErr [] = panic "multiRootsErr"
multiRootsErr summs@(summ1:_)
- = throwDyn $ mkPlainErrMsg noSrcSpan $
+ = throwErrMsg $ mkPlainErrMsg noSrcSpan $
text "module" <+> quotes (ppr mod) <+>
text "is defined in multiple files:" <+>
sep (map text files)
-- 'setContext'.
lookupGlobalName :: Session -> Name -> IO (Maybe TyThing)
lookupGlobalName s name = withSession s $ \hsc_env -> do
- eps <- readIORef (hsc_EPS hsc_env)
+ eps <- hscEPS hsc_env
return $! lookupType (hsc_dflags hsc_env)
(hsc_HPT hsc_env) (eps_PTE eps) name
res <- findImportedModule hsc_env mod_name maybe_pkg
case res of
Found _ m | modulePackageId m /= this_pkg -> return m
- | otherwise -> throwDyn (CmdLineError (showSDoc $
+ | otherwise -> ghcError (CmdLineError (showSDoc $
text "module" <+> quotes (ppr (moduleName m)) <+>
text "is not loaded"))
err -> let msg = cannotFindModule dflags mod_name err in
- throwDyn (CmdLineError (showSDoc msg))
+ ghcError (CmdLineError (showSDoc msg))
#ifdef GHCI
getHistorySpan :: Session -> History -> IO SrcSpan
projects / ghc-hetmet.git / blobdiff