{-# LANGUAGE DeriveGeneric, StandaloneDeriving #-}
module Trace.Hpc.Util
( HpcPos
, fromHpcPos
, toHpcPos
, insideHpcPos
, HpcHash(..)
, Hash
, catchIO
, readFileUtf8
, writeFileUtf8
) where
import Prelude hiding (Foldable(..))
import Control.DeepSeq (deepseq, NFData)
import qualified Control.Exception as Exception
import Data.Char (ord)
import Data.Bits (xor)
import Data.Foldable (Foldable(..))
import Data.Word
import GHC.Generics (Generic)
import System.Directory (createDirectoryIfMissing)
import System.FilePath (takeDirectory)
import System.IO
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
$c== :: HpcPos -> HpcPos -> Bool
== :: HpcPos -> HpcPos -> Bool
$c/= :: HpcPos -> HpcPos -> Bool
/= :: 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
$ccompare :: HpcPos -> HpcPos -> Ordering
compare :: HpcPos -> HpcPos -> Ordering
$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
>= :: HpcPos -> HpcPos -> Bool
$cmax :: HpcPos -> HpcPos -> HpcPos
max :: HpcPos -> HpcPos -> HpcPos
$cmin :: HpcPos -> HpcPos -> HpcPos
min :: HpcPos -> HpcPos -> HpcPos
Ord)
fromHpcPos :: HpcPos -> (Int,Int,Int,Int)
fromHpcPos :: HpcPos -> (Int, Int, Int, Int)
fromHpcPos (P Int
l1 Int
c1 Int
l2 Int
c2) = (Int
l1,Int
c1,Int
l2,Int
c2)
toHpcPos :: (Int,Int,Int,Int) -> HpcPos
toHpcPos :: (Int, Int, Int, Int) -> HpcPos
toHpcPos (Int
l1,Int
c1,Int
l2,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 HpcPos
small 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 (Int
sl1,Int
sc1,Int
sl2,Int
sc2) = HpcPos -> (Int, Int, Int, Int)
fromHpcPos HpcPos
small
(Int
bl1,Int
bc1,Int
bl2,Int
bc2) = HpcPos -> (Int, Int, Int, Int)
fromHpcPos HpcPos
big
instance Show HpcPos where
show :: HpcPos -> [Char]
show (P Int
l1 Int
c1 Int
l2 Int
c2) = Int -> [Char]
forall a. Show a => a -> [Char]
show Int
l1 [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Char
':' Char -> ShowS
forall a. a -> [a] -> [a]
: Int -> [Char]
forall a. Show a => a -> [Char]
show Int
c1 [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Char
'-' Char -> ShowS
forall a. a -> [a] -> [a]
: Int -> [Char]
forall a. Show a => a -> [Char]
show Int
l2 [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Char
':' Char -> ShowS
forall a. a -> [a] -> [a]
: Int -> [Char]
forall a. Show a => a -> [Char]
show Int
c2
instance Read HpcPos where
readsPrec :: Int -> ReadS HpcPos
readsPrec Int
_i [Char]
pos = [((Int, Int, Int, Int) -> HpcPos
toHpcPos ([Char] -> Int
forall a. Read a => [Char] -> a
read [Char]
l1,[Char] -> Int
forall a. Read a => [Char] -> a
read [Char]
c1,[Char] -> Int
forall a. Read a => [Char] -> a
read [Char]
l2,[Char] -> Int
forall a. Read a => [Char] -> a
read [Char]
c2),[Char]
after)]
where
([Char]
before,[Char]
after) = (Char -> Bool) -> [Char] -> ([Char], [Char])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
',') [Char]
pos
parseError :: a -> b
parseError a
a = [Char] -> b
forall a. HasCallStack => [Char] -> a
error ([Char] -> b) -> [Char] -> b
forall a b. (a -> b) -> a -> b
$ [Char]
"Read HpcPos: Could not parse: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> [Char]
forall a. Show a => a -> [Char]
show a
a
([Char]
lhs0,[Char]
rhs0) = case (Char -> Bool) -> [Char] -> ([Char], [Char])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'-') [Char]
before of
([Char]
lhs,Char
'-':[Char]
rhs) -> ([Char]
lhs,[Char]
rhs)
([Char]
lhs,[Char]
"") -> ([Char]
lhs,[Char]
lhs)
([Char], [Char])
_ -> [Char] -> ([Char], [Char])
forall {a} {b}. Show a => a -> b
parseError [Char]
before
([Char]
l1,[Char]
c1) = case (Char -> Bool) -> [Char] -> ([Char], [Char])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
':') [Char]
lhs0 of
([Char]
l,Char
':':[Char]
c) -> ([Char]
l,[Char]
c)
([Char], [Char])
_ -> [Char] -> ([Char], [Char])
forall {a} {b}. Show a => a -> b
parseError [Char]
lhs0
([Char]
l2,[Char]
c2) = case (Char -> Bool) -> [Char] -> ([Char], [Char])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
':') [Char]
rhs0 of
([Char]
l,Char
':':[Char]
c) -> ([Char]
l,[Char]
c)
([Char], [Char])
_ -> [Char] -> ([Char], [Char])
forall {a} {b}. Show a => a -> b
parseError [Char]
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
$c== :: Hash -> Hash -> Bool
== :: Hash -> Hash -> Bool
$c/= :: Hash -> Hash -> Bool
/= :: Hash -> Hash -> Bool
Eq)
deriving instance (Generic Hash)
instance NFData Hash
instance Read Hash where
readsPrec :: Int -> ReadS Hash
readsPrec Int
p [Char]
n = [ (Word32 -> Hash
Hash Word32
v,[Char]
rest)
| (Word32
v,[Char]
rest) <- Int -> ReadS Word32
forall a. Read a => Int -> ReadS a
readsPrec Int
p [Char]
n
]
instance Show Hash where
showsPrec :: Int -> Hash -> ShowS
showsPrec Int
p (Hash Word32
n) = Int -> Word32 -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
p Word32
n
instance Num Hash where
(Hash Word32
a) + :: Hash -> Hash -> Hash
+ (Hash 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 Word32
a) * :: Hash -> Hash -> Hash
* (Hash 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 Word32
a) - :: Hash -> Hash -> Hash
- (Hash 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 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 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 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 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 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 Integer
n = Integer -> Hash
forall a. Num a => Integer -> a
fromInteger Integer
n
instance HpcHash Char where
toHash :: Char -> Hash
toHash 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 Bool
True = Hash
1
toHash Bool
False = Hash
0
instance HpcHash a => HpcHash [a] where
toHash :: [a] -> Hash
toHash [a]
xs = (Hash -> a -> Hash) -> Hash -> [a] -> Hash
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\ Hash
h 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
* Hash
33)) Hash
5381 [a]
xs
instance (HpcHash a,HpcHash b) => HpcHash (a,b) where
toHash :: (a, b) -> Hash
toHash (a
a,b
b) = (a -> Hash
forall a. HpcHash a => a -> Hash
toHash a
a Hash -> Hash -> Hash
forall a. Num a => a -> a -> a
* Hash
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 Int
a Int
b Int
c 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
* Int
0x1000000 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
b Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
0x10000 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
c Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
0x100 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
d
hxor :: Hash -> Hash -> Hash
hxor :: Hash -> Hash -> Hash
hxor (Hash Word32
x) (Hash 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 :: forall a. 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
readFileUtf8 :: FilePath -> IO String
readFileUtf8 :: [Char] -> IO [Char]
readFileUtf8 [Char]
filepath =
[Char] -> IOMode -> (Handle -> IO [Char]) -> IO [Char]
forall r. [Char] -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile [Char]
filepath IOMode
ReadMode ((Handle -> IO [Char]) -> IO [Char])
-> (Handle -> IO [Char]) -> IO [Char]
forall a b. (a -> b) -> a -> b
$ \Handle
h -> do
Handle -> TextEncoding -> IO ()
hSetEncoding Handle
h TextEncoding
utf8
contents <- Handle -> IO [Char]
hGetContents Handle
h
contents `deepseq` hClose h
return contents
writeFileUtf8 :: FilePath -> String -> IO ()
writeFileUtf8 :: [Char] -> [Char] -> IO ()
writeFileUtf8 [Char]
filepath [Char]
str = do
Bool -> [Char] -> IO ()
createDirectoryIfMissing Bool
True (ShowS
takeDirectory [Char]
filepath)
[Char] -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. [Char] -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile [Char]
filepath IOMode
WriteMode ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
h -> do
Handle -> TextEncoding -> IO ()
hSetEncoding Handle
h TextEncoding
utf8
Handle -> [Char] -> IO ()
hPutStr Handle
h [Char]
str