Merge remote-tracking branch 'origin/type-nats' into type-nats-merge
[ghc.git] / ghc / GhciTags.hs
1 -----------------------------------------------------------------------------
2 --
3 -- GHCi's :ctags and :etags commands
4 --
5 -- (c) The GHC Team 2005-2007
6 --
7 -----------------------------------------------------------------------------
8
9 {-# OPTIONS -fno-warn-tabs #-}
10 -- The above warning supression flag is a temporary kludge.
11 -- While working on this module you are encouraged to remove it and
12 -- detab the module (please do the detabbing in a separate patch). See
13 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSp
14 -- for details
15
16 {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
17 module GhciTags (
18 createCTagsWithLineNumbersCmd,
19 createCTagsWithRegExesCmd,
20 createETagsFileCmd
21 ) where
22
23 import Exception
24 import GHC
25 import GhciMonad
26 import Outputable
27 import Util
28
29 -- ToDo: figure out whether we need these, and put something appropriate
30 -- into the GHC API instead
31 import Name (nameOccName)
32 import OccName (pprOccName)
33 import MonadUtils
34
35 import Data.Maybe
36 import Panic
37 import Data.List
38 import Control.Monad
39 import System.IO
40 import System.IO.Error
41
42 -----------------------------------------------------------------------------
43 -- create tags file for currently loaded modules.
44
45 createCTagsWithLineNumbersCmd, createCTagsWithRegExesCmd,
46 createETagsFileCmd :: String -> GHCi ()
47
48 createCTagsWithLineNumbersCmd "" =
49 ghciCreateTagsFile CTagsWithLineNumbers "tags"
50 createCTagsWithLineNumbersCmd file =
51 ghciCreateTagsFile CTagsWithLineNumbers file
52
53 createCTagsWithRegExesCmd "" =
54 ghciCreateTagsFile CTagsWithRegExes "tags"
55 createCTagsWithRegExesCmd file =
56 ghciCreateTagsFile CTagsWithRegExes file
57
58 createETagsFileCmd "" = ghciCreateTagsFile ETags "TAGS"
59 createETagsFileCmd file = ghciCreateTagsFile ETags file
60
61 data TagsKind = ETags | CTagsWithLineNumbers | CTagsWithRegExes
62
63 ghciCreateTagsFile :: TagsKind -> FilePath -> GHCi ()
64 ghciCreateTagsFile kind file = do
65 createTagsFile kind file
66
67 -- ToDo:
68 -- - remove restriction that all modules must be interpreted
69 -- (problem: we don't know source locations for entities unless
70 -- we compiled the module.
71 --
72 -- - extract createTagsFile so it can be used from the command-line
73 -- (probably need to fix first problem before this is useful).
74 --
75 createTagsFile :: TagsKind -> FilePath -> GHCi ()
76 createTagsFile tagskind tagsFile = do
77 graph <- GHC.getModuleGraph
78 mtags <- mapM listModuleTags (map GHC.ms_mod graph)
79 either_res <- liftIO $ collateAndWriteTags tagskind tagsFile $ concat mtags
80 case either_res of
81 Left e -> liftIO $ hPutStrLn stderr $ ioeGetErrorString e
82 Right _ -> return ()
83
84
85 listModuleTags :: GHC.Module -> GHCi [TagInfo]
86 listModuleTags m = do
87 is_interpreted <- GHC.moduleIsInterpreted m
88 -- should we just skip these?
89 when (not is_interpreted) $
90 let mName = GHC.moduleNameString (GHC.moduleName m) in
91 ghcError (CmdLineError ("module '" ++ mName ++ "' is not interpreted"))
92 mbModInfo <- GHC.getModuleInfo m
93 case mbModInfo of
94 Nothing -> return []
95 Just mInfo -> do
96 mb_print_unqual <- GHC.mkPrintUnqualifiedForModule mInfo
97 let unqual = fromMaybe GHC.alwaysQualify mb_print_unqual
98 let names = fromMaybe [] $GHC.modInfoTopLevelScope mInfo
99 let localNames = filter ((m==) . nameModule) names
100 mbTyThings <- mapM GHC.lookupName localNames
101 return $! [ tagInfo unqual exported kind name realLoc
102 | tyThing <- catMaybes mbTyThings
103 , let name = getName tyThing
104 , let exported = GHC.modInfoIsExportedName mInfo name
105 , let kind = tyThing2TagKind tyThing
106 , let loc = srcSpanStart (nameSrcSpan name)
107 , RealSrcLoc realLoc <- [loc]
108 ]
109
110 where
111 tyThing2TagKind (AnId _) = 'v'
112 tyThing2TagKind (ADataCon _) = 'd'
113 tyThing2TagKind (ATyCon _) = 't'
114 tyThing2TagKind (ACoAxiom _) = 'x'
115
116
117 data TagInfo = TagInfo
118 { tagExported :: Bool -- is tag exported
119 , tagKind :: Char -- tag kind
120 , tagName :: String -- tag name
121 , tagFile :: String -- file name
122 , tagLine :: Int -- line number
123 , tagCol :: Int -- column number
124 , tagSrcInfo :: Maybe (String,Integer) -- source code line and char offset
125 }
126
127
128 -- get tag info, for later translation into Vim or Emacs style
129 tagInfo :: PrintUnqualified -> Bool -> Char -> Name -> RealSrcLoc -> TagInfo
130 tagInfo unqual exported kind name loc
131 = TagInfo exported kind
132 (showSDocForUser unqual $ pprOccName (nameOccName name))
133 (showSDocForUser unqual $ ftext (srcLocFile loc))
134 (srcLocLine loc) (srcLocCol loc) Nothing
135
136
137 collateAndWriteTags :: TagsKind -> FilePath -> [TagInfo] -> IO (Either IOError ())
138 -- ctags style with the Ex exresion being just the line number, Vim et al
139 collateAndWriteTags CTagsWithLineNumbers file tagInfos = do
140 let tags = unlines $ sortLe (<=) $ map showCTag tagInfos
141 tryIO (writeFile file tags)
142
143 -- ctags style with the Ex exresion being a regex searching the line, Vim et al
144 collateAndWriteTags CTagsWithRegExes file tagInfos = do -- ctags style, Vim et al
145 tagInfoGroups <- makeTagGroupsWithSrcInfo tagInfos
146 let tags = unlines $ sortLe (<=) $ map showCTag $concat tagInfoGroups
147 tryIO (writeFile file tags)
148
149 collateAndWriteTags ETags file tagInfos = do -- etags style, Emacs/XEmacs
150 tagInfoGroups <- makeTagGroupsWithSrcInfo $filter tagExported tagInfos
151 let tagGroups = map processGroup tagInfoGroups
152 tryIO (writeFile file $ concat tagGroups)
153
154 where
155 processGroup [] = ghcError (CmdLineError "empty tag file group??")
156 processGroup group@(tagInfo:_) =
157 let tags = unlines $ map showETag group in
158 "\x0c\n" ++ tagFile tagInfo ++ "," ++ show (length tags) ++ "\n" ++ tags
159
160
161 makeTagGroupsWithSrcInfo :: [TagInfo] -> IO [[TagInfo]]
162 makeTagGroupsWithSrcInfo tagInfos = do
163 let byFile op ti0 ti1 = tagFile ti0 `op` tagFile ti1
164 groups = groupBy (byFile (==)) $ sortLe (byFile (<=)) tagInfos
165 mapM addTagSrcInfo groups
166
167 where
168 addTagSrcInfo [] = ghcError (CmdLineError "empty tag file group??")
169 addTagSrcInfo group@(tagInfo:_) = do
170 file <- readFile $tagFile tagInfo
171 let byLine ti0 ti1 = tagLine ti0 <= tagLine ti1
172 sortedGroup = sortLe byLine group
173 return $ perFile sortedGroup 1 0 $ lines file
174
175 perFile allTags@(tag:tags) cnt pos allLs@(l:ls)
176 | tagLine tag > cnt =
177 perFile allTags (cnt+1) (pos+fromIntegral(length l)) ls
178 | tagLine tag == cnt =
179 tag{ tagSrcInfo = Just(l,pos) } : perFile tags cnt pos allLs
180 perFile _ _ _ _ = []
181
182
183 -- ctags format, for Vim et al
184 showCTag :: TagInfo -> String
185 showCTag ti =
186 tagName ti ++ "\t" ++ tagFile ti ++ "\t" ++ tagCmd ++ ";\"\t" ++
187 tagKind ti : ( if tagExported ti then "" else "\tfile:" )
188
189 where
190 tagCmd =
191 case tagSrcInfo ti of
192 Nothing -> show $tagLine ti
193 Just (srcLine,_) -> "/^"++ foldr escapeSlashes [] srcLine ++"$/"
194
195 where
196 escapeSlashes '/' r = '\\' : '/' : r
197 escapeSlashes '\\' r = '\\' : '\\' : r
198 escapeSlashes c r = c : r
199
200
201 -- etags format, for Emacs/XEmacs
202 showETag :: TagInfo -> String
203 showETag TagInfo{ tagName = tag, tagLine = lineNo, tagCol = colNo,
204 tagSrcInfo = Just (srcLine,charPos) }
205 = take (colNo - 1) srcLine ++ tag
206 ++ "\x7f" ++ tag
207 ++ "\x01" ++ show lineNo
208 ++ "," ++ show charPos
209 showETag _ = ghcError (CmdLineError "missing source file info in showETag")
210