{-# 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
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
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
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 forall a. Ord a => a -> a -> Bool
>= Int
bl1 Bool -> Bool -> Bool
&&
(Int
sl1 forall a. Eq a => a -> a -> Bool
/= Int
bl1 Bool -> Bool -> Bool
|| Int
sc1 forall a. Ord a => a -> a -> Bool
>= Int
bc1) Bool -> Bool -> Bool
&&
Int
sl2 forall a. Ord a => a -> a -> Bool
<= Int
bl2 Bool -> Bool -> Bool
&&
(Int
sl2 forall a. Eq a => a -> a -> Bool
/= Int
bl2 Bool -> Bool -> Bool
|| Int
sc2 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 -> String
show (P Int
l1 Int
c1 Int
l2 Int
c2) = forall a. Show a => a -> String
show Int
l1 forall a. [a] -> [a] -> [a]
++ Char
':' forall a. a -> [a] -> [a]
: forall a. Show a => a -> String
show Int
c1 forall a. [a] -> [a] -> [a]
++ Char
'-' forall a. a -> [a] -> [a]
: forall a. Show a => a -> String
show Int
l2 forall a. [a] -> [a] -> [a]
++ Char
':' forall a. a -> [a] -> [a]
: forall a. Show a => a -> String
show Int
c2
instance Read HpcPos where
readsPrec :: Int -> ReadS HpcPos
readsPrec Int
_i String
pos = [((Int, Int, Int, Int) -> HpcPos
toHpcPos (forall a. Read a => String -> a
read String
l1,forall a. Read a => String -> a
read String
c1,forall a. Read a => String -> a
read String
l2,forall a. Read a => String -> a
read String
c2),String
after)]
where
(String
before,String
after) = forall a. (a -> Bool) -> [a] -> ([a], [a])
span (forall a. Eq a => a -> a -> Bool
/= Char
',') String
pos
parseError :: a -> a
parseError a
a = forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Read HpcPos: Could not parse: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
a
(String
lhs0,String
rhs0) = case forall a. (a -> Bool) -> [a] -> ([a], [a])
span (forall a. Eq a => a -> a -> Bool
/= Char
'-') String
before of
(String
lhs,Char
'-':String
rhs) -> (String
lhs,String
rhs)
(String
lhs,String
"") -> (String
lhs,String
lhs)
(String, String)
_ -> forall {a} {a}. Show a => a -> a
parseError String
before
(String
l1,String
c1) = case forall a. (a -> Bool) -> [a] -> ([a], [a])
span (forall a. Eq a => a -> a -> Bool
/= Char
':') String
lhs0 of
(String
l,Char
':':String
c) -> (String
l,String
c)
(String, String)
_ -> forall {a} {a}. Show a => a -> a
parseError String
lhs0
(String
l2,String
c2) = case forall a. (a -> Bool) -> [a] -> ([a], [a])
span (forall a. Eq a => a -> a -> Bool
/= Char
':') String
rhs0 of
(String
l,Char
':':String
c) -> (String
l,String
c)
(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
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)
deriving instance (Generic Hash)
instance NFData Hash
instance Read Hash where
readsPrec :: Int -> ReadS Hash
readsPrec Int
p String
n = [ (Word32 -> Hash
Hash Word32
v,String
rest)
| (Word32
v,String
rest) <- forall a. Read a => Int -> ReadS a
readsPrec Int
p String
n
]
instance Show Hash where
showsPrec :: Int -> Hash -> ShowS
showsPrec Int
p (Hash Word32
n) = 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 forall a b. (a -> b) -> a -> b
$ Word32
a forall a. Num a => a -> a -> a
+ Word32
b
(Hash Word32
a) * :: Hash -> Hash -> Hash
* (Hash Word32
b) = Word32 -> Hash
Hash forall a b. (a -> b) -> a -> b
$ Word32
a forall a. Num a => a -> a -> a
* Word32
b
(Hash Word32
a) - :: Hash -> Hash -> Hash
- (Hash Word32
b) = Word32 -> Hash
Hash forall a b. (a -> b) -> a -> b
$ Word32
a forall a. Num a => a -> a -> a
- Word32
b
negate :: Hash -> Hash
negate (Hash Word32
a) = Word32 -> Hash
Hash forall a b. (a -> b) -> a -> b
$ forall a. Num a => a -> a
negate Word32
a
abs :: Hash -> Hash
abs (Hash Word32
a) = Word32 -> Hash
Hash forall a b. (a -> b) -> a -> b
$ forall a. Num a => a -> a
abs Word32
a
signum :: Hash -> Hash
signum (Hash Word32
a) = Word32 -> Hash
Hash forall a b. (a -> b) -> a -> b
$ forall a. Num a => a -> a
signum Word32
a
fromInteger :: Integer -> Hash
fromInteger Integer
n = Word32 -> Hash
Hash forall a b. (a -> b) -> a -> b
$ forall a. Num a => Integer -> a
fromInteger Integer
n
instance HpcHash Int where
toHash :: Int -> Hash
toHash Int
n = Word32 -> Hash
Hash forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n
instance HpcHash Integer where
toHash :: Integer -> Hash
toHash Integer
n = forall a. Num a => Integer -> a
fromInteger Integer
n
instance HpcHash Char where
toHash :: Char -> Hash
toHash Char
c = Word32 -> Hash
Hash forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral 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 = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\ Hash
h a
c -> forall a. HpcHash a => a -> Hash
toHash a
c Hash -> Hash -> Hash
`hxor` (Hash
h 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) = (forall a. HpcHash a => a -> Hash
toHash a
a forall a. Num a => a -> a -> a
* Hash
33) Hash -> Hash -> Hash
`hxor` 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 forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Int
a forall a. Num a => a -> a -> a
* Int
0x1000000 forall a. Num a => a -> a -> a
+ Int
b forall a. Num a => a -> a -> a
* Int
0x10000 forall a. Num a => a -> a -> a
+ Int
c forall a. Num a => a -> a -> a
* Int
0x100 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 forall a b. (a -> b) -> a -> b
$ Word32
x 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 = forall e a. Exception e => IO a -> (e -> IO a) -> IO a
Exception.catch
readFileUtf8 :: FilePath -> IO String
readFileUtf8 :: String -> IO String
readFileUtf8 String
filepath =
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile String
filepath IOMode
ReadMode forall a b. (a -> b) -> a -> b
$ \Handle
h -> do
Handle -> TextEncoding -> IO ()
hSetEncoding Handle
h TextEncoding
utf8
String
contents <- Handle -> IO String
hGetContents Handle
h
String
contents forall a b. NFData a => a -> b -> b
`deepseq` Handle -> IO ()
hClose Handle
h
forall (m :: * -> *) a. Monad m => a -> m a
return String
contents
writeFileUtf8 :: FilePath -> String -> IO ()
writeFileUtf8 :: String -> String -> IO ()
writeFileUtf8 String
filepath String
str = do
Bool -> String -> IO ()
createDirectoryIfMissing Bool
True (ShowS
takeDirectory String
filepath)
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile String
filepath IOMode
WriteMode forall a b. (a -> b) -> a -> b
$ \Handle
h -> do
Handle -> TextEncoding -> IO ()
hSetEncoding Handle
h TextEncoding
utf8
Handle -> String -> IO ()
hPutStr Handle
h String
str