[commit: packages/hpc] wip/T10529: Improve error messages in readMix (#10529) (eaf1906)
git at git.haskell.org
git at git.haskell.org
Tue Jun 16 13:06:04 UTC 2015
Repository : ssh://git@git.haskell.org/hpc
On branch : wip/T10529
Link : http://git.haskell.org/packages/hpc.git/commitdiff/eaf1906f4456765becd3b52dee0188750feab2bf
>---------------------------------------------------------------
commit eaf1906f4456765becd3b52dee0188750feab2bf
Author: Thomas Miedema <thomasmiedema at gmail.com>
Date: Tue Jun 16 14:48:19 2015 +0200
Improve error messages in readMix (#10529)
>---------------------------------------------------------------
eaf1906f4456765becd3b52dee0188750feab2bf
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 | 1 +
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, 48 insertions(+), 15 deletions(-)
diff --git a/Trace/Hpc/Mix.hs b/Trace/Hpc/Mix.hs
index f4025d9..695791e 100644
--- a/Trace/Hpc/Mix.hs
+++ b/Trace/Hpc/Mix.hs
@@ -25,10 +25,18 @@ module Trace.Hpc.Mix
import Data.Maybe (catMaybes)
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,18 @@ 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 path = mixName dirName modName
+ contents <- readFile path
+ case readMaybe contents of
+ Just x | hashCheck mod' x -> return (Just x)
+ | otherwise -> error $ "hash in .tix file does " ++
+ "not match hash in " ++ path
+ Nothing -> error $ "can not parse " ++ path)
+ `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 +121,14 @@ readMix dirNames mod' = do
mixName :: FilePath -> String -> String
mixName dirName name = dirName </> name <.> "mix"
+-- | Check that hash in .tix and .mix file match.
+hashCheck :: Either String TixModule -- ^ module wanted
+ -> Mix -- ^ Mix DataStructure
+ -> Bool
+hashCheck mod' (Mix _ _ h _ _) = case mod' of
+ Left _ -> True -- Bypass hash check. This is a feature. See fab3cfb.
+ Right tix -> h == 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..14591d0
--- /dev/null
+++ b/tests/simple/tixs/T10529b.stderr
@@ -0,0 +1 @@
+hpc: hash in .tix file does not match hash in ./.hpc/Main.mix
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