[project @ 2004-08-06 11:33:06 by simonmar]

Update from Robert Ennals: allow either the ctags or etags file to be
generated, so as to be more friendly to case-insensitive filesystems.

diff --git a/ghc/utils/hasktags/HaskTags.hs b/ghc/utils/hasktags/HaskTags.hs
index 9df6637..f184033 100644 (file)
--- a/ghc/utils/hasktags/HaskTags.hs
+++ b/ghc/utils/hasktags/HaskTags.hs
@@ -3,6 +3,9 @@ import System
 import Char
 import List
 import IO
+import System.Environment
+import System.Console.GetOpt
+import System.Exit
 
 
 -- search for definitions of things 
@@ -21,15 +24,52 @@ import IO
 
 main :: IO ()
 main = do
-       filenames <- getArgs
+        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 modes
        filedata <- mapM findthings filenames
-       ctagsfile <- openFile "tags" WriteMode
-       writectagsfile ctagsfile filedata
-       hClose ctagsfile
-       etagsfile <- openFile "TAGS" WriteMode
-       writeetagsfile etagsfile filedata
-       hClose etagsfile
-       
+        if mode == BothTags || mode == CTags
+         then do 
+           ctagsfile <- openFile "tags" WriteMode
+          writectagsfile ctagsfile filedata
+           hClose ctagsfile
+         else return ()
+       if mode == BothTags || mode == ETags 
+         then do
+           etagsfile <- openFile "TAGS" WriteMode
+          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 | 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 "h" ["help"] (NoArg Help) "This help"
+         ]
+
 type FileName = String
 
 type ThingName = String
@@ -48,7 +88,6 @@ data FoundThing = FoundThing ThingName Pos
 
 -- Data we have obtained from a file
 data FileData = FileData FileName [FoundThing]
-       deriving Show
 
 data Token = Token String Pos
        deriving Show
@@ -104,6 +143,9 @@ spacedwords xs = (blanks ++ wordchars):(spacedwords rest2)
 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 words aslines
        let noslcoms = map stripslcomments wordlines
@@ -111,6 +153,8 @@ findthings filename = do
                                        aslines [0 ..]
        let nocoms = stripblockcomments tokens
        return $ FileData filename $ findstuff nocoms
+  where evaluate [] = return ()
+        evaluate (c:cs) = c `seq` evaluate cs
        
 -- Create tokens from words, by recording their line number
 -- and which token they are through that line
@@ -122,15 +166,13 @@ withline filename words fullline i =
 -- comments stripping
 
 stripslcomments :: [String] -> [String]
-stripslcomments (x:xs) | isPrefixOf "--" x = []
-                                          | otherwise = x : stripslcomments xs
+stripslcomments ("--":xs) = []
+stripslcomments (x:xs) = x : stripslcomments xs 
 stripslcomments [] = []
 
 stripblockcomments :: [Token] -> [Token]
-stripblockcomments ((Token "\\end{code}" _):xs) = 
-       stripblockcomments $ afterlitend xs
-stripblockcomments ((Token "{-" _):xs) = 
-       stripblockcomments $ afterblockcomend xs
+stripblockcomments ((Token "\\end{code}" _):xs) = afterlitend xs
+stripblockcomments ((Token "{-" _):xs) = afterblockcomend xs
 stripblockcomments (x:xs) = x:stripblockcomments xs
 stripblockcomments [] = []