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