{-
  Colin Runciman and Andy Gill, June 2006
 -}

-- | Datatypes and file-access routines for the per-module (@.mix@)
-- indexes used by Hpc.
module Trace.Haptics.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 System.FilePath
import Text.Read (readMaybe)
-- 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.Haptics.Tix
import Trace.Haptics.Utils (Hash, HpcHash (..), HpcPos, catchIO, insideHpcPos)

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

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

-- | Read a mix file.
readMix
  :: [String] -- ^ 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` readFile 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 : _ : _)
      | any (/= x) (tail xs) ->
        -- 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
      then -- The case where we have a new HpcPos range
        Node (new_pos, [new_a]) [] : entries
      else
        if length
          [ ()
          | (am_inside, _, _) <- entries'
          , am_inside
          ]
          > 0
          then -- 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)

            [ 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
