{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, RecordWildCards, TupleSections #-} module Development.Rattle( rattle, cmd, parallel, liftIO ) where import Control.Monad.Trans.Reader import Control.Monad.IO.Class import Control.Monad.Extra import System.IO.Error import System.IO.Extra import Control.Exception.Extra import qualified Development.Shake.Command as C import qualified Data.HashMap.Strict as Map import Data.IORef import System.Directory import Data.List.Extra import Data.Maybe import Data.Time import Data.Tuple.Extra newtype Run a = Run {unRun :: ReaderT (IORef S) IO a} deriving (Functor, Applicative, Monad, MonadIO) newtype T = T Int -- timestamps deriving (Enum,Eq,Ord,Show) data S = S {timestamp :: T -- the timestamp I am on -- ,running :: [Args] -- things that are running now ,finished :: [(T, T, Cmd)] -- people who have finished ,history :: [Cmd] -- what I ran last time around } deriving Show getTimestamp :: Run T getTimestamp = do ref <- Run ask liftIO $ atomicModifyIORef' ref $ \s -> (s{timestamp = succ $ timestamp s}, timestamp s) getHistory :: Run [Cmd] getHistory = do ref <- Run ask liftIO $ history <$> readIORef ref addExecuted :: (T, T, Cmd) -> Run () addExecuted x = do ref <- Run ask liftIO $ atomicModifyIORef' ref $ \s -> (s{finished = x : finished s}, ()) parallel :: [Run a] -> Run [a] parallel = sequence type Args = [String] cmd :: Args -> Run () cmd args = do start <- getTimestamp history <- getHistory skip <- liftIO $ flip firstJustM history $ \cmd@Cmd{..} -> do let conds = (return $ args == cmdArgs) : [(== time) <$> getModTime file | (file,time) <- cmdRead ++ cmdWrite] ifM (andM conds) (return $ Just cmd) (return Nothing) cmd <- case skip of Just cmd -> return cmd Nothing -> do liftIO $ putStrLn $ unwords $ "#" : args xs :: [C.FSATrace] <- liftIO $ C.cmd args let (reads, writes) = both (nubOrd . concat) $ unzip $ map fsaRW xs let f xs = liftIO $ forM xs $ \x -> (x,) <$> getModTime x -- explicitly add back in the program beacuse of https://github.com/jacereda/fsatrace/issues/19 prog <- liftIO $ case args of prog:_ -> findExecutable prog _ -> return Nothing reads <- f $ maybeToList prog ++ reads writes <- f writes return $ Cmd args reads writes stop <- getTimestamp addExecuted (start, stop, cmd) getModTime :: FilePath -> IO (Maybe UTCTime) getModTime x = handleBool isDoesNotExistError (const $ return Nothing) (Just <$> getModificationTime x) fsaRW :: C.FSATrace -> ([FilePath], [FilePath]) fsaRW (C.FSAWrite x) = ([], [x]) fsaRW (C.FSARead x) = ([x], []) fsaRW (C.FSADelete x) = ([], [x]) fsaRW (C.FSAMove x y) = ([], [x,y]) fsaRW (C.FSAQuery x) = ([x], []) fsaRW (C.FSATouch x) = ([], [x]) data Cmd = Cmd {cmdArgs :: Args ,cmdRead :: [(FilePath, Maybe UTCTime)] ,cmdWrite :: [(FilePath, Maybe UTCTime)] } deriving (Show, Read) -- | Given an Action to run, and a list of previous commands that got run, run it again rattle :: Run a -> IO a rattle act = do history <- ifM (doesFileExist ".rattle") (map read . lines <$> readFile' ".rattle") (return []) ref <- newIORef $ S (T 0) [] history res <- flip runReaderT ref $ unRun act cmds <- finished <$> readIORef ref checkHazards cmds writeFile ".rattle" $ unlines $ reverse $ map (show . thd3) cmds return res -- | You get a write/write hazard if two separate commands write to the same file. -- You get a read/write hazard if there was a read of a file before a write. checkHazards :: [(T, T, Cmd)] -> IO () checkHazards xs = do let writeWrite = Map.filter (\args -> length args > 1) $ Map.fromListWith (++) [(fst x, [cmdArgs]) | (_,_,Cmd{..}) <- xs, x <- cmdWrite] unless (Map.null writeWrite) $ fail $ "Write/write: " ++ show writeWrite let lastWrite = Map.fromList [(fst x, (end, cmdArgs)) | (_,end,Cmd{..}) <- xs, x <- cmdWrite] let readWrite = [x | (start,_,Cmd{..}) <- xs, x <- cmdRead, Just (t, args) <- [Map.lookup (fst x) lastWrite], t >= start, args /= cmdArgs] unless (null readWrite) $ fail $ "Read/write: " ++ show readWrite