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

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

-- Very simple Hash number generators

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)

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


-- | 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 =
  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  -- see #17073
    String
contents <- Handle -> IO String
hGetContents Handle
h
    String
contents forall a b. NFData a => a -> b -> b
`deepseq` Handle -> IO ()
hClose Handle
h -- prevent lazy IO
    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)
  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  -- see #17073
    Handle -> String -> IO ()
hPutStr Handle
h String
str