Untitled diff

Created Diff never expires
41 removals
120 lines
25 additions
104 lines
import Control.Concurrent
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 Control.Monad
import System.Directory
import System.Directory
import System.Environment (getArgs)
import System.Environment (getArgs)
import System.Exit
import System.Exit
import System.INotify
import System.INotify
import System.IO
import System.IO
import System.Process
import System.Process
data Config =
data Config =
Config
Config
{ confOutputFile :: FilePath
{ confExecFile :: 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
let execFile = args !! 1
putStrLn $ "Watching directory: " ++ dir
putStrLn $ "Watching directory: " ++ dir
putStrLn $ "Cabal output file: " ++ cabalOutput
putStrLn $ "Exec file: " ++ execFile
contents <- getDirectoryContents dir
fileExists <- doesFileExist execFile
let contents' = filter filterCabal contents
if fileExists
case contents' of
then do
(x:_) -> do
let config = Config execFile False
let config = Config cabalOutput x False
runThread config dir
runThread config dir
[] -> do
else do
putStrLn "No cabal file found!"
putStrLn $ "Exec file does not exist!"
putStrLn "Exiting"
putStrLn "Exiting"
runThread config dir = do
runThread config dir = do
config <- newTVarIO config
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 =
handleFilteredFile conf evt fp =
when (filterHS fp) $ print evt >> doWork conf
when (filterHS fp) $ print evt >> doWork conf
filterHS fp = fileExt fp == "hs"
filterHS fp = fileExt fp == "hs"
filterCabal fp = fileExt fp == "cabal"
fileExt = reverse
fileExt = reverse
. takeWhile (/= '.')
. takeWhile (/= '.')
. reverse
. reverse
doWork :: TVar Config -> IO ()
doWork :: TVar Config -> IO ()
doWork conf = 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
_ <- forkIO $ runCI conf
return ()
return ()
runCI :: TVar Config -> IO ()
runCI :: TVar Config -> IO ()
runCI conf = do
runCI conf = do
runCIChain conf
config <- readTVarIO conf
config <- readTVarIO conf
contents <- readFile $ confExecFile config
execContents $ lines contents
atomically $ writeTVar conf (config { confWorking = False })
atomically $ writeTVar conf (config { confWorking = False })
return ()
return ()
runCIChain :: TVar Config -> IO ()
execContents :: [String] -> IO Bool
runCIChain conf = do
execContents [] = return True
cabalBuild <- runCabal conf ["build"]
execContents (x:xs) = do
print $ "*** cabal build result: " ++ show cabalBuild
let p = shell x
case cabalBuild of
(_,_,_,h) <- createProcess p
False -> return ()
exitCode <- waitForProcess h
True -> do
case exitCode of
cabalTest <- runCabal conf ["test"]
ExitSuccess -> execContents xs
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
ExitFailure _ -> return False