1{-# LANGUAGE CPP #-} 2#ifdef __GLASGOW_HASKELL__ 3{-# LANGUAGE Safe #-} 4#endif 5----------------------------------------- 6-- Andy Gill and Colin Runciman, June 2006 7------------------------------------------ 8 9-- | Minor utilities for the HPC tools. 10 11module Trace.Hpc.Util 12 ( HpcPos 13 , fromHpcPos 14 , toHpcPos 15 , insideHpcPos 16 , HpcHash(..) 17 , Hash 18 , catchIO 19 , readFileUtf8 20 , writeFileUtf8 21 ) where 22 23import Control.DeepSeq (deepseq) 24import qualified Control.Exception as Exception 25import Data.List(foldl') 26import Data.Char (ord) 27import Data.Bits (xor) 28import Data.Word 29import System.Directory (createDirectoryIfMissing) 30import System.FilePath (takeDirectory) 31import System.IO 32 33-- | 'HpcPos' is an Hpc local rendition of a Span. 34data HpcPos = P !Int !Int !Int !Int deriving (Eq, Ord) 35 36-- | 'fromHpcPos' explodes the HpcPos into /line:column/-/line:column/ 37fromHpcPos :: HpcPos -> (Int,Int,Int,Int) 38fromHpcPos (P l1 c1 l2 c2) = (l1,c1,l2,c2) 39 40-- | 'toHpcPos' implodes to HpcPos, from /line:column/-/line:column/ 41toHpcPos :: (Int,Int,Int,Int) -> HpcPos 42toHpcPos (l1,c1,l2,c2) = P l1 c1 l2 c2 43 44-- | Predicate determining whether the first argument is inside the second argument. 45insideHpcPos :: HpcPos -> HpcPos -> Bool 46insideHpcPos small big = 47 sl1 >= bl1 && 48 (sl1 /= bl1 || sc1 >= bc1) && 49 sl2 <= bl2 && 50 (sl2 /= bl2 || sc2 <= bc2) 51 where (sl1,sc1,sl2,sc2) = fromHpcPos small 52 (bl1,bc1,bl2,bc2) = fromHpcPos big 53 54instance Show HpcPos where 55 show (P l1 c1 l2 c2) = show l1 ++ ':' : show c1 ++ '-' : show l2 ++ ':' : show c2 56 57instance Read HpcPos where 58 readsPrec _i pos = [(toHpcPos (read l1,read c1,read l2,read c2),after)] 59 where 60 (before,after) = span (/= ',') pos 61 parseError a = error $ "Read HpcPos: Could not parse: " ++ show a 62 (lhs0,rhs0) = case span (/= '-') before of 63 (lhs,'-':rhs) -> (lhs,rhs) 64 (lhs,"") -> (lhs,lhs) 65 _ -> parseError before 66 (l1,c1) = case span (/= ':') lhs0 of 67 (l,':':c) -> (l,c) 68 _ -> parseError lhs0 69 (l2,c2) = case span (/= ':') rhs0 of 70 (l,':':c) -> (l,c) 71 _ -> parseError rhs0 72 73------------------------------------------------------------------------------ 74 75-- Very simple Hash number generators 76 77class HpcHash a where 78 toHash :: a -> Hash 79 80newtype Hash = Hash Word32 deriving (Eq) 81 82instance Read Hash where 83 readsPrec p n = [ (Hash v,rest) 84 | (v,rest) <- readsPrec p n 85 ] 86 87instance Show Hash where 88 showsPrec p (Hash n) = showsPrec p n 89 90instance Num Hash where 91 (Hash a) + (Hash b) = Hash $ a + b 92 (Hash a) * (Hash b) = Hash $ a * b 93 (Hash a) - (Hash b) = Hash $ a - b 94 negate (Hash a) = Hash $ negate a 95 abs (Hash a) = Hash $ abs a 96 signum (Hash a) = Hash $ signum a 97 fromInteger n = Hash $ fromInteger n 98 99instance HpcHash Int where 100 toHash n = Hash $ fromIntegral n 101 102instance HpcHash Integer where 103 toHash n = fromInteger n 104 105instance HpcHash Char where 106 toHash c = Hash $ fromIntegral $ ord c 107 108instance HpcHash Bool where 109 toHash True = 1 110 toHash False = 0 111 112instance HpcHash a => HpcHash [a] where 113 toHash xs = foldl' (\ h c -> toHash c `hxor` (h * 33)) 5381 xs 114 115instance (HpcHash a,HpcHash b) => HpcHash (a,b) where 116 toHash (a,b) = (toHash a * 33) `hxor` toHash b 117 118instance HpcHash HpcPos where 119 toHash (P a b c d) = Hash $ fromIntegral $ a * 0x1000000 + b * 0x10000 + c * 0x100 + d 120 121hxor :: Hash -> Hash -> Hash 122hxor (Hash x) (Hash y) = Hash $ x `xor` y 123 124catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a 125catchIO = Exception.catch 126 127 128-- | Read a file strictly, as opposed to how `readFile` does it using lazy IO, but also 129-- disregard system locale and assume that the file is encoded in UTF-8. Haskell source 130-- files are expected to be encoded in UTF-8 by GHC. 131readFileUtf8 :: FilePath -> IO String 132readFileUtf8 filepath = 133 withBinaryFile filepath ReadMode $ \h -> do 134 hSetEncoding h utf8 -- see #17073 135 contents <- hGetContents h 136 contents `deepseq` hClose h -- prevent lazy IO 137 return contents 138 139-- | Write file in UTF-8 encoding. Parent directory will be created if missing. 140writeFileUtf8 :: FilePath -> String -> IO () 141writeFileUtf8 filepath str = do 142 createDirectoryIfMissing True (takeDirectory filepath) 143 withBinaryFile filepath WriteMode $ \h -> do 144 hSetEncoding h utf8 -- see #17073 145 hPutStr h str 146