{-# LANGUAGE CPP #-}
#ifdef __GLASGOW_HASKELL__
{-# LANGUAGE Safe #-}
#endif
module Trace.Hpc.Util
( HpcPos
, fromHpcPos
, toHpcPos
, insideHpcPos
, HpcHash(..)
, Hash
, catchIO
) where
import qualified Control.Exception as Exception
import Data.List(foldl')
import Data.Char (ord)
import Data.Bits (xor)
import Data.Word
data HpcPos = P !Int !Int !Int !Int deriving (HpcPos -> HpcPos -> Bool
(HpcPos -> HpcPos -> Bool)
-> (HpcPos -> HpcPos -> Bool) -> Eq HpcPos
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HpcPos -> HpcPos -> Bool
$c/= :: HpcPos -> HpcPos -> Bool
== :: HpcPos -> HpcPos -> Bool
$c== :: HpcPos -> HpcPos -> Bool
Eq, Eq HpcPos
Eq HpcPos =>
(HpcPos -> HpcPos -> Ordering)
-> (HpcPos -> HpcPos -> Bool)
-> (HpcPos -> HpcPos -> Bool)
-> (HpcPos -> HpcPos -> Bool)
-> (HpcPos -> HpcPos -> Bool)
-> (HpcPos -> HpcPos -> HpcPos)
-> (HpcPos -> HpcPos -> HpcPos)
-> Ord HpcPos
HpcPos -> HpcPos -> Bool
HpcPos -> HpcPos -> Ordering
HpcPos -> HpcPos -> HpcPos
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: HpcPos -> HpcPos -> HpcPos
$cmin :: HpcPos -> HpcPos -> HpcPos
max :: HpcPos -> HpcPos -> HpcPos
$cmax :: HpcPos -> HpcPos -> HpcPos
>= :: HpcPos -> HpcPos -> Bool
$c>= :: HpcPos -> HpcPos -> Bool
> :: HpcPos -> HpcPos -> Bool
$c> :: HpcPos -> HpcPos -> Bool
<= :: HpcPos -> HpcPos -> Bool
$c<= :: HpcPos -> HpcPos -> Bool
< :: HpcPos -> HpcPos -> Bool
$c< :: HpcPos -> HpcPos -> Bool
compare :: HpcPos -> HpcPos -> Ordering
$ccompare :: HpcPos -> HpcPos -> Ordering
$cp1Ord :: Eq HpcPos
Ord)
fromHpcPos :: HpcPos -> (Int,Int,Int,Int)
fromHpcPos :: HpcPos -> (Int, Int, Int, Int)
fromHpcPos (P l1 :: Int
l1 c1 :: Int
c1 l2 :: Int
l2 c2 :: Int
c2) = (Int
l1,Int
c1,Int
l2,Int
c2)
toHpcPos :: (Int,Int,Int,Int) -> HpcPos
toHpcPos :: (Int, Int, Int, Int) -> HpcPos
toHpcPos (l1 :: Int
l1,c1 :: Int
c1,l2 :: Int
l2,c2 :: Int
c2) = Int -> Int -> Int -> Int -> HpcPos
P Int
l1 Int
c1 Int
l2 Int
c2
insideHpcPos :: HpcPos -> HpcPos -> Bool
insideHpcPos :: HpcPos -> HpcPos -> Bool
insideHpcPos small :: HpcPos
small big :: HpcPos
big =
Int
sl1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
bl1 Bool -> Bool -> Bool
&&
(Int
sl1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
bl1 Bool -> Bool -> Bool
|| Int
sc1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
bc1) Bool -> Bool -> Bool
&&
Int
sl2 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
bl2 Bool -> Bool -> Bool
&&
(Int
sl2 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
bl2 Bool -> Bool -> Bool
|| Int
sc2 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
bc2)
where (sl1 :: Int
sl1,sc1 :: Int
sc1,sl2 :: Int
sl2,sc2 :: Int
sc2) = HpcPos -> (Int, Int, Int, Int)
fromHpcPos HpcPos
small
(bl1 :: Int
bl1,bc1 :: Int
bc1,bl2 :: Int
bl2,bc2 :: Int
bc2) = HpcPos -> (Int, Int, Int, Int)
fromHpcPos HpcPos
big
instance Show HpcPos where
show :: HpcPos -> String
show (P l1 :: Int
l1 c1 :: Int
c1 l2 :: Int
l2 c2 :: Int
c2) = Int -> String
forall a. Show a => a -> String
show Int
l1 String -> ShowS
forall a. [a] -> [a] -> [a]
++ ':' Char -> ShowS
forall a. a -> [a] -> [a]
: Int -> String
forall a. Show a => a -> String
show Int
c1 String -> ShowS
forall a. [a] -> [a] -> [a]
++ '-' Char -> ShowS
forall a. a -> [a] -> [a]
: Int -> String
forall a. Show a => a -> String
show Int
l2 String -> ShowS
forall a. [a] -> [a] -> [a]
++ ':' Char -> ShowS
forall a. a -> [a] -> [a]
: Int -> String
forall a. Show a => a -> String
show Int
c2
instance Read HpcPos where
readsPrec :: Int -> ReadS HpcPos
readsPrec _i :: Int
_i pos :: String
pos = [((Int, Int, Int, Int) -> HpcPos
toHpcPos (String -> Int
forall a. Read a => String -> a
read String
l1,String -> Int
forall a. Read a => String -> a
read String
c1,String -> Int
forall a. Read a => String -> a
read String
l2,String -> Int
forall a. Read a => String -> a
read String
c2),String
after)]
where
(before :: String
before,after :: String
after) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= ',') String
pos
parseError :: a -> a
parseError a :: a
a = String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ "Read HpcPos: Could not parse: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
a
(lhs0 :: String
lhs0,rhs0 :: String
rhs0) = case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= '-') String
before of
(lhs :: String
lhs,'-':rhs :: String
rhs) -> (String
lhs,String
rhs)
(lhs :: String
lhs,"") -> (String
lhs,String
lhs)
_ -> String -> (String, String)
forall a a. Show a => a -> a
parseError String
before
(l1 :: String
l1,c1 :: String
c1) = case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= ':') String
lhs0 of
(l :: String
l,':':c :: String
c) -> (String
l,String
c)
_ -> String -> (String, String)
forall a a. Show a => a -> a
parseError String
lhs0
(l2 :: String
l2,c2 :: String
c2) = case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= ':') String
rhs0 of
(l :: String
l,':':c :: String
c) -> (String
l,String
c)
_ -> String -> (String, String)
forall a a. Show a => a -> a
parseError String
rhs0
class HpcHash a where
toHash :: a -> Hash
newtype Hash = Hash Word32 deriving (Hash -> Hash -> Bool
(Hash -> Hash -> Bool) -> (Hash -> Hash -> Bool) -> Eq Hash
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Hash -> Hash -> Bool
$c/= :: Hash -> Hash -> Bool
== :: Hash -> Hash -> Bool
$c== :: Hash -> Hash -> Bool
Eq)
instance Read Hash where
readsPrec :: Int -> ReadS Hash
readsPrec p :: Int
p n :: String
n = [ (Word32 -> Hash
Hash Word32
v,String
rest)
| (v :: Word32
v,rest :: String
rest) <- Int -> ReadS Word32
forall a. Read a => Int -> ReadS a
readsPrec Int
p String
n
]
instance Show Hash where
showsPrec :: Int -> Hash -> ShowS
showsPrec p :: Int
p (Hash n :: Word32
n) = Int -> Word32 -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
p Word32
n
instance Num Hash where
(Hash a :: Word32
a) + :: Hash -> Hash -> Hash
+ (Hash b :: Word32
b) = Word32 -> Hash
Hash (Word32 -> Hash) -> Word32 -> Hash
forall a b. (a -> b) -> a -> b
$ Word32
a Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
b
(Hash a :: Word32
a) * :: Hash -> Hash -> Hash
* (Hash b :: Word32
b) = Word32 -> Hash
Hash (Word32 -> Hash) -> Word32 -> Hash
forall a b. (a -> b) -> a -> b
$ Word32
a Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
* Word32
b
(Hash a :: Word32
a) - :: Hash -> Hash -> Hash
- (Hash b :: Word32
b) = Word32 -> Hash
Hash (Word32 -> Hash) -> Word32 -> Hash
forall a b. (a -> b) -> a -> b
$ Word32
a Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
- Word32
b
negate :: Hash -> Hash
negate (Hash a :: Word32
a) = Word32 -> Hash
Hash (Word32 -> Hash) -> Word32 -> Hash
forall a b. (a -> b) -> a -> b
$ Word32 -> Word32
forall a. Num a => a -> a
negate Word32
a
abs :: Hash -> Hash
abs (Hash a :: Word32
a) = Word32 -> Hash
Hash (Word32 -> Hash) -> Word32 -> Hash
forall a b. (a -> b) -> a -> b
$ Word32 -> Word32
forall a. Num a => a -> a
abs Word32
a
signum :: Hash -> Hash
signum (Hash a :: Word32
a) = Word32 -> Hash
Hash (Word32 -> Hash) -> Word32 -> Hash
forall a b. (a -> b) -> a -> b
$ Word32 -> Word32
forall a. Num a => a -> a
signum Word32
a
fromInteger :: Integer -> Hash
fromInteger n :: Integer
n = Word32 -> Hash
Hash (Word32 -> Hash) -> Word32 -> Hash
forall a b. (a -> b) -> a -> b
$ Integer -> Word32
forall a. Num a => Integer -> a
fromInteger Integer
n
instance HpcHash Int where
toHash :: Int -> Hash
toHash n :: Int
n = Word32 -> Hash
Hash (Word32 -> Hash) -> Word32 -> Hash
forall a b. (a -> b) -> a -> b
$ Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n
instance HpcHash Integer where
toHash :: Integer -> Hash
toHash n :: Integer
n = Integer -> Hash
forall a. Num a => Integer -> a
fromInteger Integer
n
instance HpcHash Char where
toHash :: Char -> Hash
toHash c :: Char
c = Word32 -> Hash
Hash (Word32 -> Hash) -> Word32 -> Hash
forall a b. (a -> b) -> a -> b
$ Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word32) -> Int -> Word32
forall a b. (a -> b) -> a -> b
$ Char -> Int
ord Char
c
instance HpcHash Bool where
toHash :: Bool -> Hash
toHash True = 1
toHash False = 0
instance HpcHash a => HpcHash [a] where
toHash :: [a] -> Hash
toHash xs :: [a]
xs = (Hash -> a -> Hash) -> Hash -> [a] -> Hash
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\ h :: Hash
h c :: a
c -> a -> Hash
forall a. HpcHash a => a -> Hash
toHash a
c Hash -> Hash -> Hash
`hxor` (Hash
h Hash -> Hash -> Hash
forall a. Num a => a -> a -> a
* 33)) 5381 [a]
xs
instance (HpcHash a,HpcHash b) => HpcHash (a,b) where
toHash :: (a, b) -> Hash
toHash (a :: a
a,b :: b
b) = (a -> Hash
forall a. HpcHash a => a -> Hash
toHash a
a Hash -> Hash -> Hash
forall a. Num a => a -> a -> a
* 33) Hash -> Hash -> Hash
`hxor` b -> Hash
forall a. HpcHash a => a -> Hash
toHash b
b
instance HpcHash HpcPos where
toHash :: HpcPos -> Hash
toHash (P a :: Int
a b :: Int
b c :: Int
c d :: Int
d) = Word32 -> Hash
Hash (Word32 -> Hash) -> Word32 -> Hash
forall a b. (a -> b) -> a -> b
$ Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word32) -> Int -> Word32
forall a b. (a -> b) -> a -> b
$ Int
a Int -> Int -> Int
forall a. Num a => a -> a -> a
* 0x1000000 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
b Int -> Int -> Int
forall a. Num a => a -> a -> a
* 0x10000 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
c Int -> Int -> Int
forall a. Num a => a -> a -> a
* 0x100 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
d
hxor :: Hash -> Hash -> Hash
hxor :: Hash -> Hash -> Hash
hxor (Hash x :: Word32
x) (Hash y :: Word32
y) = Word32 -> Hash
Hash (Word32 -> Hash) -> Word32 -> Hash
forall a b. (a -> b) -> a -> b
$ Word32
x Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
`xor` Word32
y
catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a
catchIO :: IO a -> (IOException -> IO a) -> IO a
catchIO = IO a -> (IOException -> IO a) -> IO a
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
Exception.catch