Untitled diff
Created Diff never expires
12 removals
| Lines | |
|---|---|
| Total | |
| Removed | |
| Characters | |
| Total | |
| Removed | |
49 additions
| Lines | |
|---|---|
| Total | |
| Added | |
| Characters | |
| Total | |
| Added | |
import Control.Concurrent
import Control.Concurrent.STM
import Control.Concurrent.STM
import Control.Concurrent.STM.TVar
import Control.Concurrent.STM.TVar
import Control.Monad
import System.Directory
import System.Directory
import System.Environment (getArgs)
import System.Environment (getArgs)
import System.Exit
import System.INotify
import System.INotify
import System.IO
import System.IO
import System.Process
data Config =
data Config =
Config
Config
{ confCabalFile :: FilePath
{ confOutputFile :: FilePath
, confCabalFile :: FilePath
, confWorking :: Bool
, confWorking :: Bool
} deriving (Show,Read)
} deriving (Show,Read)
main = do
main = do
args <- getArgs
args <- getArgs
let dir = head args
let dir = head args
let cabalOutput = args !! 1
putStrLn $ "Watching directory: " ++ dir
putStrLn $ "Watching directory: " ++ dir
putStrLn $ "Cabal output file: " ++ cabalOutput
contents <- getDirectoryContents dir
contents <- getDirectoryContents dir
let contents' = filter filterCabal contents
let contents' = filter filterCabal contents
case contents' of
case contents' of
(x:_) -> runThread x dir
(x:_) -> do
let config = Config cabalOutput x False
runThread config dir
[] -> do
[] -> do
putStrLn "No cabal file found!"
putStrLn "No cabal file found!"
putStrLn "Exiting"
putStrLn "Exiting"
runThread cabal dir = do
runThread config dir = do
config <- newTVarIO $ Config cabal False
config <- newTVarIO config
n <- initINotify
n <- initINotify
putStrLn "Press <Enter> to exit"
putStrLn "Press <Enter> to exit"
print n
print n
wd <- addWatch n
wd <- addWatch n
[ Modify, CloseWrite, Create, Delete, MoveIn, MoveOut ]
[ Modify, CloseWrite, Create, Delete, MoveIn, MoveOut ]
dir
dir
(eventHandler config)
(eventHandler config)
print wd
print wd
getLine
getLine
removeWatch wd
removeWatch wd
killINotify n
killINotify n
eventHandler :: TVar Config -> Event -> IO ()
eventHandler :: TVar Config -> Event -> IO ()
eventHandler conf x@(Modified _ (Just fp)) = handleFilteredFile conf x fp
eventHandler conf x@(Modified _ (Just fp)) = handleFilteredFile conf x fp
eventHandler conf x@(MovedIn _ fp _) = handleFilteredFile conf x fp
eventHandler conf x@(MovedIn _ fp _) = handleFilteredFile conf x fp
eventHandler conf x@(MovedOut _ fp _) = handleFilteredFile conf x fp
eventHandler conf x@(MovedOut _ fp _) = handleFilteredFile conf x fp
eventHandler conf x@(Created _ fp) = handleFilteredFile conf x fp
eventHandler conf x@(Created _ fp) = handleFilteredFile conf x fp
eventHandler conf x@(Deleted _ fp) = handleFilteredFile conf x fp
eventHandler conf x@(Deleted _ fp) = handleFilteredFile conf x fp
eventHandler _ _ = return ()
eventHandler _ _ = return ()
handleFilteredFile conf evt fp = do
handleFilteredFile conf evt fp =
if filterHS fp
when (filterHS fp) $ print evt >> doWork conf
then print evt >> doWork conf fp
else return ()
filterHS fp = fileExt fp == "hs"
filterHS fp = fileExt fp == "hs"
filterCabal fp = fileExt fp == "cabal"
filterCabal fp = fileExt fp == "cabal"
fileExt = reverse
fileExt = reverse
. takeWhile (/= '.')
. takeWhile (/= '.')
. reverse
. reverse
doWork :: TVar Config -> FilePath -> IO ()
doWork :: TVar Config -> IO ()
doWork conf fp = do
doWork conf = do
config <- readTVarIO conf
config <- readTVarIO conf
if confWorking config
if confWorking config
then do
then do
print "Already working!"
print "Already working!"
return ()
return ()
else do
else do
print "New work available!"
print "New work available!"
atomically $ writeTVar conf (config { confWorking = True })
atomically $ writeTVar conf (config { confWorking = True })
_ <- forkIO $ runCI conf
return ()
return ()
runCI :: TVar Config -> IO ()
runCI conf = do
runCIChain conf
config <- readTVarIO conf
atomically $ writeTVar conf (config { confWorking = False })
return ()
runCIChain :: TVar Config -> IO ()
runCIChain conf = do
cabalBuild <- runCabal conf ["build"]
print $ "*** cabal build result: " ++ show cabalBuild
case cabalBuild of
False -> return ()
True -> do
cabalTest <- runCabal conf ["test"]
print $ "*** cabal test result: " ++ show cabalTest
runCabal :: TVar Config -> [String] -> IO Bool
runCabal conf args = do
(code, out, err) <- readProcessWithExitCode "cabal" args ""
config <- readTVarIO conf
let outputFile = confOutputFile config
_ <- when (out /= []) $ appendFile outputFile out
_ <- when (err /= []) $ appendFile outputFile err
case code of
ExitSuccess -> return True
ExitFailure _ -> return False