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

-- | Datatypes and file-access routines for the per-module (@.mix@)
-- indexes used by Hpc.
module Trace.Hpc.Mix
        ( Mix(..)
        , MixEntry
        , BoxLabel(..)
        , CondBox(..)
        , mixCreate
        , readMix
        , createMixEntryDom
        , MixEntryDom
        )
  where

import Data.List
import Data.Maybe (catMaybes, fromMaybe)
import Data.Time (UTCTime)
import Data.Tree
#if MIN_VERSION_base(4,6,0)
import Text.Read (readMaybe)
#else
import Data.Char (isSpace)
#endif

import System.FilePath

-- a module index records the attributes of each tick-box that has
-- been introduced in that module, accessed by tick-number position
-- in the list

import Trace.Hpc.Util (HpcPos, insideHpcPos, Hash, HpcHash(..), catchIO)
import Trace.Hpc.Tix

#if !MIN_VERSION_base(4,6,0)
readMaybe :: Read a => String -> Maybe a
readMaybe s = case reads s of
  [(x, s')] | all isSpace s' -> Just x
  _                          -> Nothing
#endif

-- | 'Mix' is the information about a modules static properties, like
-- location of Tix's in a file.
--
-- Tab stops are the size of a tab in the provided /line:column/ values.
--
--  * In GHC, this is 1 (a tab is just a character)
--  * With @hpc-tracer@, this is 8 (a tab represents several spaces).
data Mix = Mix
             FilePath           -- location of original file
             UTCTime            -- time of original file's last update
             Hash               -- hash of mix entry + timestamp
             Int                -- tab stop value.
             [MixEntry]         -- entries
        deriving (Int -> Mix -> ShowS
[Mix] -> ShowS
Mix -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Mix] -> ShowS
$cshowList :: [Mix] -> ShowS
show :: Mix -> String
$cshow :: Mix -> String
showsPrec :: Int -> Mix -> ShowS
$cshowsPrec :: Int -> Mix -> ShowS
Show,ReadPrec [Mix]
ReadPrec Mix
Int -> ReadS Mix
ReadS [Mix]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Mix]
$creadListPrec :: ReadPrec [Mix]
readPrec :: ReadPrec Mix
$creadPrec :: ReadPrec Mix
readList :: ReadS [Mix]
$creadList :: ReadS [Mix]
readsPrec :: Int -> ReadS Mix
$creadsPrec :: Int -> ReadS Mix
Read,Mix -> Mix -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Mix -> Mix -> Bool
$c/= :: Mix -> Mix -> Bool
== :: Mix -> Mix -> Bool
$c== :: Mix -> Mix -> Bool
Eq)

type MixEntry = (HpcPos, BoxLabel)

data BoxLabel = ExpBox  Bool -- isAlt
              | TopLevelBox [String]
              | LocalBox [String]
              | BinBox CondBox Bool
              deriving (ReadPrec [BoxLabel]
ReadPrec BoxLabel
Int -> ReadS BoxLabel
ReadS [BoxLabel]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [BoxLabel]
$creadListPrec :: ReadPrec [BoxLabel]
readPrec :: ReadPrec BoxLabel
$creadPrec :: ReadPrec BoxLabel
readList :: ReadS [BoxLabel]
$creadList :: ReadS [BoxLabel]
readsPrec :: Int -> ReadS BoxLabel
$creadsPrec :: Int -> ReadS BoxLabel
Read, Int -> BoxLabel -> ShowS
[BoxLabel] -> ShowS
BoxLabel -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BoxLabel] -> ShowS
$cshowList :: [BoxLabel] -> ShowS
show :: BoxLabel -> String
$cshow :: BoxLabel -> String
showsPrec :: Int -> BoxLabel -> ShowS
$cshowsPrec :: Int -> BoxLabel -> ShowS
Show, BoxLabel -> BoxLabel -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BoxLabel -> BoxLabel -> Bool
$c/= :: BoxLabel -> BoxLabel -> Bool
== :: BoxLabel -> BoxLabel -> Bool
$c== :: BoxLabel -> BoxLabel -> Bool
Eq, Eq BoxLabel
BoxLabel -> BoxLabel -> Bool
BoxLabel -> BoxLabel -> Ordering
BoxLabel -> BoxLabel -> BoxLabel
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 :: BoxLabel -> BoxLabel -> BoxLabel
$cmin :: BoxLabel -> BoxLabel -> BoxLabel
max :: BoxLabel -> BoxLabel -> BoxLabel
$cmax :: BoxLabel -> BoxLabel -> BoxLabel
>= :: BoxLabel -> BoxLabel -> Bool
$c>= :: BoxLabel -> BoxLabel -> Bool
> :: BoxLabel -> BoxLabel -> Bool
$c> :: BoxLabel -> BoxLabel -> Bool
<= :: BoxLabel -> BoxLabel -> Bool
$c<= :: BoxLabel -> BoxLabel -> Bool
< :: BoxLabel -> BoxLabel -> Bool
$c< :: BoxLabel -> BoxLabel -> Bool
compare :: BoxLabel -> BoxLabel -> Ordering
$ccompare :: BoxLabel -> BoxLabel -> Ordering
Ord)

data CondBox = GuardBinBox
             | CondBinBox
             | QualBinBox
              deriving (ReadPrec [CondBox]
ReadPrec CondBox
Int -> ReadS CondBox
ReadS [CondBox]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [CondBox]
$creadListPrec :: ReadPrec [CondBox]
readPrec :: ReadPrec CondBox
$creadPrec :: ReadPrec CondBox
readList :: ReadS [CondBox]
$creadList :: ReadS [CondBox]
readsPrec :: Int -> ReadS CondBox
$creadsPrec :: Int -> ReadS CondBox
Read, Int -> CondBox -> ShowS
[CondBox] -> ShowS
CondBox -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CondBox] -> ShowS
$cshowList :: [CondBox] -> ShowS
show :: CondBox -> String
$cshow :: CondBox -> String
showsPrec :: Int -> CondBox -> ShowS
$cshowsPrec :: Int -> CondBox -> ShowS
Show, CondBox -> CondBox -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CondBox -> CondBox -> Bool
$c/= :: CondBox -> CondBox -> Bool
== :: CondBox -> CondBox -> Bool
$c== :: CondBox -> CondBox -> Bool
Eq, Eq CondBox
CondBox -> CondBox -> Bool
CondBox -> CondBox -> Ordering
CondBox -> CondBox -> CondBox
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 :: CondBox -> CondBox -> CondBox
$cmin :: CondBox -> CondBox -> CondBox
max :: CondBox -> CondBox -> CondBox
$cmax :: CondBox -> CondBox -> CondBox
>= :: CondBox -> CondBox -> Bool
$c>= :: CondBox -> CondBox -> Bool
> :: CondBox -> CondBox -> Bool
$c> :: CondBox -> CondBox -> Bool
<= :: CondBox -> CondBox -> Bool
$c<= :: CondBox -> CondBox -> Bool
< :: CondBox -> CondBox -> Bool
$c< :: CondBox -> CondBox -> Bool
compare :: CondBox -> CondBox -> Ordering
$ccompare :: CondBox -> CondBox -> Ordering
Ord)

instance HpcHash BoxLabel where
   toHash :: BoxLabel -> Hash
toHash (ExpBox Bool
b)       = Hash
0x100 forall a. Num a => a -> a -> a
+ forall a. HpcHash a => a -> Hash
toHash Bool
b
   toHash (TopLevelBox [String]
nm) = Hash
0x200 forall a. Num a => a -> a -> a
+ forall a. HpcHash a => a -> Hash
toHash [String]
nm
   toHash (LocalBox [String]
nm)    = Hash
0x300 forall a. Num a => a -> a -> a
+ forall a. HpcHash a => a -> Hash
toHash [String]
nm
   toHash (BinBox CondBox
cond Bool
b)  = Hash
0x400 forall a. Num a => a -> a -> a
+ forall a. HpcHash a => a -> Hash
toHash (CondBox
cond,Bool
b)

instance HpcHash CondBox where
   toHash :: CondBox -> Hash
toHash CondBox
GuardBinBox = Hash
0x10
   toHash CondBox
CondBinBox  = Hash
0x20
   toHash CondBox
QualBinBox  = Hash
0x30


-- | Create is mix file.
mixCreate :: String -- ^ Dir Name
          -> String -- ^ module Name
          -> Mix    -- ^ Mix DataStructure
          -> IO ()
mixCreate :: String -> String -> Mix -> IO ()
mixCreate String
dirName String
modName Mix
mix =
   String -> String -> IO ()
writeFile (String -> ShowS
mixName String
dirName String
modName) (forall a. Show a => a -> String
show Mix
mix)

-- | Read a mix file.
readMix :: [String]                 -- ^ Dir Names
        -> Either String TixModule  -- ^ module wanted
        -> IO Mix
readMix :: [String] -> Either String TixModule -> IO Mix
readMix [String]
dirNames Either String TixModule
mod' = do
   let modName :: String
modName = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. a -> a
id TixModule -> String
tixModuleName Either String TixModule
mod'
   [Maybe Mix]
res <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [ (do let mixPath :: String
mixPath    = String -> ShowS
mixName String
dirName String
modName
                             parseError :: a
parseError = forall a. HasCallStack => String -> a
error (String
"can not parse " forall a. [a] -> [a] -> [a]
++ String
mixPath)
                             parse :: String -> Mix
parse      = forall a. a -> Maybe a -> a
fromMaybe forall {a}. a
parseError forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Read a => String -> Maybe a
readMaybe
                         Mix
mix <- String -> Mix
parse forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` String -> IO String
readFile String
mixPath
                         case Either String TixModule
mod' of
                            Left  String
_   -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Mix
mix -- Bypass hash check
                            Right TixModule
tix -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ TixModule -> Mix -> String -> Maybe Mix
checkHash TixModule
tix Mix
mix String
mixPath)
                     forall a. IO a -> (IOException -> IO a) -> IO a
`catchIO` (\ IOException
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Maybe a
Nothing)
                   | String
dirName <- [String]
dirNames
                   ]
   case forall a. [Maybe a] -> [a]
catMaybes [Maybe Mix]
res of
     xs :: [Mix]
xs@(Mix
x:Mix
_:[Mix]
_) | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. Eq a => a -> a -> Bool
/= Mix
x) (forall a. [a] -> [a]
tail [Mix]
xs) ->
              -- Only complain if multiple *different* `Mix` files with the
              -- same name are found (#9619).
              forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"found " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show(forall (t :: * -> *) a. Foldable t => t a -> Int
length [Mix]
xs) forall a. [a] -> [a] -> [a]
++ String
" different instances of "
                      forall a. [a] -> [a] -> [a]
++ String
modName forall a. [a] -> [a] -> [a]
++ String
" in " forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate String
", " [String]
dirNames
     (Mix
x:[Mix]
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return Mix
x
     [Mix]
_     -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"can not find "
                      forall a. [a] -> [a] -> [a]
++ String
modName forall a. [a] -> [a] -> [a]
++ String
" in " forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate String
", " [String]
dirNames

mixName :: FilePath -> String -> String
mixName :: String -> ShowS
mixName String
dirName String
name = String
dirName String -> ShowS
</> String
name String -> ShowS
<.> String
"mix"

-- | Check that hash in .tix and .mix file match.
checkHash :: TixModule -> Mix -> FilePath -> Maybe Mix
checkHash :: TixModule -> Mix -> String -> Maybe Mix
checkHash TixModule
tix mix :: Mix
mix@(Mix String
_ UTCTime
_ Hash
mixHash Int
_ [MixEntry]
_) String
mixPath
  | Hash
modHash forall a. Eq a => a -> a -> Bool
== Hash
mixHash = forall a. a -> Maybe a
Just Mix
mix
  | Bool
otherwise = forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$
      String
"hash in tix file for module " forall a. [a] -> [a] -> [a]
++ String
modName forall a. [a] -> [a] -> [a]
++ String
" (" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Hash
modHash forall a. [a] -> [a] -> [a]
++ String
")\n"
      forall a. [a] -> [a] -> [a]
++ String
"does not match hash in " forall a. [a] -> [a] -> [a]
++ String
mixPath forall a. [a] -> [a] -> [a]
++ String
" (" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Hash
mixHash forall a. [a] -> [a] -> [a]
++ String
")"
  where
    modName :: String
modName = TixModule -> String
tixModuleName TixModule
tix
    modHash :: Hash
modHash = TixModule -> Hash
tixModuleHash TixModule
tix

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

type MixEntryDom a = Tree (HpcPos,a)

-- A good tree has all its children fully inside its parents HpcPos.
-- No child should have the *same* HpcPos.
-- There is no ordering to the children

isGoodNode :: MixEntryDom a -> Bool
isGoodNode :: forall a. MixEntryDom a -> Bool
isGoodNode (Node (HpcPos
pos,a
_) [Tree (HpcPos, a)]
sub_nodes) =
      forall (t :: * -> *). Foldable t => t Bool -> Bool
and [ HpcPos
pos' HpcPos -> HpcPos -> Bool
`insideHpcPos` HpcPos
pos  | Node(HpcPos
pos',a
_)  [Tree (HpcPos, a)]
_ <- [Tree (HpcPos, a)]
sub_nodes ]
   Bool -> Bool -> Bool
&& forall (t :: * -> *). Foldable t => t Bool -> Bool
and [ HpcPos
pos' forall a. Eq a => a -> a -> Bool
/= HpcPos
pos | Node(HpcPos
pos',a
_) [Tree (HpcPos, a)]
_ <- [Tree (HpcPos, a)]
sub_nodes ]
   Bool -> Bool -> Bool
&& forall a. [MixEntryDom a] -> Bool
isGoodForest [Tree (HpcPos, a)]
sub_nodes

-- all sub-trees are good trees, and no two HpcPos are inside each other.
isGoodForest :: [MixEntryDom a] -> Bool
isGoodForest :: forall a. [MixEntryDom a] -> Bool
isGoodForest [MixEntryDom a]
sub_nodes =
   forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all forall a. MixEntryDom a -> Bool
isGoodNode [MixEntryDom a]
sub_nodes
   Bool -> Bool -> Bool
&& forall (t :: * -> *). Foldable t => t Bool -> Bool
and [  Bool -> Bool
not (HpcPos
pos1 HpcPos -> HpcPos -> Bool
`insideHpcPos` HpcPos
pos2 Bool -> Bool -> Bool
||
                  HpcPos
pos2 HpcPos -> HpcPos -> Bool
`insideHpcPos` HpcPos
pos1)
          | (Node (HpcPos
pos1,a
_) [MixEntryDom a]
_,Int
n1) <- forall a b. [a] -> [b] -> [(a, b)]
zip [MixEntryDom a]
sub_nodes [Int
0..]
          , (Node (HpcPos
pos2,a
_) [MixEntryDom a]
_,Int
n2) <- forall a b. [a] -> [b] -> [(a, b)]
zip [MixEntryDom a]
sub_nodes [Int
0..]
          , (Int
n1 :: Int) forall a. Eq a => a -> a -> Bool
/= Int
n2 ]

addNodeToTree :: (Show a) => (HpcPos,a) -> MixEntryDom [a] -> MixEntryDom [a]
addNodeToTree :: forall a.
Show a =>
(HpcPos, a) -> MixEntryDom [a] -> MixEntryDom [a]
addNodeToTree (HpcPos
new_pos,a
new_a) (Node (HpcPos
pos,[a]
a) [Tree (HpcPos, [a])]
children)
  | HpcPos
pos forall a. Eq a => a -> a -> Bool
== HpcPos
new_pos = forall a. a -> [Tree a] -> Tree a
Node (HpcPos
pos,a
new_a forall a. a -> [a] -> [a]
: [a]
a) [Tree (HpcPos, [a])]
children
  | HpcPos
new_pos HpcPos -> HpcPos -> Bool
`insideHpcPos` HpcPos
pos =
       forall a. a -> [Tree a] -> Tree a
Node (HpcPos
pos,[a]
a) (forall a.
Show a =>
(HpcPos, a) -> [MixEntryDom [a]] -> [MixEntryDom [a]]
addNodeToList (HpcPos
new_pos,a
new_a) [Tree (HpcPos, [a])]
children)
  | HpcPos
pos HpcPos -> HpcPos -> Bool
`insideHpcPos` HpcPos
new_pos =
       forall a. HasCallStack => String -> a
error String
"precondition not met inside addNodeToNode"
  | Bool
otherwise = forall a. HasCallStack => String -> a
error String
"something impossible happened in addNodeToTree"

addNodeToList :: Show a => (HpcPos,a) -> [MixEntryDom [a]] -> [MixEntryDom [a]]
addNodeToList :: forall a.
Show a =>
(HpcPos, a) -> [MixEntryDom [a]] -> [MixEntryDom [a]]
addNodeToList (HpcPos
new_pos,a
new_a) [MixEntryDom [a]]
entries
  | Bool
otherwise =
  if forall (t :: * -> *) a. Foldable t => t a -> Int
length [ ()
          | (Bool
am_inside,Bool
am_outside,MixEntryDom [a]
_) <- [(Bool, Bool, MixEntryDom [a])]
entries'
          , Bool
am_inside Bool -> Bool -> Bool
|| Bool
am_outside
          ] forall a. Eq a => a -> a -> Bool
== Int
0
     -- The case where we have a new HpcPos range
     then forall a. a -> [Tree a] -> Tree a
Node (HpcPos
new_pos,[a
new_a]) [] forall a. a -> [a] -> [a]
: [MixEntryDom [a]]
entries else
  if forall (t :: * -> *) a. Foldable t => t a -> Int
length [ ()
            | (Bool
am_inside,Bool
_,MixEntryDom [a]
_) <- [(Bool, Bool, MixEntryDom [a])]
entries'
            , Bool
am_inside
            ] forall a. Ord a => a -> a -> Bool
> Int
0
     -- The case where we are recursing into a tree
     -- Note we can recurse down many branches, in the case of
     -- overlapping ranges.
     -- Assumes we have captures the new HpcPos
     -- (or the above conditional would be true)
     then [ if Bool
i_am_inside  -- or the same as
            then forall a.
Show a =>
(HpcPos, a) -> MixEntryDom [a] -> MixEntryDom [a]
addNodeToTree (HpcPos
new_pos,a
new_a) MixEntryDom [a]
node
            else MixEntryDom [a]
node
          | (Bool
i_am_inside,Bool
_,MixEntryDom [a]
node) <- [(Bool, Bool, MixEntryDom [a])]
entries'
          ] else
     -- The case of a super-range.
     ( forall a. a -> [Tree a] -> Tree a
Node (HpcPos
new_pos,[a
new_a])
             [ MixEntryDom [a]
node | (Bool
_,Bool
True,MixEntryDom [a]
node) <- [(Bool, Bool, MixEntryDom [a])]
entries' ] forall a. a -> [a] -> [a]
:
       [ MixEntryDom [a]
node | (Bool
_,Bool
False,MixEntryDom [a]
node) <- [(Bool, Bool, MixEntryDom [a])]
entries' ]
     )
  where
    entries' :: [(Bool, Bool, MixEntryDom [a])]
entries' = [ ( HpcPos
new_pos HpcPos -> HpcPos -> Bool
`insideHpcPos` HpcPos
pos
                 , HpcPos
pos  HpcPos -> HpcPos -> Bool
`insideHpcPos` HpcPos
new_pos
                 , MixEntryDom [a]
node)
               | node :: MixEntryDom [a]
node@(Node (HpcPos
pos,[a]
_) [MixEntryDom [a]]
_) <- [MixEntryDom [a]]
entries
               ]

createMixEntryDom :: (Show a) => [(HpcPos,a)] -> [MixEntryDom [a]]
createMixEntryDom :: forall a. Show a => [(HpcPos, a)] -> [MixEntryDom [a]]
createMixEntryDom [(HpcPos, a)]
entries
    | forall a. [MixEntryDom a] -> Bool
isGoodForest [MixEntryDom [a]]
forest = [MixEntryDom [a]]
forest
    | Bool
otherwise = forall a. HasCallStack => String -> a
error String
"createMixEntryDom: bad forest"
  where forest :: [MixEntryDom [a]]
forest = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall a.
Show a =>
(HpcPos, a) -> [MixEntryDom [a]] -> [MixEntryDom [a]]
addNodeToList [] [(HpcPos, a)]
entries