Commits (1)
...@@ -18,7 +18,7 @@ module Trace.Hpc.Tix(Tix(..), TixModule(..), ...@@ -18,7 +18,7 @@ module Trace.Hpc.Tix(Tix(..), TixModule(..),
import System.FilePath (replaceExtension) import System.FilePath (replaceExtension)
import Trace.Hpc.Util (Hash, catchIO) import Trace.Hpc.Util (Hash, catchIO, readFileUtf8, writeFileUtf8)
-- | 'Tix' is the storage format for our dynamic information about -- | 'Tix' is the storage format for our dynamic information about
-- what boxes are ticked. -- what boxes are ticked.
...@@ -45,17 +45,15 @@ tixModuleTixs (TixModule _ _ _ tixs) = tixs ...@@ -45,17 +45,15 @@ tixModuleTixs (TixModule _ _ _ tixs) = tixs
-- | Read a @.tix@ File. -- | Read a @.tix@ File.
readTix :: String readTix :: String
-> IO (Maybe Tix) -> IO (Maybe Tix)
readTix tix_filename = readTix tixFilename =
catchIO (do contents <- readFile $ tix_filename catchIO (fmap (Just . read) $ readFileUtf8 tixFilename)
return $ Just $ read contents) (const $ return Nothing)
(\ _ -> return $ Nothing)
-- | Write a @.tix@ File. -- | Write a @.tix@ File.
writeTix :: String writeTix :: String
-> Tix -> Tix
-> IO () -> IO ()
writeTix name tix = writeTix name tix = writeFileUtf8 name (show tix)
writeFile name (show tix)
-- | 'getTixFullName' takes a binary or @.tix@-file name, -- | 'getTixFullName' takes a binary or @.tix@-file name,
-- and normalizes it into a @.tix@-file name. -- and normalizes it into a @.tix@-file name.
......
...@@ -16,13 +16,19 @@ module Trace.Hpc.Util ...@@ -16,13 +16,19 @@ module Trace.Hpc.Util
, HpcHash(..) , HpcHash(..)
, Hash , Hash
, catchIO , catchIO
, readFileUtf8
, writeFileUtf8
) where ) where
import Control.DeepSeq (deepseq)
import qualified Control.Exception as Exception import qualified Control.Exception as Exception
import Data.List(foldl') import Data.List(foldl')
import Data.Char (ord) import Data.Char (ord)
import Data.Bits (xor) import Data.Bits (xor)
import Data.Word import Data.Word
import System.Directory (createDirectoryIfMissing)
import System.FilePath (takeDirectory)
import System.IO
-- | 'HpcPos' is an Hpc local rendition of a Span. -- | 'HpcPos' is an Hpc local rendition of a Span.
data HpcPos = P !Int !Int !Int !Int deriving (Eq, Ord) data HpcPos = P !Int !Int !Int !Int deriving (Eq, Ord)
...@@ -117,3 +123,23 @@ hxor (Hash x) (Hash y) = Hash $ x `xor` y ...@@ -117,3 +123,23 @@ hxor (Hash x) (Hash y) = Hash $ x `xor` y
catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a
catchIO = Exception.catch catchIO = Exception.catch
-- | Read a file strictly, as opposed to how `readFile` does it using lazy IO, but also
-- disregard system locale and assume that the file is encoded in UTF-8. Haskell source
-- files are expected to be encoded in UTF-8 by GHC.
readFileUtf8 :: FilePath -> IO String
readFileUtf8 filepath =
withBinaryFile filepath ReadMode $ \h -> do
hSetEncoding h utf8 -- see #17073
contents <- hGetContents h
contents `deepseq` hClose h -- prevent lazy IO
return contents
-- | Write file in UTF-8 encoding. Parent directory will be created if missing.
writeFileUtf8 :: FilePath -> String -> IO ()
writeFileUtf8 filepath str = do
createDirectoryIfMissing True (takeDirectory filepath)
withBinaryFile filepath WriteMode $ \h -> do
hSetEncoding h utf8 -- see #17073
hPutStr h str
# Changelog for [`hpc` package](http://hackage.haskell.org/package/hpc) # Changelog for [`hpc` package](http://hackage.haskell.org/package/hpc)
## 0.6.1.0 *October 2019*
* Addition of `readFielUtf8` and `writeFileUtf8` functions.
* Ensure `.tix` files read and written in UTF-8, regadless of the system locale.
## 0.6.0.3 *May 2016* ## 0.6.0.3 *May 2016*
* Bundled with GHC 8.0.1 * Bundled with GHC 8.0.1
......
name: hpc name: hpc
version: 0.6.0.3 version: 0.6.1.0
-- NOTE: Don't forget to update ./changelog.md -- NOTE: Don't forget to update ./changelog.md
license: BSD3 license: BSD3
license-file: LICENSE license-file: LICENSE
...@@ -37,6 +37,7 @@ Library ...@@ -37,6 +37,7 @@ Library
Build-Depends: Build-Depends:
base >= 4.4.1 && < 4.15, base >= 4.4.1 && < 4.15,
containers >= 0.4.1 && < 0.7, containers >= 0.4.1 && < 0.7,
deepseq >= 1.1 && < 1.5,
directory >= 1.1 && < 1.4, directory >= 1.1 && < 1.4,
filepath >= 1 && < 1.5, filepath >= 1 && < 1.5,
time >= 1.2 && < 1.10 time >= 1.2 && < 1.10
......
...@@ -35,7 +35,6 @@ test('hpc_show_error_002', exit_code(1), run_command, ...@@ -35,7 +35,6 @@ test('hpc_show_error_002', exit_code(1), run_command,
["{hpc} show hpc001.hs"]) # bad .tix file ["{hpc} show hpc001.hs"]) # bad .tix file
test('hpc_help_version', normal, run_command, ["{hpc} help version"]) test('hpc_help_version', normal, run_command, ["{hpc} help version"])
test('hpc_version', normal, run_command, ["{hpc} version"])
test('hpc_help_draft', normal, run_command, ["{hpc} help draft"]) test('hpc_help_draft', normal, run_command, ["{hpc} help draft"])
test('hpc_draft', extra_files(['.hpc/', 'hpc001.hs', 'hpc_sample.tix']), run_command, ["{hpc} draft hpc_sample.tix"]) test('hpc_draft', extra_files(['.hpc/', 'hpc001.hs', 'hpc_sample.tix']), run_command, ["{hpc} draft hpc_sample.tix"])
......