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 )
> import Util( sortLe )
> 
112a120
>   ("tags",	keepGoing createTagsFileCmd),
840a849,898
> 
> -----------------------------------------------------------------------------
> -- create tags file for currently loaded modules
> -- ignore parameter for now, always create simple ctags format
> -- todo: sort tags?
> createTagsFileCmd :: String -> GHCi ()
> createTagsFileCmd "" = createTagsFile
> createTagsFileCmd _  = throwDyn (CmdLineError "syntax:  :tags")
> 
> createTagsFile = 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 ->
>             return [ showSDocForUser unqual $ showTag name loc 
>                    | name <- GHC.modInfoExports modInfo
>                    , let loc = nameSrcLoc name
>                    , isGoodSrcLoc loc
>                    ]
>           _ -> return []
> 
>   mtags <- mapM tagModule ms
>   let tags = unlines $ sortLe (<=) $ nub $ concat mtags
>   either_res <- io (IO.try (writeFile "tags" tags))
>   case either_res of
>     Left e    -> io (hPutStrLn stderr $ ioeGetErrorString e)
>     Right _ -> return ()
> 
> showTag :: Name -> SrcLoc -> SDoc
> showTag name loc
>     =   pprOccName (nameOccName name)
>     <> text "\t" <> ftext (srcLocFile loc)
>     <> text "\t" <> text (show $ srcLocLine loc)