+++ /dev/null
-
-module Main (main) where
-
-import Char
-import List
-import IO
-import System.Environment
-import System.Console.GetOpt
-import System.Exit
-
-
--- search for definitions of things
--- we do this by looking for the following patterns:
--- data XXX = ... giving a datatype location
--- newtype XXX = ... giving a newtype location
--- bla :: ... giving a function location
---
--- by doing it this way, we avoid picking up local definitions
--- (whether this is good or not is a matter for debate)
---
-
--- We generate both CTAGS and ETAGS format tags files
--- The former is for use in most sensible editors, while EMACS uses ETAGS
-
---
--- TODO add tag categories
--- alternatives: http://haskell.org/haskellwiki/Tags
-
-main :: IO ()
-main = do
- progName <- getProgName
- args <- getArgs
- let usageString = "Usage: " ++ progName ++ " [OPTION...] [files...]"
- let (modes, filenames, errs) = getOpt Permute options args
- if errs /= [] || elem Help modes || filenames == []
- then do
- putStr $ unlines errs
- putStr $ usageInfo usageString options
- exitWith (ExitFailure 1)
- else return ()
- let mode = getMode (Append `delete` modes)
- let openFileMode = if elem Append modes
- then AppendMode
- else WriteMode
- filedata <- mapM findthings filenames
- if mode == BothTags || mode == CTags
- then do
- ctagsfile <- openFile "tags" openFileMode
- writectagsfile ctagsfile filedata
- hClose ctagsfile
- else return ()
- if mode == BothTags || mode == ETags
- then do
- etagsfile <- openFile "TAGS" openFileMode
- writeetagsfile etagsfile filedata
- hClose etagsfile
- else return ()
-
--- | getMode takes a list of modes and extract the mode with the
--- highest precedence. These are as follows: Both, CTags, ETags
--- The default case is Both.
-getMode :: [Mode] -> Mode
-getMode [] = BothTags
-getMode [x] = x
-getMode (x:xs) = max x (getMode xs)
-
-
-data Mode = ETags | CTags | BothTags | Append | Help deriving (Ord, Eq, Show)
-
-options :: [OptDescr Mode]
-options = [ Option "c" ["ctags"]
- (NoArg CTags) "generate CTAGS file (ctags)"
- , Option "e" ["etags"]
- (NoArg ETags) "generate ETAGS file (etags)"
- , Option "b" ["both"]
- (NoArg BothTags) ("generate both CTAGS and ETAGS")
- , Option "a" ["append"]
- (NoArg Append) ("append to existing CTAGS and/or ETAGS file(s)")
- , Option "h" ["help"] (NoArg Help) "This help"
- ]
-
-type FileName = String
-
-type ThingName = String
-
--- The position of a token or definition
-data Pos = Pos
- FileName -- file name
- Int -- line number
- Int -- token number
- String -- string that makes up that line
- deriving (Show, Eq)
-
--- A definition we have found
-data FoundThing = FoundThing ThingName Pos
- deriving (Show, Eq)
-
--- Data we have obtained from a file
-data FileData = FileData FileName [FoundThing]
-
-data Token = Token String Pos
- deriving Show
-
-
--- stuff for dealing with ctags output format
-
-writectagsfile :: Handle -> [FileData] -> IO ()
-writectagsfile ctagsfile filedata = do
- let things = concat $ map getfoundthings filedata
- mapM_ (\x -> hPutStrLn ctagsfile $ dumpthing x) (sortThings things)
-
-sortThings :: [FoundThing] -> [FoundThing]
-sortThings = sortBy (\(FoundThing a _) (FoundThing b _) -> compare a b)
-
-getfoundthings :: FileData -> [FoundThing]
-getfoundthings (FileData _ things) = things
-
-dumpthing :: FoundThing -> String
-dumpthing (FoundThing name (Pos filename line _ _)) =
- name ++ "\t" ++ filename ++ "\t" ++ (show $ line + 1)
-
-
--- stuff for dealing with etags output format
-
-writeetagsfile :: Handle -> [FileData] -> IO ()
-writeetagsfile etagsfile filedata = do
- mapM_ (\x -> hPutStr etagsfile $ e_dumpfiledata x) filedata
-
-e_dumpfiledata :: FileData -> String
-e_dumpfiledata (FileData filename things) =
- "\x0c\n" ++ filename ++ "," ++ (show thingslength) ++ "\n" ++ thingsdump
- where thingsdump = concat $ map e_dumpthing things
- thingslength = length thingsdump
-
-e_dumpthing :: FoundThing -> String
-e_dumpthing (FoundThing _ (Pos _ line token fullline)) =
- (concat $ take (token + 1) $ spacedwords fullline)
- ++ "\x7f" ++ (show line) ++ "," ++ (show $ line+1) ++ "\n"
-
-
--- like "words", but keeping the whitespace, and so letting us build
--- accurate prefixes
-
-spacedwords :: String -> [String]
-spacedwords [] = []
-spacedwords xs = (blanks ++ wordchars):(spacedwords rest2)
- where (blanks,rest) = span Char.isSpace xs
- (wordchars,rest2) = span (\x -> not $ Char.isSpace x) rest
-
-
--- Find the definitions in a file
-
-findthings :: FileName -> IO FileData
-findthings filename = do
- text <- readFile filename
- evaluate text -- forces evaluation of text
- -- too many files were being opened otherwise since
- -- readFile is lazy
- let aslines = lines text
- let wordlines = map mywords aslines
- let noslcoms = map stripslcomments wordlines
- let tokens = concat $ zipWith3 (withline filename) noslcoms aslines [0 ..]
- -- there are some tokens with "" (don't know why yet) this filter fixes it
- let tokens' = filter (\(Token s _ ) -> (not . null) s ) tokens
- let nocoms = stripblockcomments tokens'
- -- using nub because getcons and findstuff are parsing parts of the file twice
- return $ FileData filename $ nub $ findstuff nocoms
- where evaluate [] = return ()
- evaluate (c:cs) = c `seq` evaluate cs
- -- my words is mainly copied from Data.List.
- -- difference abc::def is split into three words instead of one.
- -- We should really be lexing Haskell properly here rather
- -- than using hacks like this. In the future we expect hasktags
- -- to be replaced by something using the GHC API.
- mywords :: String -> [String]
- mywords (':':':':xs) = "::" : mywords xs
- mywords s = case dropWhile isSpace s of
- "" -> []
- s' -> w : mywords s''
- where (w, s'') = myBreak s'
- myBreak [] = ([],[])
- myBreak (':':':':xs) = ([], "::"++xs)
- myBreak (' ':xs) = ([],xs);
- myBreak (x:xs) = let (a,b) = myBreak xs
- in (x:a,b)
-
--- Create tokens from words, by recording their line number
--- and which token they are through that line
-
-withline :: FileName -> [String] -> String -> Int -> [Token]
-withline filename theWords fullline i =
- zipWith (\w t -> Token w (Pos filename i t fullline)) theWords $ [0 ..]
-
--- comments stripping
-
-stripslcomments :: [String] -> [String]
-stripslcomments ("--" : _) = []
-stripslcomments (x : xs) = x : stripslcomments xs
-stripslcomments [] = []
-
-stripblockcomments :: [Token] -> [Token]
-stripblockcomments ((Token "\\end{code}" _):xs) = afterlitend xs
-stripblockcomments ((Token "{-" _):xs) = afterblockcomend xs
-stripblockcomments (x:xs) = x:stripblockcomments xs
-stripblockcomments [] = []
-
-afterlitend :: [Token] -> [Token]
-afterlitend (Token "\\begin{code}" _ : xs) = xs
-afterlitend (_ : xs) = afterlitend xs
-afterlitend [] = []
-
-afterblockcomend :: [Token] -> [Token]
-afterblockcomend ((Token token _):xs)
- | contains "-}" token = xs
- | otherwise = afterblockcomend xs
-afterblockcomend [] = []
-
-
--- does one string contain another string
-
-contains :: Eq a => [a] -> [a] -> Bool
-contains sub full = any (isPrefixOf sub) $ tails full
-
--- actually pick up definitions
-
-findstuff :: [Token] -> [FoundThing]
-findstuff ((Token "module" _):(Token name pos):xs) =
- FoundThing name pos : (getcons xs) ++ (findstuff xs)
-findstuff ((Token "data" _):(Token name pos):xs) =
- FoundThing name pos : (getcons xs) ++ (findstuff xs)
-findstuff ((Token "newtype" _):(Token name pos):xs) =
- FoundThing name pos : findstuff xs
-findstuff ((Token "type" _):(Token name pos):xs) =
- FoundThing name pos : findstuff xs
-findstuff ((Token "class" _):xs) = findClassName xs
-findstuff ((Token name pos):(Token "::" _):xs) =
- FoundThing name pos : findstuff xs
-findstuff (_ : xs) = findstuff xs
-findstuff [] = []
-
-findClassName :: [Token] -> [FoundThing]
-findClassName [] = []
-findClassName [Token n p] = [FoundThing n p]
-findClassName xs = (\(Token n pos : xs') -> FoundThing n pos : findstuff xs') . drop2 . dropParens 0 $ xs
-
-dropParens :: Integer -> [Token] -> [Token]
-dropParens n (Token "(" _ : xs) = dropParens (n + 1) xs
-dropParens 0 (x : xs) = x : xs
-dropParens 1 (Token ")" _ : xs) = xs
-dropParens n (Token ")" _ : xs) = dropParens (n - 1) xs
-dropParens n (_ : xs) = dropParens n xs
-dropParens _ [] = [] -- Shouldn't happen on correct source
-
--- dropsEverything till token "=>" (if it is on the same line as the
--- first token. if not return tokens)
-drop2 :: [Token] -> [Token]
-drop2 tokens@(Token _ (Pos _ line_nr _ _ ) : _) =
- let (line, following) = span (\(Token _ (Pos _ l _ _)) -> l == line_nr) tokens
- (_, following_in_line) = span (\(Token n _) -> n /= "=>") line
- in case following_in_line of
- (Token "=>" _ : xs) -> xs ++ following
- _ -> tokens
-drop2 xs = xs
-
--- get the constructor definitions, knowing that a datatype has just started
-
-getcons :: [Token] -> [FoundThing]
-getcons (Token "=" _ : Token name pos : xs) =
- FoundThing name pos : getcons2 xs
-getcons (_ : xs) = getcons xs
-getcons [] = []
-
-getcons2 :: [Token] -> [FoundThing]
-getcons2 (Token "=" _ : _) = []
-getcons2 (Token "|" _ : Token name pos : xs) =
- FoundThing name pos : getcons2 xs
-getcons2 (_:xs) = getcons2 xs
-getcons2 [] = []
-
projects / ghc-hetmet.git / blobdiff