6 import System.Environment
7 import System.Console.GetOpt
11 -- search for definitions of things
12 -- we do this by looking for the following patterns:
13 -- data XXX = ... giving a datatype location
14 -- newtype XXX = ... giving a newtype location
15 -- bla :: ... giving a function location
17 -- by doing it this way, we avoid picking up local definitions
18 -- (whether this is good or not is a matter for debate)
21 -- We generate both CTAGS and ETAGS format tags files
22 -- The former is for use in most sensible editors, while EMACS uses ETAGS
27 progName <- getProgName
29 let usageString = "Usage: " ++ progName ++ " [OPTION...] [files...]"
30 let (modes, filenames, errs) = getOpt Permute options args
31 if errs /= [] || elem Help modes || filenames == []
34 putStr $ usageInfo usageString options
35 exitWith (ExitFailure 1)
37 let mode = getMode modes
38 filedata <- mapM findthings filenames
39 if mode == BothTags || mode == CTags
41 ctagsfile <- openFile "tags" WriteMode
42 writectagsfile ctagsfile filedata
45 if mode == BothTags || mode == ETags
47 etagsfile <- openFile "TAGS" WriteMode
48 writeetagsfile etagsfile filedata
52 -- | getMode takes a list of modes and extract the mode with the
53 -- highest precedence. These are as follows: Both, CTags, ETags
54 -- The default case is Both.
55 getMode :: [Mode] -> Mode
58 getMode (x:xs) = max x (getMode xs)
61 data Mode = ETags | CTags | BothTags | Help deriving (Ord, Eq, Show)
63 options :: [OptDescr Mode]
64 options = [ Option "c" ["ctags"]
65 (NoArg CTags) "generate CTAGS file (ctags)"
66 , Option "e" ["etags"]
67 (NoArg ETags) "generate ETAGS file (etags)"
69 (NoArg BothTags) ("generate both CTAGS and ETAGS")
70 , Option "h" ["help"] (NoArg Help) "This help"
73 type FileName = String
75 type ThingName = String
77 -- The position of a token or definition
82 String -- string that makes up that line
85 -- A definition we have found
86 data FoundThing = FoundThing ThingName Pos
89 -- Data we have obtained from a file
90 data FileData = FileData FileName [FoundThing]
92 data Token = Token String Pos
96 -- stuff for dealing with ctags output format
98 writectagsfile :: Handle -> [FileData] -> IO ()
99 writectagsfile ctagsfile filedata = do
100 let things = concat $ map getfoundthings filedata
101 mapM_ (\x -> hPutStrLn ctagsfile $ dumpthing x) things
103 getfoundthings :: FileData -> [FoundThing]
104 getfoundthings (FileData filename things) = things
106 dumpthing :: FoundThing -> String
107 dumpthing (FoundThing name (Pos filename line _ _)) =
108 name ++ "\t" ++ filename ++ "\t" ++ (show $ line + 1)
111 -- stuff for dealing with etags output format
113 writeetagsfile :: Handle -> [FileData] -> IO ()
114 writeetagsfile etagsfile filedata = do
115 mapM_ (\x -> hPutStr etagsfile $ e_dumpfiledata x) filedata
117 e_dumpfiledata :: FileData -> String
118 e_dumpfiledata (FileData filename things) =
119 "\x0c\n" ++ filename ++ "," ++ (show thingslength) ++ "\n" ++ thingsdump
121 thingsdump = concat $ map e_dumpthing things
122 thingslength = length thingsdump
124 e_dumpthing :: FoundThing -> String
125 e_dumpthing (FoundThing name (Pos filename line token fullline)) =
126 (concat $ take (token + 1) $ spacedwords fullline)
127 ++ "\x7f" ++ (show line) ++ "," ++ (show $ line+1) ++ "\n"
130 -- like "words", but keeping the whitespace, and so letting us build
133 spacedwords :: String -> [String]
135 spacedwords xs = (blanks ++ wordchars):(spacedwords rest2)
137 (blanks,rest) = span Char.isSpace xs
138 (wordchars,rest2) = span (\x -> not $ Char.isSpace x) rest
141 -- Find the definitions in a file
143 findthings :: FileName -> IO FileData
144 findthings filename = do
145 text <- readFile filename
146 evaluate text -- forces evaluation of text
147 -- too many files were being opened otherwise since
149 let aslines = lines text
150 let wordlines = map words aslines
151 let noslcoms = map stripslcomments wordlines
152 let tokens = concat $ zipWith3 (withline filename) noslcoms
154 let nocoms = stripblockcomments tokens
155 return $ FileData filename $ findstuff nocoms
156 where evaluate [] = return ()
157 evaluate (c:cs) = c `seq` evaluate cs
159 -- Create tokens from words, by recording their line number
160 -- and which token they are through that line
162 withline :: FileName -> [String] -> String -> Int -> [Token]
163 withline filename words fullline i =
164 zipWith (\w t -> Token w (Pos filename i t fullline)) words $ [0 ..]
166 -- comments stripping
168 stripslcomments :: [String] -> [String]
169 stripslcomments ("--":xs) = []
170 stripslcomments (x:xs) = x : stripslcomments xs
171 stripslcomments [] = []
173 stripblockcomments :: [Token] -> [Token]
174 stripblockcomments ((Token "\\end{code}" _):xs) = afterlitend xs
175 stripblockcomments ((Token "{-" _):xs) = afterblockcomend xs
176 stripblockcomments (x:xs) = x:stripblockcomments xs
177 stripblockcomments [] = []
179 afterlitend2 :: [Token] -> [Token]
180 afterlitend2 (x:xs) = afterlitend xs
183 afterlitend :: [Token] -> [Token]
184 afterlitend ((Token "\\begin{code}" _):xs) = xs
185 afterlitend (x:xs) = afterlitend xs
188 afterblockcomend :: [Token] -> [Token]
189 afterblockcomend ((Token token _):xs) | contains "-}" token = xs
190 | otherwise = afterblockcomend xs
191 afterblockcomend [] = []
194 -- does one string contain another string
196 contains :: Eq a => [a] -> [a] -> Bool
197 contains sub full = any (isPrefixOf sub) $ tails full
200 ints i = i:(ints $ i+1)
203 -- actually pick up definitions
205 findstuff :: [Token] -> [FoundThing]
206 findstuff ((Token "data" _):(Token name pos):xs) =
207 FoundThing name pos : (getcons xs) ++ (findstuff xs)
208 findstuff ((Token "newtype" _):(Token name pos):xs) =
209 FoundThing name pos : findstuff xs
210 findstuff ((Token "type" _):(Token name pos):xs) =
211 FoundThing name pos : findstuff xs
212 findstuff ((Token name pos):(Token "::" _):xs) =
213 FoundThing name pos : findstuff xs
214 findstuff (x:xs) = findstuff xs
218 -- get the constructor definitions, knowing that a datatype has just started
220 getcons :: [Token] -> [FoundThing]
221 getcons ((Token "=" _):(Token name pos):xs) =
222 FoundThing name pos : getcons2 xs
223 getcons (x:xs) = getcons xs
227 getcons2 ((Token "=" _):xs) = []
228 getcons2 ((Token "|" _):(Token name pos):xs) =
229 FoundThing name pos : getcons2 xs
230 getcons2 (x:xs) = getcons2 xs