{-# LANGUAGE CPP #-}
#ifdef __GLASGOW_HASKELL__
{-# LANGUAGE Safe #-}
#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
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)

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