Add (a) CoreM monad, (b) new Annotations feature

[ghc-hetmet.git] / compiler / main / GHC.hs

diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index 38208a0..e8ea87c 100644 (file)
--- a/compiler/main/GHC.hs
+++ b/compiler/main/GHC.hs
@@ -74,6 +74,7 @@ module GHC (
        modInfoIsExportedName,
        modInfoLookupName,
        lookupGlobalName,
+       findGlobalAnns,
         mkPrintUnqualifiedForModule,
 
        -- * Printing
@@ -196,6 +197,20 @@ module GHC (
         srcSpanStartLine, srcSpanEndLine, 
         srcSpanStartCol, srcSpanEndCol,
 
+        -- ** Located
+       Located(..),
+
+       -- *** Constructing Located
+       noLoc, mkGeneralLocated,
+
+       -- *** Deconstructing Located
+       getLoc, unLoc,
+
+       -- *** Combining and comparing Located values
+       eqLocated, cmpLocated, combineLocs, addCLoc,
+        leftmost_smallest, leftmost_largest, rightmost,
+        spans, isSubspanOf,
+
        -- * Exceptions
        GhcException(..), showGhcException,
 
@@ -264,6 +279,7 @@ import StaticFlagParser
 import qualified StaticFlags
 import SysTools     ( initSysTools, cleanTempFiles, cleanTempFilesExcept,
                       cleanTempDirs )
+import Annotations
 import Module
 import LazyUniqFM
 import UniqSet
@@ -290,6 +306,8 @@ import System.Directory ( getModificationTime, doesFileExist,
 import Data.Maybe
 import Data.List
 import qualified Data.List as List
+import Data.Typeable    ( Typeable )
+import Data.Word        ( Word8 )
 import Control.Monad
 import System.Exit     ( exitWith, ExitCode(..) )
 import System.Time     ( ClockTime, getClockTime )
@@ -328,13 +346,6 @@ defaultErrorHandler dflags inner =
            exitWith (ExitFailure 1)
          ) $
 
-  -- program errors: messages with locations attached.  Sometimes it is
-  -- convenient to just throw these as exceptions.
-  handleErrMsg
-            (\em -> liftIO $ do
-                      printBagOfErrors dflags (unitBag em)
-                      exitWith (ExitFailure 1)) $
-
   -- error messages propagated as exceptions
   handleGhcException
             (\ge -> liftIO $ do
@@ -1166,6 +1177,7 @@ mkModGuts coreModule = ModGuts {
   mg_binds = cm_binds coreModule,
   mg_foreign = NoStubs,
   mg_warns = NoWarnings,
+  mg_anns = [],
   mg_hpc_info = emptyHpcInfo False,
   mg_modBreaks = emptyModBreaks,
   mg_vect_info = noVectInfo,
@@ -1696,11 +1708,12 @@ reachableBackwards mod summaries
 type SummaryNode = (ModSummary, Int, [Int])
 
 topSortModuleGraph
-         :: Bool               -- Drop hi-boot nodes? (see below)
+         :: Bool
+          -- ^ Drop hi-boot nodes? (see below)
          -> [ModSummary]
          -> Maybe ModuleName
          -> [SCC ModSummary]
--- Calculate SCCs of the module graph, possibly dropping the hi-boot nodes
+-- ^ 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
@@ -1708,10 +1721,10 @@ topSortModuleGraph
 --
 -- Drop hi-boot nodes (first boolean arg)? 
 --
---   False:    treat the hi-boot summaries as nodes of the graph,
+-- - @False@:  treat the hi-boot summaries as nodes of the graph,
 --             so the graph must be acyclic
 --
---   True:     eliminate the hi-boot nodes, and instead pretend
+-- - @True@:   eliminate the hi-boot nodes, and instead pretend
 --             the a source-import of Foo is an import of Foo
 --             The resulting graph has no hi-boot nodes, but can be cyclic
 
@@ -1864,7 +1877,7 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots
                if exists 
                    then summariseFile hsc_env old_summaries file mb_phase 
                                        obj_allowed maybe_buf
-                   else throwErrMsg $ mkPlainErrMsg noSrcSpan $
+                   else throwOneError $ mkPlainErrMsg noSrcSpan $
                           text "can't find file:" <+> text file
        getRootSummary (Target (TargetModule modl) obj_allowed maybe_buf)
           = do maybe_summary <- summariseModule hsc_env old_summary_map False 
@@ -2128,7 +2141,7 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod)
         (srcimps, the_imps, L mod_loc mod_name) <- liftIO $ getImports dflags' buf hspp_fn src_fn
 
        when (mod_name /= wanted_mod) $
-               throwErrMsg $ mkPlainErrMsg mod_loc $ 
+               throwOneError $ mkPlainErrMsg mod_loc $ 
                              text "File name does not match module name:" 
                              $$ text "Saw:" <+> quotes (ppr mod_name)
                               $$ text "Expected:" <+> quotes (ppr wanted_mod)
@@ -2204,21 +2217,21 @@ preprocessFile hsc_env src_fn mb_phase (Just (buf, _time))
 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
-  = throwErrMsg $ mkPlainErrMsg loc $ cannotFindModule dflags wanted_mod err
+  = throwOneError $ mkPlainErrMsg loc $ cannotFindModule dflags wanted_mod err
                                
-noHsFileErr :: SrcSpan -> String -> a
+noHsFileErr :: GhcMonad m => SrcSpan -> String -> m a
 noHsFileErr loc path
-  = throwErrMsg $ mkPlainErrMsg loc $ text "Can't find" <+> text path
+  = throwOneError $ mkPlainErrMsg loc $ text "Can't find" <+> text path
  
-packageModErr :: ModuleName -> a
+packageModErr :: GhcMonad m => ModuleName -> m a
 packageModErr mod
-  = throwErrMsg $ mkPlainErrMsg noSrcSpan $
+  = throwOneError $ mkPlainErrMsg noSrcSpan $
        text "module" <+> quotes (ppr mod) <+> text "is a package module"
 
 multiRootsErr :: [ModSummary] -> IO ()
 multiRootsErr [] = panic "multiRootsErr"
 multiRootsErr summs@(summ1:_)
-  = throwErrMsg $ mkPlainErrMsg noSrcSpan $
+  = throwOneError $ mkPlainErrMsg noSrcSpan $
        text "module" <+> quotes (ppr mod) <+> 
        text "is defined in multiple files:" <+>
        sep (map text files)
@@ -2404,6 +2417,11 @@ lookupGlobalName name = withSession $ \hsc_env -> do
    return $! lookupType (hsc_dflags hsc_env) 
                        (hsc_HPT hsc_env) (eps_PTE eps) name
 
+findGlobalAnns :: (GhcMonad m, Typeable a) => ([Word8] -> a) -> AnnTarget Name -> m [a]
+findGlobalAnns deserialize target = withSession $ \hsc_env -> do
+    ann_env <- liftIO $ prepareAnnotations hsc_env Nothing
+    return (findAnns deserialize ann_env target)
+
 #ifdef GHCI
 -- | get the GlobalRdrEnv for a session
 getGRE :: GhcMonad m => m GlobalRdrEnv