5 import System.Environment
6 import System.Console.GetOpt
10 -- search for definitions of things
11 -- we do this by looking for the following patterns:
12 -- data XXX = ... giving a datatype location
13 -- newtype XXX = ... giving a newtype location
14 -- bla :: ... giving a function location
16 -- by doing it this way, we avoid picking up local definitions
17 -- (whether this is good or not is a matter for debate)
20 -- We generate both CTAGS and ETAGS format tags files
21 -- The former is for use in most sensible editors, while EMACS uses ETAGS
26 progName <- getProgName
28 let usageString = "Usage: " ++ progName ++ " [OPTION...] [files...]"
29 let (modes, filenames, errs) = getOpt Permute options args
30 if errs /= [] || elem Help modes || filenames == []
33 putStr $ usageInfo usageString options
34 exitWith (ExitFailure 1)
36 let mode = getMode (Append `delete` modes)
37 let openFileMode = if elem Append modes
40 filedata <- mapM findthings filenames
41 if mode == BothTags || mode == CTags
43 ctagsfile <- openFile "tags" openFileMode
44 writectagsfile ctagsfile filedata
47 if mode == BothTags || mode == ETags
49 etagsfile <- openFile "TAGS" openFileMode
50 writeetagsfile etagsfile filedata
54 -- | getMode takes a list of modes and extract the mode with the
55 -- highest precedence. These are as follows: Both, CTags, ETags
56 -- The default case is Both.
57 getMode :: [Mode] -> Mode
60 getMode (x:xs) = max x (getMode xs)
63 data Mode = ETags | CTags | BothTags | Append | Help deriving (Ord, Eq, Show)
65 options :: [OptDescr Mode]
66 options = [ Option "c" ["ctags"]
67 (NoArg CTags) "generate CTAGS file (ctags)"
68 , Option "e" ["etags"]
69 (NoArg ETags) "generate ETAGS file (etags)"
71 (NoArg BothTags) ("generate both CTAGS and ETAGS")
72 , Option "a" ["append"]
73 (NoArg Append) ("append to existing CTAGS and/or ETAGS file(s)")
74 , Option "h" ["help"] (NoArg Help) "This help"
77 type FileName = String
79 type ThingName = String
81 -- The position of a token or definition
86 String -- string that makes up that line
89 -- A definition we have found
90 data FoundThing = FoundThing ThingName Pos
93 -- Data we have obtained from a file
94 data FileData = FileData FileName [FoundThing]
96 data Token = Token String Pos
100 -- stuff for dealing with ctags output format
102 writectagsfile :: Handle -> [FileData] -> IO ()
103 writectagsfile ctagsfile filedata = do
104 let things = concat $ map getfoundthings filedata
105 mapM_ (\x -> hPutStrLn ctagsfile $ dumpthing x) things
107 getfoundthings :: FileData -> [FoundThing]
108 getfoundthings (FileData filename things) = things
110 dumpthing :: FoundThing -> String
111 dumpthing (FoundThing name (Pos filename line _ _)) =
112 name ++ "\t" ++ filename ++ "\t" ++ (show $ line + 1)
115 -- stuff for dealing with etags output format
117 writeetagsfile :: Handle -> [FileData] -> IO ()
118 writeetagsfile etagsfile filedata = do
119 mapM_ (\x -> hPutStr etagsfile $ e_dumpfiledata x) filedata
121 e_dumpfiledata :: FileData -> String
122 e_dumpfiledata (FileData filename things) =
123 "\x0c\n" ++ filename ++ "," ++ (show thingslength) ++ "\n" ++ thingsdump
125 thingsdump = concat $ map e_dumpthing things
126 thingslength = length thingsdump
128 e_dumpthing :: FoundThing -> String
129 e_dumpthing (FoundThing name (Pos filename line token fullline)) =
130 (concat $ take (token + 1) $ spacedwords fullline)
131 ++ "\x7f" ++ (show line) ++ "," ++ (show $ line+1) ++ "\n"
134 -- like "words", but keeping the whitespace, and so letting us build
137 spacedwords :: String -> [String]
139 spacedwords xs = (blanks ++ wordchars):(spacedwords rest2)
141 (blanks,rest) = span Char.isSpace xs
142 (wordchars,rest2) = span (\x -> not $ Char.isSpace x) rest
145 -- Find the definitions in a file
147 findthings :: FileName -> IO FileData
148 findthings filename = do
149 text <- readFile filename
150 evaluate text -- forces evaluation of text
151 -- too many files were being opened otherwise since
153 let aslines = lines text
154 let wordlines = map words aslines
155 let noslcoms = map stripslcomments wordlines
156 let tokens = concat $ zipWith3 (withline filename) noslcoms
158 let nocoms = stripblockcomments tokens
159 return $ FileData filename $ findstuff nocoms
160 where evaluate [] = return ()
161 evaluate (c:cs) = c `seq` evaluate cs
163 -- Create tokens from words, by recording their line number
164 -- and which token they are through that line
166 withline :: FileName -> [String] -> String -> Int -> [Token]
167 withline filename words fullline i =
168 zipWith (\w t -> Token w (Pos filename i t fullline)) words $ [0 ..]
170 -- comments stripping
172 stripslcomments :: [String] -> [String]
173 stripslcomments ("--":xs) = []
174 stripslcomments (x:xs) = x : stripslcomments xs
175 stripslcomments [] = []
177 stripblockcomments :: [Token] -> [Token]
178 stripblockcomments ((Token "\\end{code}" _):xs) = afterlitend xs
179 stripblockcomments ((Token "{-" _):xs) = afterblockcomend xs
180 stripblockcomments (x:xs) = x:stripblockcomments xs
181 stripblockcomments [] = []
183 afterlitend2 :: [Token] -> [Token]
184 afterlitend2 (x:xs) = afterlitend xs
187 afterlitend :: [Token] -> [Token]
188 afterlitend ((Token "\\begin{code}" _):xs) = xs
189 afterlitend (x:xs) = afterlitend xs
192 afterblockcomend :: [Token] -> [Token]
193 afterblockcomend ((Token token _):xs) | contains "-}" token = xs
194 | otherwise = afterblockcomend xs
195 afterblockcomend [] = []
198 -- does one string contain another string
200 contains :: Eq a => [a] -> [a] -> Bool
201 contains sub full = any (isPrefixOf sub) $ tails full
204 ints i = i:(ints $ i+1)
207 -- actually pick up definitions
209 findstuff :: [Token] -> [FoundThing]
210 findstuff ((Token "data" _):(Token name pos):xs) =
211 FoundThing name pos : (getcons xs) ++ (findstuff xs)
212 findstuff ((Token "newtype" _):(Token name pos):xs) =
213 FoundThing name pos : findstuff xs
214 findstuff ((Token "type" _):(Token name pos):xs) =
215 FoundThing name pos : findstuff xs
216 findstuff ((Token name pos):(Token "::" _):xs) =
217 FoundThing name pos : findstuff xs
218 findstuff (x:xs) = findstuff xs
222 -- get the constructor definitions, knowing that a datatype has just started
224 getcons :: [Token] -> [FoundThing]
225 getcons ((Token "=" _):(Token name pos):xs) =
226 FoundThing name pos : getcons2 xs
227 getcons (x:xs) = getcons xs
231 getcons2 ((Token "=" _):xs) = []
232 getcons2 ((Token "|" _):(Token name pos):xs) =
233 FoundThing name pos : getcons2 xs
234 getcons2 (x:xs) = getcons2 xs