{-# LANGUAGE CPP #-}
#if __GLASGOW_HASKELL__ >= 704
{-# LANGUAGE Safe #-}
#elif __GLASGOW_HASKELL__ >= 702
{-# LANGUAGE Trustworthy #-}
#endif
module Trace.Hpc.Util
( HpcPos
, fromHpcPos
, toHpcPos
, insideHpcPos
, HpcHash(..)
, Hash
, catchIO
, readFileUtf8
, writeFileUtf8
) where
import Control.DeepSeq (deepseq)
import qualified Control.Exception as Exception
import Data.List(foldl')
import Data.Char (ord)
import Data.Bits (xor)
import Data.Word
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 -> String
show (P Int
l1 Int
c1 Int
l2 Int
c2) = Int -> String
forall a. Show a => a -> String
show Int
l1 String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char
':' 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
'-' 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
':' 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 Int
_i 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
(String
before,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
/= Char
',') String
pos
parseError :: a -> a
parseError a
a = String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
"Read HpcPos: Could not parse: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
a
(String
lhs0,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
/= Char
'-') String
before of
(String
lhs,Char
'-':String
rhs) -> (String
lhs,String
rhs)
(String
lhs,String
"") -> (String
lhs,String
lhs)
(String, String)
_ -> String -> (String, String)
forall {a} {a}. Show a => a -> a
parseError String
before
(String
l1,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
/= Char
':') String
lhs0 of
(String
l,Char
':':String
c) -> (String
l,String
c)
(String, String)
_ -> String -> (String, String)
forall {a} {a}. Show a => a -> a
parseError String
lhs0
(String
l2,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
/= Char
':') String
rhs0 of
(String
l,Char
':':String
c) -> (String
l,String
c)
(String, String)
_ -> 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
$c== :: Hash -> Hash -> Bool
== :: Hash -> Hash -> Bool
$c/= :: Hash -> Hash -> Bool
/= :: Hash -> Hash -> Bool
Eq)
instance Read Hash where
readsPrec :: Int -> ReadS Hash
readsPrec Int
p String
n = [ (Word32 -> Hash
Hash Word32
v,String
rest)
| (Word32
v,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 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 :: String -> IO String
readFileUtf8 String
filepath =
String -> IOMode -> (Handle -> IO String) -> IO String
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile String
filepath IOMode
ReadMode ((Handle -> IO String) -> IO String)
-> (Handle -> IO String) -> IO String
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 String -> IO () -> IO ()
forall a b. NFData a => a -> b -> b
`deepseq` Handle -> IO ()
hClose Handle
h
String -> IO String
forall a. a -> IO a
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)
String -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile String
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 -> String -> IO ()
hPutStr Handle
h String
str