{-# 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 -> [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

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

-- 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 [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


-- | 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 :: [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  -- see #17073
    contents <- Handle -> IO [Char]
hGetContents Handle
h
    contents `deepseq` hClose h -- prevent lazy IO
    return contents

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