#if __GLASGOW_HASKELL__ >= 709
#elif __GLASGOW_HASKELL__ >= 701
#endif
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
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
data Mix = Mix
FilePath
UTCTime
Hash
Int
[MixEntry]
deriving (Show,Read,Eq)
type MixEntry = (HpcPos, BoxLabel)
data BoxLabel = ExpBox Bool
| TopLevelBox [String]
| LocalBox [String]
| BinBox CondBox Bool
deriving (Read, Show, Eq, Ord)
data CondBox = GuardBinBox
| CondBinBox
| QualBinBox
deriving (Read, Show, Eq, Ord)
instance HpcHash BoxLabel where
toHash (ExpBox b) = 0x100 + toHash b
toHash (TopLevelBox nm) = 0x200 + toHash nm
toHash (LocalBox nm) = 0x300 + toHash nm
toHash (BinBox cond b) = 0x400 + toHash (cond,b)
instance HpcHash CondBox where
toHash GuardBinBox = 0x10
toHash CondBinBox = 0x20
toHash QualBinBox = 0x30
mixCreate :: String
-> String
-> Mix
-> IO ()
mixCreate dirName modName mix =
writeFile (mixName dirName modName) (show mix)
readMix :: [String]
-> Either String TixModule
-> IO Mix
readMix dirNames mod' = do
let modName = either id tixModuleName mod'
res <- sequence [ (do let mixPath = mixName dirName modName
parseError = error ("can not parse " ++ mixPath)
parse = fromMaybe parseError . readMaybe
mix <- parse `fmap` readFile mixPath
case mod' of
Left _ -> return $ Just mix
Right tix -> return $ checkHash tix mix mixPath)
`catchIO` (\ _ -> return $ Nothing)
| dirName <- dirNames
]
case catMaybes res of
xs@(x:_:_) | any (/= x) (tail xs) ->
error $ "found " ++ show(length xs) ++ " different instances of "
++ modName ++ " in " ++ intercalate ", " dirNames
(x:_) -> return x
_ -> error $ "can not find "
++ modName ++ " in " ++ intercalate ", " dirNames
mixName :: FilePath -> String -> String
mixName dirName name = dirName </> name <.> "mix"
checkHash :: TixModule -> Mix -> FilePath -> Maybe Mix
checkHash tix mix@(Mix _ _ mixHash _ _) mixPath
| modHash == mixHash = Just mix
| otherwise = error $
"hash in tix file for module " ++ modName ++ " (" ++ show modHash ++ ")\n"
++ "does not match hash in " ++ mixPath ++ " (" ++ show mixHash ++ ")"
where
modName = tixModuleName tix
modHash = tixModuleHash tix
type MixEntryDom a = Tree (HpcPos,a)
isGoodNode :: MixEntryDom a -> Bool
isGoodNode (Node (pos,_) sub_nodes) =
and [ pos' `insideHpcPos` pos | Node(pos',_) _ <- sub_nodes ]
&& and [ pos' /= pos | Node(pos',_) _ <- sub_nodes ]
&& isGoodForest sub_nodes
isGoodForest :: [MixEntryDom a] -> Bool
isGoodForest sub_nodes =
all isGoodNode sub_nodes
&& and [ not (pos1 `insideHpcPos` pos2 ||
pos2 `insideHpcPos` pos1)
| (Node (pos1,_) _,n1) <- zip sub_nodes [0..]
, (Node (pos2,_) _,n2) <- zip sub_nodes [0..]
, (n1 :: Int) /= n2 ]
addNodeToTree :: (Show a) => (HpcPos,a) -> MixEntryDom [a] -> MixEntryDom [a]
addNodeToTree (new_pos,new_a) (Node (pos,a) children)
| pos == new_pos = Node (pos,new_a : a) children
| new_pos `insideHpcPos` pos =
Node (pos,a) (addNodeToList (new_pos,new_a) children)
| pos `insideHpcPos` new_pos =
error "precondition not met inside addNodeToNode"
| otherwise = error "something impossible happened in addNodeToTree"
addNodeToList :: Show a => (HpcPos,a) -> [MixEntryDom [a]] -> [MixEntryDom [a]]
addNodeToList (new_pos,new_a) entries
| otherwise =
if length [ ()
| (am_inside,am_outside,_) <- entries'
, am_inside || am_outside
] == 0
then Node (new_pos,[new_a]) [] : entries else
if length [ ()
| (am_inside,_,_) <- entries'
, am_inside
] > 0
then [ if i_am_inside
then addNodeToTree (new_pos,new_a) node
else node
| (i_am_inside,_,node) <- entries'
] else
( Node (new_pos,[new_a])
[ node | (_,True,node) <- entries' ] :
[ node | (_,False,node) <- entries' ]
)
where
entries' = [ ( new_pos `insideHpcPos` pos
, pos `insideHpcPos` new_pos
, node)
| node@(Node (pos,_) _) <- entries
]
createMixEntryDom :: (Show a) => [(HpcPos,a)] -> [MixEntryDom [a]]
createMixEntryDom entries
| isGoodForest forest = forest
| otherwise = error "createMixEntryDom: bad forest"
where forest = foldr addNodeToList [] entries