utils/hasktags/HaskTags.hs

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