Improve error messages in readMix (#10529)
authorThomas Miedema <thomasmiedema@gmail.com>
Tue, 16 Jun 2015 12:48:19 +0000 (14:48 +0200)
committerThomas Miedema <thomasmiedema@gmail.com>
Tue, 16 Jun 2015 18:48:18 +0000 (20:48 +0200)
Trace/Hpc/Mix.hs
changelog.md
tests/simple/tixs/.hpc/NoParse.mix [new file with mode: 0644]
tests/simple/tixs/T10529a.stderr [new file with mode: 0644]
tests/simple/tixs/T10529b.stderr [new file with mode: 0644]
tests/simple/tixs/T10529c.stderr [new file with mode: 0644]
tests/simple/tixs/hpc_sample_incompatible_hash.tix [new file with mode: 0644]
tests/simple/tixs/hpc_sample_no_parse.tix [new file with mode: 0644]
tests/simple/tixs/hpc_sample_non_existing_module.tix [new file with mode: 0644]
tests/simple/tixs/test.T

index f4025d9..0a5f054 100644 (file)
@@ -22,13 +22,21 @@ module Trace.Hpc.Mix
         )
   where
 
-import Data.Maybe (catMaybes)
+import Data.Maybe (catMaybes, fromMaybe)
 import Data.Time (UTCTime)
 import Data.Tree
-import Data.Char
 
 import System.FilePath
 
+#if MIN_VERSION_base(4,6,0)
+import Text.Read (readMaybe)
+#else
+readMaybe :: Read a => String -> Maybe a
+readMaybe s = case reads s of
+  [(x, s')] | all isSpace s' -> Just x
+  _                          -> Nothing
+#endif
+
 -- a module index records the attributes of each tick-box that has
 -- been introduced in that module, accessed by tick-number position
 -- in the list
@@ -89,18 +97,15 @@ readMix :: [String]                 -- ^ Dir Names
         -> Either String TixModule  -- ^ module wanted
         -> IO Mix
 readMix dirNames mod' = do
-   let modName = case mod' of
-                    Left str -> str
-                    Right tix -> tixModuleName tix
-   res <- sequence [ (do contents <- readFile (mixName dirName modName)
-                         case reads contents of
-                           [(r@(Mix _ _ h _ _),cs)]
-                                | all isSpace cs
-                               && (case mod' of
-                                     Left  _   -> True
-                                     Right tix -> h == tixModuleHash tix
-                                  ) -> return $ Just r
-                           _ -> return $ Nothing) `catchIO` (\ _ -> return $ Nothing)
+   let modName = either id tixModuleName mod'
+   res <- sequence [ (do let mixPath    = mixName dirName modName
+                             parseError = error ("can not parse " ++ mixPath)
+                             parse      = fromMaybe parseError . readMaybe
+                         mix <- parse `fmap` readFile mixPath
+                         case mod' of
+                            Left  _   -> return $ Just mix -- Bypass hash check
+                            Right tix -> return $ checkHash tix mix mixPath)
+                     `catchIO` (\ _ -> return $ Nothing)
                    | dirName <- dirNames
                    ]
    case catMaybes res of
@@ -115,6 +120,17 @@ readMix dirNames mod' = do
 mixName :: FilePath -> String -> String
 mixName dirName name = dirName </> name <.> "mix"
 
+-- | Check that hash in .tix and .mix file match.
+checkHash :: TixModule -> Mix -> FilePath -> Maybe Mix
+checkHash tix mix@(Mix _ _ mixHash _ _) mixPath
+  | modHash == mixHash = Just mix
+  | otherwise = error $
+      "hash in tix file for module " ++ modName ++ " (" ++ show modHash ++ ")\n"
+      ++ "does not match hash in " ++ mixPath ++ " (" ++ show mixHash ++ ")"
+  where
+    modName = tixModuleName tix
+    modHash = tixModuleHash tix
+
 ------------------------------------------------------------------------------
 
 type MixEntryDom a = Tree (HpcPos,a)
index dfb36fd..6312fa8 100644 (file)
@@ -1,5 +1,9 @@
 # Changelog for [`hpc` package](http://hackage.haskell.org/package/hpc)
 
+## 0.6.0.3  *Unreleased*
+
+  * Improved error messages (#10529)
+
 ## 0.6.0.2  *Mar 2015*
 
   * Bundled with GHC 7.10.1
diff --git a/tests/simple/tixs/.hpc/NoParse.mix b/tests/simple/tixs/.hpc/NoParse.mix
new file mode 100644 (file)
index 0000000..28f54ff
--- /dev/null
@@ -0,0 +1 @@
+NoParse
diff --git a/tests/simple/tixs/T10529a.stderr b/tests/simple/tixs/T10529a.stderr
new file mode 100644 (file)
index 0000000..945c633
--- /dev/null
@@ -0,0 +1 @@
+hpc: can not find NonExistingModule in ["./.hpc"]
diff --git a/tests/simple/tixs/T10529b.stderr b/tests/simple/tixs/T10529b.stderr
new file mode 100644 (file)
index 0000000..4035997
--- /dev/null
@@ -0,0 +1,2 @@
+hpc: hash in tix file for module Main (1234567890)
+does not match hash in ./.hpc/Main.mix (2454134535)
diff --git a/tests/simple/tixs/T10529c.stderr b/tests/simple/tixs/T10529c.stderr
new file mode 100644 (file)
index 0000000..5a0db11
--- /dev/null
@@ -0,0 +1 @@
+hpc: can not parse ./.hpc/NoParse.mix
diff --git a/tests/simple/tixs/hpc_sample_incompatible_hash.tix b/tests/simple/tixs/hpc_sample_incompatible_hash.tix
new file mode 100644 (file)
index 0000000..f9c335e
--- /dev/null
@@ -0,0 +1 @@
+Tix [ TixModule "Main" 1234567890 5 [1,0,1,1,1]]
diff --git a/tests/simple/tixs/hpc_sample_no_parse.tix b/tests/simple/tixs/hpc_sample_no_parse.tix
new file mode 100644 (file)
index 0000000..b2b2110
--- /dev/null
@@ -0,0 +1 @@
+Tix [ TixModule "NoParse" 2454134535 5 [1,0,1,1,1]]
diff --git a/tests/simple/tixs/hpc_sample_non_existing_module.tix b/tests/simple/tixs/hpc_sample_non_existing_module.tix
new file mode 100644 (file)
index 0000000..1fa93c5
--- /dev/null
@@ -0,0 +1 @@
+Tix [ TixModule "NonExistingModule" 2454134535 5 [1,0,1,1,1]]
index 8e98d0e..da88911 100644 (file)
@@ -71,3 +71,11 @@ test('hpc_bad_001', exit_code(1), run_command, ["{hpc} bad arguments"])
 test('T9619', ignore_output, run_command,
      # Having the same mix file in two different hpcdirs should work.
      ["{hpc} report hpc_sample.tix --hpcdir=.hpc --hpcdir=.hpc.copy"])
+
+# Show different error messages for different types of failures.
+test('T10529a', exit_code(1), run_command,
+     ["{hpc} report hpc_sample_non_existing_module.tix"])
+test('T10529b', exit_code(1), run_command,
+     ["{hpc} report hpc_sample_incompatible_hash.tix"])
+test('T10529c', exit_code(1), run_command,
+     ["{hpc} report hpc_sample_no_parse.tix"])