[commit: packages/hpc] wip/T10529: Improve error messages in readMix (#10529) (6b88e91)
git at git.haskell.org
git at git.haskell.org
Tue Jun 16 18:48:10 UTC 2015
Repository : ssh://git@git.haskell.org/hpc
On branch : wip/T10529
Link : http://git.haskell.org/packages/hpc.git/commitdiff/6b88e91c8a0e7806d44d999616983c60a0b8eb78
>---------------------------------------------------------------
commit 6b88e91c8a0e7806d44d999616983c60a0b8eb78
Author: Thomas Miedema <thomasmiedema at gmail.com>
Date: Tue Jun 16 14:48:19 2015 +0200
Improve error messages in readMix (#10529)
>---------------------------------------------------------------
6b88e91c8a0e7806d44d999616983c60a0b8eb78
Trace/Hpc/Mix.hs | 44 +++++++++++++++-------
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, 50 insertions(+), 14 deletions(-)
diff --git a/Trace/Hpc/Mix.hs b/Trace/Hpc/Mix.hs
index f4025d9..0a5f054 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,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)
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