content: {-# LANGUAGE TupleSections #-}
  {-# LANGUAGE RecordWildCards #-}
  
  module Development.Rattle.Hazards(
      Hazard(..), Recoverable(..),
      HazardSet, mergeHazardSet, newHazardSet, emptyHazardSet, seenHazardSet, addHazardSet,
      recoverableHazard, restartableHazard,
      ) where
  
  import Development.Rattle.Types
  import Control.Exception.Extra
  import System.Time.Extra
  import General.Extra
  import Data.List
  import Data.Tuple.Extra
  import qualified Data.HashMap.Strict as Map
  import General.FileName
  
  data ReadOrWrite = Read | Write deriving (Show,Eq)
  
  -- For Write, Seconds is the last possible time at which it was written
  -- For Read, Seconds is the earliest possible time at which it was read
  -- In both cases, Cmd is the thing that caused the read/write
  newtype HazardSet = HazardSet (Map.HashMap FileName (ReadOrWrite, Seconds, Cmd))
      deriving Show
  
  
  -- | Type of exception thrown if there is a hazard when running the build system.
  data Hazard
      = ReadWriteHazard FileName Cmd Cmd Recoverable
      | WriteWriteHazard FileName Cmd Cmd Recoverable
        deriving Show
  instance Exception Hazard
  
  data Recoverable = Recoverable | NonRecoverable | Restartable deriving (Show,Eq)
  
  recoverableHazard :: Hazard -> Bool
  recoverableHazard WriteWriteHazard{} = False
  recoverableHazard (ReadWriteHazard _ _ _ r) = r == Recoverable
  
  restartableHazard :: Hazard -> Bool
  restartableHazard (WriteWriteHazard _ _ _ r) = r == Restartable
  restartableHazard (ReadWriteHazard _ _ _ r) = r == Restartable
  
  emptyHazardSet :: HazardSet
  emptyHazardSet = HazardSet Map.empty
  
  seenHazardSet :: FileName -> HazardSet -> Bool
  seenHazardSet x (HazardSet mp) = x `Map.member` mp
  
  newHazardSet :: Seconds -> Seconds -> Cmd -> Touch FileName -> HazardSet
  newHazardSet start stop cmd Touch{..} = HazardSet $ Map.fromList $
      map (,(Write,stop ,cmd)) tWrite ++
      map (,(Read ,start,cmd)) tRead
  
  mergeHazardSet :: [Cmd] -> HazardSet -> HazardSet -> ([Hazard], HazardSet)
  mergeHazardSet required (HazardSet h1) (HazardSet h2) =
      second HazardSet $ unionWithKeyEithers (mergeFileOps required) h1 h2
  
  -- | addHazardSet a b c d e f == mergeHazardSet a b (newHazardSet c d e f)
  addHazardSet :: [Cmd] -> HazardSet -> Seconds -> Seconds -> Cmd -> Touch FileName -> ([Hazard], HazardSet)
  addHazardSet required (HazardSet h1) start stop cmd Touch{..} =
      second HazardSet $ insertWithKeyEithers (mergeFileOps required) h1 $
      map (,(Write,stop,cmd)) tWrite ++ map (,(Read,start,cmd)) tRead
  
  
  -- Very carefully written to include the commands
  {- HLINT ignore mergeFileOps "Redundant if" -}
  {- HLINT ignore mergeFileOps "Use infix" -}
  
  -- r is required list; s is speculate list
  mergeFileOps :: [Cmd] -> FileName -> (ReadOrWrite, Seconds, Cmd) -> (ReadOrWrite, Seconds, Cmd) -> Either Hazard (Maybe (ReadOrWrite, Seconds, Cmd))
  mergeFileOps r x (Read, t1, cmd1) (Read, t2, cmd2)
      | t1 <= t2 = Right Nothing -- don't update the Map (an optimisation for the common case)
      | otherwise = Right $ Just (Read, t2, cmd2)
  mergeFileOps r x (Write, t1, cmd1) (Write, t2, cmd2) = Left $ WriteWriteHazard x cmd1 cmd2 $
      -- if they both were required, we've got a problem
      if elem cmd1 r && elem cmd2 r then NonRecoverable
      -- if one (or both) were speculated, we might be able to restart and get over it
      else Restartable
  
  mergeFileOps r x (Read, tR, cmdR) (Write, tW, cmdW)
      | tW < tR = -- write happened first
          -- if the write hasn't been demanded but the read has we've
          -- managed to read something that was speculated, which is bad
          if elem cmdR r && notElem cmdW r then hazard Restartable
          -- otherwise, everything is good
          else Right $ Just (Write, tW, cmdW)
  
      | otherwise = -- read happened first
          -- if the read was speculated, we can ignore it
          if notElem cmdR r then hazard Recoverable
          -- if the write was speculated, we can restart and hopefully it won't recur
          else if notElem cmdW r then hazard Restartable
          -- neither was speculated, but did we use speculation to reorder them?
          -- note the order seems backwards, because r is a snoc-list
          -- FIXME: We might have had them race because of parallelism, so this is optimistically restartable
          else if elemIndex cmdR r < elemIndex cmdW r then hazard Restartable
          -- the user wrote the read before the write
          else hazard NonRecoverable
      where
          hazard = Left . ReadWriteHazard x cmdW cmdR
  mergeFileOps r x v1 v2 = mergeFileOps r x v2 v1 -- must be Write/Read, so match the other way around
  