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