Columns now start at 1, as lines already did
[ghc-hetmet.git] / compiler / main / GHC.hs
index f63b98f..5289f71 100644 (file)
@@ -58,9 +58,6 @@ module GHC (
         compileCoreToObj,
         getModSummary,
 
-       -- * Parsing Haddock comments
-       parseHaddockComment,
-
        -- * Inspecting the module structure of the program
        ModuleGraph, ModSummary(..), ms_mod_name, ModLocation(..),
        getModuleGraph,
@@ -245,7 +242,6 @@ import qualified Linker
 import Linker           ( HValue )
 import ByteCodeInstr
 import BreakArray
-import NameSet
 import InteractiveEval
 import TcRnDriver
 #endif
@@ -265,10 +261,10 @@ import Var
 import TysPrim         ( alphaTyVars )
 import TyCon
 import Class
-import FunDeps
+-- import FunDeps
 import DataCon
 import Name             hiding ( varName )
-import OccName         ( parenSymOcc )
+-- import OccName              ( parenSymOcc )
 import InstEnv         ( Instance, instanceDFunId, pprInstance, pprInstanceHdr,
                           emptyInstEnv )
 import FamInstEnv       ( emptyFamInstEnv )
@@ -276,7 +272,7 @@ import SrcLoc
 --import CoreSyn
 import TidyPgm
 import DriverPipeline
-import DriverPhases    ( HscSource(..), Phase(..), isHaskellSrcFilename, startPhase )
+import DriverPhases    ( Phase(..), isHaskellSrcFilename, startPhase )
 import HeaderInfo
 import Finder
 import HscMain
@@ -301,8 +297,6 @@ import StringBuffer ( StringBuffer, hGetStringBuffer, nextChar )
 import Outputable
 import BasicTypes
 import Maybes          ( expectJust, mapCatMaybes )
-import HaddockParse
-import HaddockLex       ( tokenise )
 import FastString
 import Lexer
 
@@ -627,15 +621,6 @@ setGlobalTypeScope ids
       hscEnv{ hsc_global_type_env = extendTypeEnvWithIds emptyTypeEnv ids }
 
 -- -----------------------------------------------------------------------------
--- Parsing Haddock comments
-
-parseHaddockComment :: String -> Either String (HsDoc RdrName)
-parseHaddockComment string = 
-  case parseHaddockParagraphs (tokenise string) of
-    MyLeft x  -> Left x
-    MyRight x -> Right x
-
--- -----------------------------------------------------------------------------
 -- Loading the program
 
 -- | Perform a dependency analysis starting from the current targets
@@ -784,7 +769,7 @@ load2 how_much mod_graph = do
                                (flattenSCCs mg2_with_srcimps)
                                stable_mods
 
-       liftIO $ evaluate pruned_hpt
+       _ <- liftIO $ evaluate pruned_hpt
 
         -- before we unload anything, make sure we don't leave an old
         -- interactive context around pointing to dead bindings.  Also,
@@ -888,7 +873,7 @@ load2 how_much mod_graph = do
              let 
                main_mod = mainModIs dflags
                a_root_is_Main = any ((==main_mod).ms_mod) mod_graph
-               do_linking = a_root_is_Main || no_hs_main || not StaticFlags.opt_Static
+               do_linking = a_root_is_Main || no_hs_main || ghcLink dflags == LinkDynLib
 
              when (ghcLink dflags == LinkBinary 
                     && isJust ofile && not do_linking) $
@@ -1036,7 +1021,7 @@ instance DesugaredMod DesugaredModule where
 
 type ParsedSource      = Located (HsModule RdrName)
 type RenamedSource     = (HsGroup Name, [LImportDecl Name], Maybe [LIE Name],
-                          Maybe (HsDoc Name), HaddockModInfo Name)
+                          Maybe LHsDocString)
 type TypecheckedSource = LHsBinds Id
 
 -- NOTE:
@@ -1208,7 +1193,7 @@ compileCoreToObj simplify cm@(CoreModule{ cm_module = mName }) = do
   (iface, changed, _details, cgguts)
       <- hscNormalIface guts Nothing
   hscWriteIface iface changed modSummary
-  hscGenHardCode cgguts modSummary
+  _ <- hscGenHardCode cgguts modSummary
   return ()
 
 -- Makes a "vanilla" ModGuts.
@@ -1242,7 +1227,7 @@ compileCore simplify fn = do
    -- First, set the target to the desired filename
    target <- guessTarget fn Nothing
    addTarget target
-   load LoadAllTargets
+   _ <- load LoadAllTargets
    -- Then find dependencies
    modGraph <- depanal [] True
    case find ((== fn) . msHsFilePath) modGraph of
@@ -2333,18 +2318,28 @@ cyclicModuleErr ms
   = hang (ptext (sLit "Module imports form a cycle for modules:"))
        2 (vcat (map show_one ms))
   where
-    show_one ms = sep [ show_mod (ms_hsc_src ms) (ms_mod ms),
-                       nest 2 $ ptext (sLit "imports:") <+> 
-                                  (pp_imps HsBootFile (ms_srcimps ms)
-                                  $$ pp_imps HsSrcFile  (ms_imps ms))]
+    mods_in_cycle = map ms_mod_name ms
+    imp_modname = unLoc . ideclName . unLoc
+    just_in_cycle = filter ((`elem` mods_in_cycle) . imp_modname)
+
+    show_one ms = 
+           vcat [ show_mod (ms_hsc_src ms) (ms_mod_name ms) <+>
+                  maybe empty (parens . text) (ml_hs_file (ms_location ms)),
+                  nest 2 $ ptext (sLit "imports:") <+> vcat [
+                     pp_imps HsBootFile (just_in_cycle $ ms_srcimps ms),
+                     pp_imps HsSrcFile  (just_in_cycle $ ms_imps ms) ]
+                ]
     show_mod hsc_src mod = ppr mod <> text (hscSourceString hsc_src)
-    pp_imps src mods = fsep (map (show_mod src) mods)
+    pp_imps src imps = fsep (map (show_mod src . unLoc . ideclName . unLoc) imps)
 
 
 -- | Inform GHC that the working directory has changed.  GHC will flush
 -- its cache of module locations, since it may no longer be valid.
--- Note: if you change the working directory, you should also unload
--- the current program (set targets to empty, followed by load).
+-- 
+-- Note: Before changing the working directory make sure all threads running
+-- in the same session have stopped.  If you change the working directory,
+-- you should also unload the current program (set targets to empty,
+-- followed by load).
 workingDirectoryChanged :: GhcMonad m => m ()
 workingDirectoryChanged = withSession $ (liftIO . flushFinderCaches)
 
@@ -2534,7 +2529,7 @@ packageDbModules only_exposed = do
    return $
      [ mkModule pid modname | p <- pkgs
                             , not only_exposed || exposed p
-                            , pid <- [mkPackageId (package p)]
+                            , let pid = packageConfigId p
                             , modname <- exposedModules p ]
 
 -- -----------------------------------------------------------------------------
@@ -2585,7 +2580,7 @@ getModuleSourceAndFlags mod = do
 getTokenStream :: GhcMonad m => Module -> m [Located Token]
 getTokenStream mod = do
   (sourceFile, source, flags) <- getModuleSourceAndFlags mod
-  let startLoc = mkSrcLoc (mkFastString sourceFile) 0 0
+  let startLoc = mkSrcLoc (mkFastString sourceFile) 1 1
   case lexTokenStream source startLoc flags of
     POk _ ts  -> return ts
     PFailed span err -> throw $ mkSrcErr (unitBag $ mkPlainErrMsg span err)
@@ -2596,7 +2591,7 @@ getTokenStream mod = do
 getRichTokenStream :: GhcMonad m => Module -> m [(Located Token, String)]
 getRichTokenStream mod = do
   (sourceFile, source, flags) <- getModuleSourceAndFlags mod
-  let startLoc = mkSrcLoc (mkFastString sourceFile) 0 0
+  let startLoc = mkSrcLoc (mkFastString sourceFile) 1 1
   case lexTokenStream source startLoc flags of
     POk _ ts -> return $ addSourceToTokens startLoc source ts
     PFailed span err -> throw $ mkSrcErr (unitBag $ mkPlainErrMsg span err)
@@ -2627,7 +2622,7 @@ addSourceToTokens loc buf (t@(L span _) : ts)
 showRichTokenStream :: [(Located Token, String)] -> String
 showRichTokenStream ts = go startLoc ts ""
     where sourceFile = srcSpanFile (getLoc . fst . head $ ts)
-          startLoc = mkSrcLoc sourceFile 0 0
+          startLoc = mkSrcLoc sourceFile 1 1
           go _ [] = id
           go loc ((L span _, str):ts)
               | not (isGoodSrcSpan span) = go loc ts