From: simonmar <unknown>
Date: Fri, 6 Aug 2004 11:33:06 +0000 (+0000)
Subject: [project @ 2004-08-06 11:33:06 by simonmar]
X-Git-Tag: Initial_conversion_from_CVS_complete~1766
X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=dc801dc275fb8f81d482535b4d6317e234bb10f8

[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
--- 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 [] = []