{-# LANGUAGE DeriveGeneric, StandaloneDeriving #-}
-----------------------------------------
-- 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 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

-- | '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)

-- | @since 0.6.2.0
deriving instance (Generic Hash)
-- | @since 0.6.2.0
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) <- 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