ghc/utils/hasktags/HaskTags.hs

   1 module Main where
   2 import System
   3 import Char
   4 import List
   5 import IO
   6
   7
   8 -- search for definitions of things
   9 -- we do this by looking for the following patterns:
  10 -- data XXX = ...      giving a datatype location
  11 -- newtype XXX = ...   giving a newtype location
  12 -- bla :: ...          giving a function location
  13 --
  14 -- by doing it this way, we avoid picking up local definitions
  15 --              (whether this is good or not is a matter for debate)
  16 --
  17
  18 -- We generate both CTAGS and ETAGS format tags files
  19 -- The former is for use in most sensible editors, while EMACS uses ETAGS
  20
  21
  22 main :: IO ()
  23 main = do
  24         filenames <- getArgs
  25         filedata <- mapM findthings filenames
  26         ctagsfile <- openFile "tags" WriteMode
  27         writectagsfile ctagsfile filedata
  28         hClose ctagsfile
  29         etagsfile <- openFile "TAGS" WriteMode
  30         writeetagsfile etagsfile filedata
  31         hClose etagsfile
  32
  33 type FileName = String
  34
  35 type ThingName = String
  36
  37 -- The position of a token or definition
  38 data Pos = Pos
  39                 FileName        -- file name
  40                 Int                     -- line number
  41                 Int             -- token number
  42                 String          -- string that makes up that line
  43         deriving Show
  44
  45 -- A definition we have found
  46 data FoundThing = FoundThing ThingName Pos
  47         deriving Show
  48
  49 -- Data we have obtained from a file
  50 data FileData = FileData FileName [FoundThing]
  51         deriving Show
  52
  53 data Token = Token String Pos
  54         deriving Show
  55
  56
  57 -- stuff for dealing with ctags output format
  58
  59 writectagsfile :: Handle -> [FileData] -> IO ()
  60 writectagsfile ctagsfile filedata = do
  61         let things = concat $ map getfoundthings filedata
  62         mapM_ (\x -> hPutStrLn ctagsfile $ dumpthing x) things
  63
  64 getfoundthings :: FileData -> [FoundThing]
  65 getfoundthings (FileData filename things) = things
  66
  67 dumpthing :: FoundThing -> String
  68 dumpthing (FoundThing name (Pos filename line _ _)) =
  69         name ++ "\t" ++ filename ++ "\t" ++ (show $ line + 1)
  70
  71
  72 -- stuff for dealing with etags output format
  73
  74 writeetagsfile :: Handle -> [FileData] -> IO ()
  75 writeetagsfile etagsfile filedata = do
  76         mapM_ (\x -> hPutStr etagsfile $ e_dumpfiledata x) filedata
  77
  78 e_dumpfiledata :: FileData -> String
  79 e_dumpfiledata (FileData filename things) =
  80         "\x0c\n" ++ filename ++ "," ++ (show thingslength) ++ "\n" ++ thingsdump
  81         where
  82                 thingsdump = concat $ map e_dumpthing things
  83                 thingslength = length thingsdump
  84
  85 e_dumpthing :: FoundThing -> String
  86 e_dumpthing (FoundThing name (Pos filename line token fullline)) =
  87         (concat $ take (token + 1) $ spacedwords fullline)
  88         ++ "\x7f" ++ (show line) ++ "," ++ (show $ line+1) ++ "\n"
  89
  90
  91 -- like "words", but keeping the whitespace, and so letting us build
  92 -- accurate prefixes
  93
  94 spacedwords :: String -> [String]
  95 spacedwords [] = []
  96 spacedwords xs = (blanks ++ wordchars):(spacedwords rest2)
  97         where
  98                 (blanks,rest) = span Char.isSpace xs
  99                 (wordchars,rest2) = span (\x -> not $ Char.isSpace x) rest
 100
 101
 102 -- Find the definitions in a file
 103
 104 findthings :: FileName -> IO FileData
 105 findthings filename = do
 106         text <- readFile filename
 107         let aslines = lines text
 108         let wordlines = map words aslines
 109         let noslcoms = map stripslcomments wordlines
 110         let tokens = concat $ zipWith3 (withline filename) noslcoms
 111                                         aslines [0 ..]
 112         let nocoms = stripblockcomments tokens
 113         return $ FileData filename $ findstuff nocoms
 114
 115 -- Create tokens from words, by recording their line number
 116 -- and which token they are through that line
 117
 118 withline :: FileName -> [String] -> String -> Int -> [Token]
 119 withline filename words fullline i =
 120         zipWith (\w t -> Token w (Pos filename i t fullline)) words $ [0 ..]
 121
 122 -- comments stripping
 123
 124 stripslcomments :: [String] -> [String]
 125 stripslcomments (x:xs) | isPrefixOf "--" x = []
 126                                            | otherwise = x : stripslcomments xs
 127 stripslcomments [] = []
 128
 129 stripblockcomments :: [Token] -> [Token]
 130 stripblockcomments ((Token "\\end{code}" _):xs) =
 131         stripblockcomments $ afterlitend xs
 132 stripblockcomments ((Token "{-" _):xs) =
 133         stripblockcomments $ afterblockcomend xs
 134 stripblockcomments (x:xs) = x:stripblockcomments xs
 135 stripblockcomments [] = []
 136
 137 afterlitend2 :: [Token] -> [Token]
 138 afterlitend2 (x:xs) = afterlitend xs
 139 afterlitend2 [] = []
 140
 141 afterlitend :: [Token] -> [Token]
 142 afterlitend ((Token "\\begin{code}" _):xs) = xs
 143 afterlitend (x:xs) = afterlitend xs
 144 afterlitend [] = []
 145
 146 afterblockcomend :: [Token] -> [Token]
 147 afterblockcomend ((Token token _):xs) | contains "-}" token = xs
 148                                                 | otherwise = afterblockcomend xs
 149 afterblockcomend [] = []
 150
 151
 152 -- does one string contain another string
 153
 154 contains :: Eq a => [a] -> [a] -> Bool
 155 contains sub full = any (isPrefixOf sub) $ tails full
 156
 157 ints :: Int -> [Int]
 158 ints i = i:(ints $ i+1)
 159
 160
 161 -- actually pick up definitions
 162
 163 findstuff :: [Token] -> [FoundThing]
 164 findstuff ((Token "data" _):(Token name pos):xs) =
 165         FoundThing name pos : (getcons xs) ++ (findstuff xs)
 166 findstuff ((Token "newtype" _):(Token name pos):xs) =
 167         FoundThing name pos : findstuff xs
 168 findstuff ((Token "type" _):(Token name pos):xs) =
 169         FoundThing name pos : findstuff xs
 170 findstuff ((Token name pos):(Token "::" _):xs) =
 171         FoundThing name pos : findstuff xs
 172 findstuff (x:xs) = findstuff xs
 173 findstuff [] = []
 174
 175
 176 -- get the constructor definitions, knowing that a datatype has just started
 177
 178 getcons :: [Token] -> [FoundThing]
 179 getcons ((Token "=" _):(Token name pos):xs) =
 180         FoundThing name pos : getcons2 xs
 181 getcons (x:xs) = getcons xs
 182 getcons [] = []
 183
 184
 185 getcons2 ((Token "=" _):xs) = []
 186 getcons2 ((Token "|" _):(Token name pos):xs) =
 187         FoundThing name pos : getcons2 xs
 188 getcons2 (x:xs) = getcons2 xs
 189 getcons2 [] = []
 190