{-# LANGUAGE CPP #-}
#if __GLASGOW_HASKELL__ >= 704
{-# LANGUAGE Safe #-}
#elif __GLASGOW_HASKELL__ >= 702
{-# LANGUAGE Trustworthy #-}
#endif
-----------------------------------------
-- Andy Gill and Colin Runciman, June 2006
------------------------------------------

-- | Minor utilities for the HPC tools.

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

-- | 'HpcPos' is an Hpc local rendition of a Span.
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' explodes the HpcPos into /line:column/-/line:column/
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' implodes to HpcPos, from /line:column/-/line:column/
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

-- | Predicate determining whether the first argument is inside the second argument.
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

------------------------------------------------------------------------------

-- Very simple Hash number generators

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


-- | Read a file strictly, as opposed to how `readFile` does it using lazy IO, but also
-- disregard system locale and assume that the file is encoded in UTF-8. Haskell source
-- files are expected to be encoded in UTF-8 by GHC.
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  -- see #17073
    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 -- prevent lazy IO
    String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return String
contents

-- | Write file in UTF-8 encoding. Parent directory will be created if missing.
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  -- see #17073
    Handle -> String -> IO ()
hPutStr Handle
h String
str