+-----------------------------------------------------------------------------
+-- create tags file for currently loaded modules.
+
+createETagsFileCmd, createCTagsFileCmd :: String -> GHCi ()
+
+createCTagsFileCmd "" = ghciCreateTagsFile CTags "tags"
+createCTagsFileCmd file = ghciCreateTagsFile CTags file
+
+createETagsFileCmd "" = ghciCreateTagsFile ETags "TAGS"
+createETagsFileCmd file = ghciCreateTagsFile ETags file
+
+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 '" ++ moduleString 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 ()
+browseCmd m =
+ case words m of
+ ['*':m] | looksLikeModuleName m -> browseModule m False
+ [m] | looksLikeModuleName m -> browseModule m True
+ _ -> throwDyn (CmdLineError "syntax: :browse <module>")
+
+browseModule m exports_only = do
+ s <- getSession
+
+ let modl = GHC.mkModule m
+ is_interpreted <- io (GHC.moduleIsInterpreted s modl)
+ when (not is_interpreted && not exports_only) $
+ throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted"))
+
+ -- Temporarily set the context to the module we're interested in,
+ -- just so we can get an appropriate PrintUnqualified
+ (as,bs) <- io (GHC.getContext s)
+ io (if exports_only then GHC.setContext s [] [prelude_mod,modl]
+ else GHC.setContext s [modl] [])
+ unqual <- io (GHC.getPrintUnqual s)
+ io (GHC.setContext s as bs)
+
+ mb_mod_info <- io $ GHC.getModuleInfo s modl
+ case mb_mod_info of
+ Nothing -> throwDyn (CmdLineError ("unknown module: " ++ m))
+ Just mod_info -> do
+ let names
+ | exports_only = GHC.modInfoExports mod_info
+ | otherwise = fromMaybe [] (GHC.modInfoTopLevelScope mod_info)
+
+ filtered = filterOutChildren names
+
+ things <- io $ mapM (GHC.lookupName s) filtered
+
+ dflags <- getDynFlags
+ let exts = dopt Opt_GlasgowExts dflags
+ io (putStrLn (showSDocForUser unqual (
+ vcat (map (pprTyThingInContext exts) (catMaybes things))
+ )))
+ -- ToDo: modInfoInstances currently throws an exception for
+ -- package modules. When it works, we can do this:
+ -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
+
+-----------------------------------------------------------------------------
+-- Setting the module context
+
+setContext str
+ | all sensible mods = fn mods
+ | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
+ where
+ (fn, mods) = case str of
+ '+':stuff -> (addToContext, words stuff)
+ '-':stuff -> (removeFromContext, words stuff)
+ stuff -> (newContext, words stuff)
+
+ sensible ('*':m) = looksLikeModuleName m
+ sensible m = looksLikeModuleName m
+
+newContext mods = do
+ session <- getSession
+ (as,bs) <- separate session mods [] []
+ let bs' = if null as && prelude_mod `notElem` bs then prelude_mod:bs else bs
+ io (GHC.setContext session as bs')
+
+separate :: Session -> [String] -> [Module] -> [Module]
+ -> GHCi ([Module],[Module])
+separate session [] as bs = return (as,bs)
+separate session (('*':m):ms) as bs = do
+ let modl = GHC.mkModule m
+ b <- io (GHC.moduleIsInterpreted session modl)
+ if b then separate session ms (modl:as) bs
+ else throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted"))
+separate session (m:ms) as bs = separate session ms as (GHC.mkModule m:bs)
+
+prelude_mod = GHC.mkModule "Prelude"
+
+
+addToContext mods = do
+ cms <- getSession
+ (as,bs) <- io (GHC.getContext cms)
+
+ (as',bs') <- separate cms mods [] []
+
+ let as_to_add = as' \\ (as ++ bs)
+ bs_to_add = bs' \\ (as ++ bs)
+
+ io (GHC.setContext cms (as ++ as_to_add) (bs ++ bs_to_add))
+
+
+removeFromContext mods = do
+ cms <- getSession
+ (as,bs) <- io (GHC.getContext cms)
+
+ (as_to_remove,bs_to_remove) <- separate cms mods [] []
+
+ let as' = as \\ (as_to_remove ++ bs_to_remove)
+ bs' = bs \\ (as_to_remove ++ bs_to_remove)
+
+ io (GHC.setContext cms as' bs')
+