Adding hpcError, that improves error messages with usage

[ghc-hetmet.git] / utils / hpc / HpcFlags.hs

diff --git a/utils/hpc/HpcFlags.hs b/utils/hpc/HpcFlags.hs
index cb561a6..38abe63 100644 (file)
--- a/utils/hpc/HpcFlags.hs
+++ b/utils/hpc/HpcFlags.hs
@@ -4,9 +4,10 @@ module HpcFlags where
 
 import System.Console.GetOpt
 import Data.Maybe ( fromMaybe )
-import qualified Data.Set as Set
+import qualified HpcSet as Set
 import Data.Char
 import Trace.Hpc.Tix
+import System.Exit
 
 data Flags = Flags 
   { outputFile         :: String
@@ -67,9 +68,9 @@ anArg flag detail argtype fn = Option [] [flag] (ReqArg fn argtype) detail
 infoArg :: String -> OptDescr (Flags -> Flags)
 infoArg info = Option [] [] (NoArg $ id) info
 
-excludeOpt    = anArg "exclude"    "exclude MODULE" "MODULE"  $ \ a f -> f { excludeMods = a `Set.insert` excludeMods f }
+excludeOpt    = anArg "exclude"    "exclude MODULE and/or PACKAGE" "[PACKAGE:][MODULE]"  $ \ a f -> f { excludeMods = a `Set.insert` excludeMods f }
 
-includeOpt    = anArg "include"    "include MODULE" "MODULE"  $ \ a f -> f { includeMods = a `Set.insert` includeMods f }
+includeOpt    = anArg "include"    "include MODULE and/or PACKAGE" "[PACKAGE:][MODULE]"  $ \ a f -> f { includeMods = a `Set.insert` includeMods f }
 hpcDirOpt     = anArg "hpcdir"     "path to .mix files (default .hpc)" "DIR"
                                                              $ \ a f -> f { hpcDirs = hpcDirs f ++ [a] }
 hsDirOpt      = anArg "hsdir"     "path to .hs files (default .)" "DIR"
@@ -108,6 +109,12 @@ command_usage plugin =
                                        then ""
                                        else usageInfo "\n\nOptions:\n" (options plugin)
 
+hpcError :: Plugin -> String -> IO a
+hpcError plugin msg = do
+   putStrLn $ "Error: " ++ msg
+   command_usage plugin
+   exitFailure
+ 
 -------------------------------------------------------------------------------
 
 data Plugin = Plugin { name           :: String
@@ -128,11 +135,22 @@ data Plugin = Plugin { name           :: String
 --  * otherwise, accepts just the included modules.
 
 allowModule :: Flags -> String -> Bool
-allowModule flags mod 
-      | mod `Set.member` excludeMods flags = False
-      | Set.null (includeMods flags)       = True
-      | mod `Set.member` includeMods flags = True
-      | otherwise                         = False
+allowModule flags full_mod 
+      | full_mod `Set.member` excludeMods flags = False
+      | pkg_name `Set.member` excludeMods flags = False
+      | mod_name `Set.member` excludeMods flags = False
+      | Set.null (includeMods flags)            = True
+      | full_mod `Set.member` includeMods flags = True
+      | pkg_name `Set.member` includeMods flags = True
+      | mod_name `Set.member` includeMods flags = True
+      | otherwise                              = False
+  where
+      -- pkg name always ends with '/', main 
+         (pkg_name,mod_name) = 
+                       case span (/= ':') full_mod of
+                    (p,':':m) -> (p ++ ":",m)
+                    (m,[])    -> (":",m)
+                    _         -> error "impossible case in allowModule" 
 
 filterTix :: Flags -> Tix -> Tix
 filterTix flags (Tix tixs) =