{-# 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)
newtype HazardSet = HazardSet (Map.HashMap FileName (ReadOrWrite, Seconds, Cmd))
deriving Show
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 :: [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
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
| otherwise = Right $ Just (Read, t2, cmd2)
mergeFileOps r x (Write, t1, cmd1) (Write, t2, cmd2) = Left $ WriteWriteHazard x cmd1 cmd2 $
if elem cmd1 r && elem cmd2 r then NonRecoverable
else Restartable
mergeFileOps r x (Read, tR, cmdR) (Write, tW, cmdW)
| tW < tR =
if elem cmdR r && notElem cmdW r then hazard Restartable
else Right $ Just (Write, tW, cmdW)
| otherwise =
if notElem cmdR r then hazard Recoverable
else if notElem cmdW r then hazard Restartable
else if elemIndex cmdR r < elemIndex cmdW r then hazard Restartable
else hazard NonRecoverable
where
hazard = Left . ReadWriteHazard x cmdW cmdR
mergeFileOps r x v1 v2 = mergeFileOps r x v2 v1