[commit: packages/hpc] wip/T10529: Improve error messages in readMix (#10529) (b6efe54)

git at git.haskell.org git at git.haskell.org
Tue Jun 16 18:13:13 UTC 2015


Repository : ssh://git@git.haskell.org/hpc

On branch  : wip/T10529
Link       : http://git.haskell.org/packages/hpc.git/commitdiff/b6efe544dfee9e1e5822979a9df4d05f4c319cf8

>---------------------------------------------------------------

commit b6efe544dfee9e1e5822979a9df4d05f4c319cf8
Author: Thomas Miedema <thomasmiedema at gmail.com>
Date:   Tue Jun 16 14:48:19 2015 +0200

    Improve error messages in readMix (#10529)


>---------------------------------------------------------------

b6efe544dfee9e1e5822979a9df4d05f4c319cf8
 Trace/Hpc/Mix.hs                                   | 48 ++++++++++++++--------
 changelog.md                                       |  4 ++
 tests/simple/tixs/.hpc/NoParse.mix                 |  1 +
 tests/simple/tixs/T10529a.stderr                   |  1 +
 tests/simple/tixs/T10529b.stderr                   |  2 +
 tests/simple/tixs/T10529c.stderr                   |  1 +
 tests/simple/tixs/hpc_sample_incompatible_hash.tix |  1 +
 tests/simple/tixs/hpc_sample_no_parse.tix          |  1 +
 .../simple/tixs/hpc_sample_non_existing_module.tix |  1 +
 tests/simple/tixs/test.T                           |  8 ++++
 10 files changed, 52 insertions(+), 16 deletions(-)

diff --git a/Trace/Hpc/Mix.hs b/Trace/Hpc/Mix.hs
index f4025d9..b4471a8 100644
--- a/Trace/Hpc/Mix.hs
+++ b/Trace/Hpc/Mix.hs
@@ -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,20 +97,17 @@ 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)
-                   | dirName <- dirNames
-                   ]
+   let modName = either id tixModuleName mod'
+   res <- sequence [
+      (do let mixPath = mixName dirName modName
+          let parse = fromMaybe (error $ "can not parse" ++ mixPath) . readMaybe
+          mix <- parse `fmap` readFile mixPath
+          case mod' of
+             Left  _   -> return $ Just mix -- Bypass hash check (fab3cfb)
+             Right tix -> return $ checkHash tix mix mixPath)
+        `catchIO` (\ _ -> return $ Nothing)
+      | dirName <- dirNames
+      ]
    case catMaybes res of
      xs@(x:_:_) | any (/= x) (tail xs) ->
               -- Only complain if multiple *different* `Mix` files with the
@@ -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)
diff --git a/changelog.md b/changelog.md
index dfb36fd..6312fa8 100644
--- a/changelog.md
+++ b/changelog.md
@@ -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
index 0000000..28f54ff
--- /dev/null
+++ b/tests/simple/tixs/.hpc/NoParse.mix
@@ -0,0 +1 @@
+NoParse
diff --git a/tests/simple/tixs/T10529a.stderr b/tests/simple/tixs/T10529a.stderr
new file mode 100644
index 0000000..945c633
--- /dev/null
+++ b/tests/simple/tixs/T10529a.stderr
@@ -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
index 0000000..4035997
--- /dev/null
+++ b/tests/simple/tixs/T10529b.stderr
@@ -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
index 0000000..5a0db11
--- /dev/null
+++ b/tests/simple/tixs/T10529c.stderr
@@ -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
index 0000000..f9c335e
--- /dev/null
+++ b/tests/simple/tixs/hpc_sample_incompatible_hash.tix
@@ -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
index 0000000..b2b2110
--- /dev/null
+++ b/tests/simple/tixs/hpc_sample_no_parse.tix
@@ -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
index 0000000..1fa93c5
--- /dev/null
+++ b/tests/simple/tixs/hpc_sample_non_existing_module.tix
@@ -0,0 +1 @@
+Tix [ TixModule "NonExistingModule" 2454134535 5 [1,0,1,1,1]]
diff --git a/tests/simple/tixs/test.T b/tests/simple/tixs/test.T
index 8e98d0e..da88911 100644
--- a/tests/simple/tixs/test.T
+++ b/tests/simple/tixs/test.T
@@ -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"])



More information about the ghc-commits mailing list