7ede8b6f353924c20a9eeb4a9c3fb26531a69968
[packages/hpc.git] / Trace / Hpc / Util.hs
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
11 module Trace.Hpc.Util
12 ( HpcPos
13 , fromHpcPos
14 , toHpcPos
15 , insideHpcPos
16 , HpcHash(..)
17 , Hash
18 , catchIO
19 ) where
20
21 import qualified Control.Exception as Exception
22 import Data.List(foldl')
23 import Data.Char (ord)
24 import Data.Bits (xor)
25 import Data.Word
26
27 -- | 'HpcPos' is an Hpc local rendition of a Span.
28 data HpcPos = P !Int !Int !Int !Int deriving (Eq, Ord)
29
30 -- | 'fromHpcPos' explodes the HpcPos into line:column-line:colunm
31 fromHpcPos :: HpcPos -> (Int,Int,Int,Int)
32 fromHpcPos (P l1 c1 l2 c2) = (l1,c1,l2,c2)
33
34 -- | 'toHpcPos' implodes to HpcPos, from line:column-line:colunm
35 toHpcPos :: (Int,Int,Int,Int) -> HpcPos
36 toHpcPos (l1,c1,l2,c2) = P l1 c1 l2 c2
37
38 -- | asks the question, is the first argument inside the second argument.
39 insideHpcPos :: HpcPos -> HpcPos -> Bool
40 insideHpcPos small big =
41 sl1 >= bl1 &&
42 (sl1 /= bl1 || sc1 >= bc1) &&
43 sl2 <= bl2 &&
44 (sl2 /= bl2 || sc2 <= bc2)
45 where (sl1,sc1,sl2,sc2) = fromHpcPos small
46 (bl1,bc1,bl2,bc2) = fromHpcPos big
47
48 instance Show HpcPos where
49 show (P l1 c1 l2 c2) = show l1 ++ ':' : show c1 ++ '-' : show l2 ++ ':' : show c2
50
51 instance Read HpcPos where
52 readsPrec _i pos = [(toHpcPos (read l1,read c1,read l2,read c2),after)]
53 where
54 (before,after) = span (/= ',') pos
55 (lhs0,rhs0) = case span (/= '-') before of
56 (lhs,'-':rhs) -> (lhs,rhs)
57 (lhs,"") -> (lhs,lhs)
58 _ -> error "bad parse"
59 (l1,':':c1) = span (/= ':') lhs0
60 (l2,':':c2) = span (/= ':') rhs0
61
62 ------------------------------------------------------------------------------
63
64 -- Very simple Hash number generators
65
66 class HpcHash a where
67 toHash :: a -> Hash
68
69 newtype Hash = Hash Word32 deriving (Eq)
70
71 instance Read Hash where
72 readsPrec p n = [ (Hash v,rest)
73 | (v,rest) <- readsPrec p n
74 ]
75
76 instance Show Hash where
77 showsPrec p (Hash n) = showsPrec p n
78
79 instance Num Hash where
80 (Hash a) + (Hash b) = Hash $ a + b
81 (Hash a) * (Hash b) = Hash $ a * b
82 (Hash a) - (Hash b) = Hash $ a - b
83 negate (Hash a) = Hash $ negate a
84 abs (Hash a) = Hash $ abs a
85 signum (Hash a) = Hash $ signum a
86 fromInteger n = Hash $ fromInteger n
87
88 instance HpcHash Int where
89 toHash n = Hash $ fromIntegral n
90
91 instance HpcHash Integer where
92 toHash n = fromInteger n
93
94 instance HpcHash Char where
95 toHash c = Hash $ fromIntegral $ ord c
96
97 instance HpcHash Bool where
98 toHash True = 1
99 toHash False = 0
100
101 instance HpcHash a => HpcHash [a] where
102 toHash xs = foldl' (\ h c -> toHash c `hxor` (h * 33)) 5381 xs
103
104 instance (HpcHash a,HpcHash b) => HpcHash (a,b) where
105 toHash (a,b) = (toHash a * 33) `hxor` toHash b
106
107 instance HpcHash HpcPos where
108 toHash (P a b c d) = Hash $ fromIntegral $ a * 0x1000000 + b * 0x10000 + c * 0x100 + d
109
110 hxor :: Hash -> Hash -> Hash
111 hxor (Hash x) (Hash y) = Hash $ x `xor` y
112
113 catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a
114 catchIO = Exception.catch
115