utils/hasktags/HaskTags.hs

   1 module Main where
   2 import Char
   3 import List
   4 import IO
   5 import System.Environment
   6 import System.Console.GetOpt
   7 import System.Exit
   8
   9
  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
  15 --
  16 -- by doing it this way, we avoid picking up local definitions
  17 --              (whether this is good or not is a matter for debate)
  18 --
  19
  20 -- We generate both CTAGS and ETAGS format tags files
  21 -- The former is for use in most sensible editors, while EMACS uses ETAGS
  22
  23
  24 main :: IO ()
  25 main = do
  26         progName <- getProgName
  27         args <- getArgs
  28         let usageString = "Usage: " ++ progName ++ " [OPTION...] [files...]"
  29         let (modes, filenames, errs) = getOpt Permute options args
  30         if errs /= [] || elem Help modes || filenames == []
  31          then do
  32            putStr $ unlines errs
  33            putStr $ usageInfo usageString options
  34            exitWith (ExitFailure 1)
  35          else return ()
  36         let mode = getMode (Append `delete` modes)
  37         let openFileMode = if elem Append modes
  38                            then AppendMode
  39                            else WriteMode
  40         filedata <- mapM findthings filenames
  41         if mode == BothTags || mode == CTags
  42          then do
  43            ctagsfile <- openFile "tags" openFileMode
  44            writectagsfile ctagsfile filedata
  45            hClose ctagsfile
  46          else return ()
  47         if mode == BothTags || mode == ETags
  48          then do
  49            etagsfile <- openFile "TAGS" openFileMode
  50            writeetagsfile etagsfile filedata
  51            hClose etagsfile
  52          else return ()
  53
  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
  58 getMode [] = BothTags
  59 getMode [x] = x
  60 getMode (x:xs) = max x (getMode xs)
  61
  62
  63 data Mode = ETags | CTags | BothTags | Append | Help deriving (Ord, Eq, Show)
  64
  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)"
  70           , Option "b" ["both"]
  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"
  75           ]
  76
  77 type FileName = String
  78
  79 type ThingName = String
  80
  81 -- The position of a token or definition
  82 data Pos = Pos
  83                 FileName        -- file name
  84                 Int                     -- line number
  85                 Int             -- token number
  86                 String          -- string that makes up that line
  87         deriving Show
  88
  89 -- A definition we have found
  90 data FoundThing = FoundThing ThingName Pos
  91         deriving Show
  92
  93 -- Data we have obtained from a file
  94 data FileData = FileData FileName [FoundThing]
  95
  96 data Token = Token String Pos
  97         deriving Show
  98
  99
 100 -- stuff for dealing with ctags output format
 101
 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
 106
 107 getfoundthings :: FileData -> [FoundThing]
 108 getfoundthings (FileData filename things) = things
 109
 110 dumpthing :: FoundThing -> String
 111 dumpthing (FoundThing name (Pos filename line _ _)) =
 112         name ++ "\t" ++ filename ++ "\t" ++ (show $ line + 1)
 113
 114
 115 -- stuff for dealing with etags output format
 116
 117 writeetagsfile :: Handle -> [FileData] -> IO ()
 118 writeetagsfile etagsfile filedata = do
 119         mapM_ (\x -> hPutStr etagsfile $ e_dumpfiledata x) filedata
 120
 121 e_dumpfiledata :: FileData -> String
 122 e_dumpfiledata (FileData filename things) =
 123         "\x0c\n" ++ filename ++ "," ++ (show thingslength) ++ "\n" ++ thingsdump
 124         where
 125                 thingsdump = concat $ map e_dumpthing things
 126                 thingslength = length thingsdump
 127
 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"
 132
 133
 134 -- like "words", but keeping the whitespace, and so letting us build
 135 -- accurate prefixes
 136
 137 spacedwords :: String -> [String]
 138 spacedwords [] = []
 139 spacedwords xs = (blanks ++ wordchars):(spacedwords rest2)
 140         where
 141                 (blanks,rest) = span Char.isSpace xs
 142                 (wordchars,rest2) = span (\x -> not $ Char.isSpace x) rest
 143
 144
 145 -- Find the definitions in a file
 146
 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
 152                       -- readFile is lazy
 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
 157                                         aslines [0 ..]
 158         let nocoms = stripblockcomments tokens
 159         return $ FileData filename $ findstuff nocoms
 160   where evaluate [] = return ()
 161         evaluate (c:cs) = c `seq` evaluate cs
 162
 163 -- Create tokens from words, by recording their line number
 164 -- and which token they are through that line
 165
 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 ..]
 169
 170 -- comments stripping
 171
 172 stripslcomments :: [String] -> [String]
 173 stripslcomments ("--":xs) = []
 174 stripslcomments (x:xs) = x : stripslcomments xs
 175 stripslcomments [] = []
 176
 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 [] = []
 182
 183 afterlitend2 :: [Token] -> [Token]
 184 afterlitend2 (x:xs) = afterlitend xs
 185 afterlitend2 [] = []
 186
 187 afterlitend :: [Token] -> [Token]
 188 afterlitend ((Token "\\begin{code}" _):xs) = xs
 189 afterlitend (x:xs) = afterlitend xs
 190 afterlitend [] = []
 191
 192 afterblockcomend :: [Token] -> [Token]
 193 afterblockcomend ((Token token _):xs) | contains "-}" token = xs
 194                                                 | otherwise = afterblockcomend xs
 195 afterblockcomend [] = []
 196
 197
 198 -- does one string contain another string
 199
 200 contains :: Eq a => [a] -> [a] -> Bool
 201 contains sub full = any (isPrefixOf sub) $ tails full
 202
 203 ints :: Int -> [Int]
 204 ints i = i:(ints $ i+1)
 205
 206
 207 -- actually pick up definitions
 208
 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
 219 findstuff [] = []
 220
 221
 222 -- get the constructor definitions, knowing that a datatype has just started
 223
 224 getcons :: [Token] -> [FoundThing]
 225 getcons ((Token "=" _):(Token name pos):xs) =
 226         FoundThing name pos : getcons2 xs
 227 getcons (x:xs) = getcons xs
 228 getcons [] = []
 229
 230
 231 getcons2 ((Token "=" _):xs) = []
 232 getcons2 ((Token "|" _):(Token name pos):xs) =
 233         FoundThing name pos : getcons2 xs
 234 getcons2 (x:xs) = getcons2 xs
 235 getcons2 [] = []
 236