CheckedModule(..) )
import Outputable
+-- for createtags (should these come via GHC?)
+import Module( moduleUserString )
+import Name( nameSrcLoc, nameModule, nameOccName )
+import OccName( pprOccName )
+import SrcLoc( isGoodSrcLoc, srcLocFile, srcLocLine, srcLocCol )
+
-- following all needed for :info... ToDo: remove
import IfaceSyn ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecls(..),
IfaceConDecl(..), IfaceType,
import StaticFlags ( opt_IgnoreDotGhci )
import Linker ( showLinkerState )
import Util ( removeSpaces, handle, global, toArgs,
- looksLikeModuleName, prefixMatch )
+ looksLikeModuleName, prefixMatch, sortLe )
import ErrUtils ( printErrorsAndWarnings )
#ifndef mingw32_HOST_OS
-import Util ( handle )
import System.Posix
#if __GLASGOW_HASKELL__ > 504
hiding (getEnv)
("check", keepGoing checkModule),
("set", keepGoing setCmd),
("show", keepGoing showCmd),
+ ("tags", keepGoing createTagsFileCmd),
("type", keepGoing typeOfExpr),
("kind", keepGoing kindOfType),
("unset", keepGoing unsetOptions),
" :show modules show the currently loaded modules\n" ++
" :show bindings show the current bindings made at the prompt\n" ++
"\n" ++
+ " :tags -e|-c create tags file for Vi (-c) or Emacs (-e)\n" ++
" :type <expr> show the type of <expr>\n" ++
" :kind <type> show the kind of <type>\n" ++
" :undef <cmd> undefine user-defined command :<cmd>\n" ++
foldr1 (\a b -> a ++ ',':b) (map fst cs)
++ ")") >> return False)
-noArgs c = throwDyn (CmdLineError ("command '" ++ c ++ "' takes no arguments"))
-
-
-----------------------------------------------------------------------------
-- To flush buffers for the *interpreted* computation we need
-- to refer to *its* stdout/stderr handles
shellEscape str = io (system str >> return False)
-----------------------------------------------------------------------------
+-- create tags file for currently loaded modules.
+
+createTagsFileCmd :: String -> GHCi ()
+createTagsFileCmd "-c" = ghciCreateTagsFile CTags "tags"
+createTagsFileCmd "-e" = ghciCreateTagsFile ETags "TAGS"
+createTagsFileCmd _ = throwDyn (CmdLineError "syntax: :tags -c|-e")
+
+data TagsKind = ETags | CTags
+
+ghciCreateTagsFile :: TagsKind -> FilePath -> GHCi ()
+ghciCreateTagsFile kind file = do
+ session <- getSession
+ io $ createTagsFile session kind file
+
+-- ToDo:
+-- - remove restriction that all modules must be interpreted
+-- (problem: we don't know source locations for entities unless
+-- we compiled the module.
+--
+-- - 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
+ let ms = map GHC.ms_mod graph
+ tagModule m = do
+ is_interpreted <- GHC.moduleIsInterpreted session m
+ -- should we just skip these?
+ when (not is_interpreted) $
+ throwDyn (CmdLineError ("module '" ++ moduleUserString m ++ "' is not interpreted"))
+
+ mbModInfo <- GHC.getModuleInfo session m
+ let unqual
+ | Just modinfo <- mbModInfo,
+ Just unqual <- GHC.modInfoPrintUnqualified modinfo = unqual
+ | otherwise = GHC.alwaysQualify
+
+ case mbModInfo of
+ Just modInfo -> return $! listTags unqual modInfo
+ _ -> return []
+
+ mtags <- mapM tagModule ms
+ either_res <- collateAndWriteTags tagskind tagFile $ concat mtags
+ case either_res of
+ Left e -> 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
+ , isGoodSrcLoc loc
+ ]
+
+type TagInfo = (String -- tag name
+ ,String -- file name
+ ,Int -- line number
+ ,Int -- column number
+ )
+
+-- get tag info, for later translation into Vim or Emacs style
+tagInfo :: PrintUnqualified -> Name -> SrcLoc -> TagInfo
+tagInfo unqual name loc
+ = ( showSDocForUser unqual $ pprOccName (nameOccName name)
+ , showSDocForUser unqual $ ftext (srcLocFile loc)
+ , srcLocLine loc
+ , srcLocCol loc
+ )
+
+collateAndWriteTags :: TagsKind -> FilePath -> [TagInfo] -> IO (Either IOError ())
+collateAndWriteTags CTags file tagInfos = do -- ctags style, Vim et al
+ let tags = unlines $ sortLe (<=) $ nub $ map showTag tagInfos
+ IO.try (writeFile file tags)
+collateAndWriteTags ETags file tagInfos = do -- etags style, Emacs/XEmacs
+ let byFile op (_,f1,_,_) (_,f2,_,_) = f1 `op` f2
+ groups = groupBy (byFile (==)) $ sortLe (byFile (<=)) tagInfos
+ tagGroups <- mapM tagFileGroup groups
+ IO.try (writeFile file $ concat tagGroups)
+ where
+ tagFileGroup group@[] = throwDyn (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 = []
+
+-- simple ctags format, for Vim et al
+showTag :: TagInfo -> String
+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
+ = take colNo line ++ tag
+ ++ "\x7f" ++ tag
+ ++ "\x01" ++ show lineNo
+ ++ "," ++ show charPos
+
+-----------------------------------------------------------------------------
-- Browsing a module's contents
browseCmd :: String -> GHCi ()
projects / ghc-hetmet.git / blobdiff