Mix.hs

---------------------------------------------------------------
-- 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 (intercalate)
import Data.Maybe (catMaybes, fromMaybe)
import Data.Time (UTCTime)
import Data.Tree
import Text.Read (readMaybe)

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, readFileUtf8)
import Trace.Hpc.Tix

-- | '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 (Show,Read,Eq)

type MixEntry = (HpcPos, BoxLabel)

data BoxLabel = ExpBox  Bool -- isAlt
              | 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


-- | Write a mix file to disk.
-- 
-- The following command creates the mix file under the location "\/home\/user\/main\/Main.mix"
--
-- > mixCreate "/home/user/main" "Main" mix

mixCreate :: FilePath -- ^ Name of the target directory.
          -> String -- ^ Name of the module for which the mix file is created.
          -> Mix    -- ^ The Mix data structure.
          -> IO ()
mixCreate dirName modName mix =
   writeFile (mixName dirName modName) (show mix)

-- | Read a mix file.
readMix :: [FilePath]                 -- ^ Dir Names
        -> Either String TixModule  -- ^ module wanted
        -> 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` readFileUtf8 mixPath
                         case mod' of
                            Left  _   -> return $ Just mix -- Bypass hash check
                            Right tix -> return $ checkHash tix mix mixPath)
                     `catchIO` (\ _ -> return $ Nothing)
                   | dirName <- dirNames
                   ]
   case catMaybes res of
     xs@(x : tl@(_ : _)) | any (/= x) tl ->
              -- Only complain if multiple *different* `Mix` files with the
              -- same name are found (#9619).
              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"

-- | Check that hash in .tix and .mix file match.
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)

-- 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 (Node (pos,_) sub_nodes) =
      and [ pos' `insideHpcPos` pos  | Node(pos',_)  _ <- sub_nodes ]
   && and [ pos' /= pos | Node(pos',_) _ <- sub_nodes ]
   && isGoodForest sub_nodes

-- all sub-trees are good trees, and no two HpcPos are inside each other.
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
     -- The case where we have a new HpcPos range
     then Node (new_pos,[new_a]) [] : entries else
  if length [ ()
            | (am_inside,_,_) <- entries'
            , am_inside
            ] > 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 i_am_inside  -- or the same as
            then addNodeToTree (new_pos,new_a) node
            else node
          | (i_am_inside,_,node) <- entries'
          ] else
     -- The case of a super-range.
     ( 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