X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FGhciTags.hs;h=b53a56f967db5136b618bbd48e39ddfe6a1a1849;hb=8ffd91b6102f4ad3111cabdf6bdb1998f257887f;hp=686633e458c2dff875d42a1943614648483f4e8b;hpb=c5f6a3c65987b467cb64be30abd7a10ea6280b67;p=ghc-hetmet.git

diff --git a/compiler/ghci/GhciTags.hs b/compiler/ghci/GhciTags.hs
index 686633e..b53a56f 100644
--- a/compiler/ghci/GhciTags.hs
+++ b/compiler/ghci/GhciTags.hs
@@ -1,6 +1,6 @@
 -----------------------------------------------------------------------------
 --
--- GHCi's :ctags and :etags commands 
+-- GHCi's :ctags and :etags commands
 --
 -- (c) The GHC Team 2005-2007
 --
@@ -17,8 +17,10 @@ import Util
 -- into the GHC API instead
 import Name (nameOccName)
 import OccName (pprOccName)
+import MonadUtils
 
-import Control.Exception
+import Data.Maybe
+import Panic
 import Data.List
 import Control.Monad
 import System.IO
@@ -39,8 +41,7 @@ data TagsKind = ETags | CTags
 
 ghciCreateTagsFile :: TagsKind -> FilePath -> GHCi ()
 ghciCreateTagsFile kind file = do
-  session <- getSession
-  io $ createTagsFile session kind file
+  createTagsFile kind file
 
 -- ToDo: 
 -- 	- remove restriction that all modules must be interpreted
@@ -50,38 +51,40 @@ ghciCreateTagsFile kind file = do
 --	- extract createTagsFile so it can be used from the command-line
 --	  (probably need to fix first problem before this is useful).
 --
-createTagsFile :: Session -> TagsKind -> FilePath -> IO ()
-createTagsFile session tagskind tagFile = do
-  graph <- GHC.getModuleGraph session
+createTagsFile :: TagsKind -> FilePath -> GHCi ()
+createTagsFile tagskind tagFile = do
+  graph <- GHC.getModuleGraph
   let ms = map GHC.ms_mod graph
       tagModule m = do 
-        is_interpreted <- GHC.moduleIsInterpreted session m
+        is_interpreted <- GHC.moduleIsInterpreted m
         -- should we just skip these?
         when (not is_interpreted) $
-          throwDyn (CmdLineError ("module '" 
+          ghcError (CmdLineError ("module '" 
                                 ++ GHC.moduleNameString (GHC.moduleName m)
                                 ++ "' is not interpreted"))
-        mbModInfo <- GHC.getModuleInfo session m
-        let unqual 
-	      | Just modinfo <- mbModInfo,
-		Just unqual <- GHC.modInfoPrintUnqualified modinfo = unqual
-	      | otherwise = GHC.alwaysQualify
-
+        mbModInfo <- GHC.getModuleInfo m
+        unqual <-
+          case mbModInfo of
+             Just minf -> do
+                mb_print_unqual <- GHC.mkPrintUnqualifiedForModule minf
+                return (fromMaybe GHC.alwaysQualify mb_print_unqual)
+             Nothing ->
+                return GHC.alwaysQualify
         case mbModInfo of 
           Just modInfo -> return $! listTags unqual modInfo 
           _            -> return []
 
   mtags <- mapM tagModule ms
-  either_res <- collateAndWriteTags tagskind tagFile $ concat mtags
+  either_res <- liftIO $ collateAndWriteTags tagskind tagFile $ concat mtags
   case either_res of
-    Left e  -> hPutStrLn stderr $ ioeGetErrorString e
+    Left e  -> liftIO $ hPutStrLn stderr $ ioeGetErrorString e
     Right _ -> return ()
 
 listTags :: PrintUnqualified -> GHC.ModuleInfo -> [TagInfo]
 listTags unqual modInfo =
 	   [ tagInfo unqual name loc 
            | name <- GHC.modInfoExports modInfo
-           , let loc = nameSrcLoc name
+           , let loc = srcSpanStart (nameSrcSpan name)
            , isGoodSrcLoc loc
            ]
 
@@ -110,27 +113,26 @@ collateAndWriteTags ETags file tagInfos = do -- etags style, Emacs/XEmacs
   tagGroups <- mapM tagFileGroup groups 
   IO.try (writeFile file $ concat tagGroups)
   where
-    tagFileGroup group@[] = throwDyn (CmdLineError "empty tag file group??")
+    tagFileGroup [] = ghcError (CmdLineError "empty tag file group??")
     tagFileGroup group@((_,fileName,_,_):_) = do
       file <- readFile fileName -- need to get additional info from sources..
       let byLine (_,_,l1,_) (_,_,l2,_) = l1 <= l2
           sortedGroup = sortLe byLine group
           tags = unlines $ perFile sortedGroup 1 0 $ lines file
       return $ "\x0c\n" ++ fileName ++ "," ++ show (length tags) ++ "\n" ++ tags
-    perFile (tagInfo@(tag,file,lNo,colNo):tags) count pos (line:lines) | lNo>count =
-      perFile (tagInfo:tags) (count+1) (pos+length line) lines
-    perFile (tagInfo@(tag,file,lNo,colNo):tags) count pos lines@(line:_) | lNo==count =
-      showETag tagInfo line pos : perFile tags count pos lines
-    perFile tags count pos lines = []
+    perFile (tagInfo@(_tag, _file, lNo, _colNo):tags) count pos lines@(line:lines')
+     | lNo >  count = perFile (tagInfo:tags) (count+1) (pos+length line) lines'
+     | lNo == count = showETag tagInfo line pos : perFile tags count pos lines
+    perFile _ _ _ _ = []
 
 -- simple ctags format, for Vim et al
 showTag :: TagInfo -> String
-showTag (tag,file,lineNo,colNo)
+showTag (tag, file, lineNo, _colNo)
     =  tag ++ "\t" ++ file ++ "\t" ++ show lineNo
 
 -- etags format, for Emacs/XEmacs
 showETag :: TagInfo -> String -> Int -> String
-showETag (tag,file,lineNo,colNo) line charPos
+showETag (tag, _file, lineNo, colNo) line charPos
     =  take colNo line ++ tag
     ++ "\x7f" ++ tag
     ++ "\x01" ++ show lineNo