Index: InteractiveUI.hs
===================================================================
RCS file: /cvs/fptools/ghc/compiler/ghci/InteractiveUI.hs,v
retrieving revision 1.207
diff -r1.207 InteractiveUI.hs
24a25,31
> -- for createtags (should these come via GHC?)
> import Module( moduleUserString )
> import Name( nameSrcLoc, nameModule, nameOccName )
> import OccName( pprOccName )
> import SrcLoc( isGoodSrcLoc, srcLocFile, srcLocLine, srcLocCol )
> import Util( sortLe )
> 
112a120
>   ("tags",	keepGoing createTagsFileCmd),
840a849,950
> 
> -----------------------------------------------------------------------------
> -- create tags file for currently loaded modules
> -- ignore parameter for now, always create simple ctags format
> -- todo: sort tags?
> createTagsFileCmd :: String -> GHCi ()
> createTagsFileCmd "-c" = createTagsFile "tags"
> createTagsFileCmd "-e" = createTagsFile "TAGS"
> createTagsFileCmd _  = throwDyn (CmdLineError "syntax:  :tags -c|-e")
> 
> createTagsFile :: TagFile -> GHCi ()
> createTagsFile tagFile = do
>   session <- getSession
>   graph <- io (GHC.getModuleGraph session)
>   let ms = map GHC.ms_mod graph
>       tagModule m = do 
>         is_interpreted <- io (GHC.moduleIsInterpreted session m)
>         -- should we just skip these?
>         when (not is_interpreted) $
>           throwDyn (CmdLineError ("module '" ++ moduleUserString m ++ "' is not interpreted"))
> 
>         -- Temporarily set the context to the module we're interested in,
>         -- just so we can get an appropriate PrintUnqualified
>         -- ?how can setting and immmediate unsetting have an effect here?
>         (as,bs) <- io (GHC.getContext session)
>         io (GHC.setContext session [m] [])
>         io (GHC.setContext session as bs)
> 
>         mbModInfo <- io (GHC.getModuleInfo session m)
>         unqual <- io (GHC.getPrintUnqual session)
> 
>         case mbModInfo of 
>           Just modInfo -> listTags unqual modInfo 
>           _            -> return []
> 
>   mtags <- mapM tagModule ms
>   either_res <- collateAndWriteTags tagFile $ concat mtags
>   case either_res of
>     Left e  -> io (hPutStrLn stderr $ ioeGetErrorString e)
>     Right _ -> return ()
> 
> listTags :: PrintUnqualified -> GHC.ModuleInfo -> GHCi [TagInfo]
> listTags unqual modInfo =
>     return [ tagInfo unqual name loc 
>            | name <- GHC.modInfoExports modInfo
>            , let loc = nameSrcLoc name
>            , isGoodSrcLoc loc
>            ]
> 
> type TagFile = String -- tags, TAGS
> 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 :: TagFile -> [TagInfo] -> GHCi (Either IOError ())
> collateAndWriteTags "tags" tagInfos = do -- ctags style, Vim et al
>   let tags = unlines $ sortLe (<=) $ nub $ map showTag tagInfos
>   io (IO.try (writeFile "tags" tags))
> collateAndWriteTags "TAGS" 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 (IO.try (writeFile "TAGS" $ concat tagGroups))
>   where
>     tagFileGroup group@[] = throwDyn (CmdLineError "empty tag file group??")
>     tagFileGroup group@((_,fileName,_,_):_) = do
>       file <- io (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 = []
> collateAndWriteTags tags _ = 
>   throwDyn (CmdLineError ("don't know how to create tag file type"++tags))
> 
> -- 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