diff --git a/arion.cabal b/arion.cabal --- a/arion.cabal +++ b/arion.cabal @@ -1,5 +1,5 @@ name: arion -version: 0.1.0.7 +version: 0.1.0.8 synopsis: Watcher and runner for Hspec description: Watcher and runner for Hspec license: MIT diff --git a/src/Arion/EventProcessor.hs b/src/Arion/EventProcessor.hs --- a/src/Arion/EventProcessor.hs +++ b/src/Arion/EventProcessor.hs @@ -1,31 +1,35 @@ {-# LANGUAGE OverloadedStrings #-} module Arion.EventProcessor ( - processEvent + processEvent, respondToEvent ) where -import Arion.Types -import System.FSNotify (Event(..)) -import Filesystem.Path.CurrentOS (encodeString) -import Data.List (isSuffixOf) -import qualified Data.Map as M -import Arion.Help +import Arion.Types +import Control.Applicative ((<$>)) +import Data.List (isSuffixOf) +import Data.List (nub) +import qualified Data.Map as M +import Data.Maybe (fromMaybe) +import Filesystem.Path (FilePath) +import Filesystem.Path.CurrentOS (encodeString) +import Prelude hiding (FilePath) +import System.FSNotify (Event (..)) -processEvent :: SourceTestMap -> String -> String -> Event -> [Command] -processEvent sourceToTestFileMap sourceFolder testFolder (Modified filePath _) = commands sourceToTestFileMap sourceFolder testFolder (encodeString filePath) -processEvent sourceToTestFileMap sourceFolder testFolder (Added filePath _) = commands sourceToTestFileMap sourceFolder testFolder (encodeString filePath) -processEvent _ _ _ _ = [] -commands :: SourceTestMap -> String -> String -> FilePath -> [Command] -commands sourceToTestFileMap sourceFolder testFolder filePath - | isSuffixOf "hs" filePath = let fileType = typeOf filePath - commandCandidates = case fileType of - Source -> let testFiles = M.lookup filePath sourceToTestFileMap - in toCommandCandidates testFiles - Test -> [filePath] - in Echo (filePath ++ " changed") : map (CabalExec . RunHaskell sourceFolder testFolder ) commandCandidates - | otherwise = [] -toCommandCandidates :: Maybe [TestFile] -> [String] -toCommandCandidates (Just testFiles) = map testFilePath testFiles -toCommandCandidates Nothing = [""] +respondToEvent (Modified filePath time) = Just (filePath,time) +respondToEvent (Added filePath time) = Just (filePath,time) +respondToEvent _ = Nothing +-- commands :: SourceTestMap -> String -> String -> (FilePath,a) -> [Command] +processEvent :: M.Map String [TestFile] -> String -> String -> (FilePath, t) -> [Command] +processEvent sourceToTestFileMap sourceFolder testFolder (filePath,_) + | isSuffixOf "hs" encodedFilePath = + let fileType = typeOf encodedFilePath + commandCandidates = case fileType of + Source -> nub . map testFilePath . fromMaybe [] + $ M.lookup encodedFilePath sourceToTestFileMap + Test -> [encodedFilePath] + in Echo (encodedFilePath ++ " changed") : + map (RunHaskell sourceFolder testFolder ) commandCandidates + | otherwise = [] + where encodedFilePath = encodeString filePath diff --git a/src/Arion/Runner.hs b/src/Arion/Runner.hs --- a/src/Arion/Runner.hs +++ b/src/Arion/Runner.hs @@ -1,25 +1,29 @@ +{-# LANGUAGE ScopedTypeVariables, TupleSections #-} module Arion.Runner( run ) where -import System.FSNotify (watchTree, withManager, WatchManager, Event) -import Data.Text (pack) -import Filesystem.Path.CurrentOS (fromText) -import System.Process (callCommand) -import Control.Monad (mapM_) -import System.FilePath.Find (find, always, extension, (==?), (||?)) -import Control.Concurrent (threadDelay) -import Control.Monad (forever, void) -import Control.Exception (try, SomeException) -import Control.Concurrent (forkIO) -import System.Directory (canonicalizePath) -import Control.Applicative ((<$>)) -import Control.Monad ((=<<)) - -import Arion.Types -import Arion.EventProcessor -import Arion.Utilities -import Arion.Help +import Arion.EventProcessor +import Arion.Help +import Arion.Types +import Arion.Utilities +import Control.Applicative ((<$>)) +import Control.Concurrent (MVar, newEmptyMVar, putMVar, + takeMVar, threadDelay) +import Control.Exception (SomeException, bracket_, try) +import Control.Monad (forever, void) +import Control.Monad (join) +import Data.IORef (IORef, atomicModifyIORef', newIORef) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Text (pack) +import Filesystem.Path.CurrentOS (fromText) +import System.Directory (canonicalizePath) +import System.FilePath.Find (always, extension, find, (==?), + (||?)) +import System.FSNotify (WatchManager, watchTree, + withManager) +import System.Process (callCommand) run :: [String] -> IO () run args @@ -30,14 +34,19 @@ startWatching :: String -> String -> String -> WatchManager -> IO () startWatching path sourceFolder testFolder manager = do - sourceFilePathAndContent <- mapM filePathAndContent =<< findHaskellFiles sourceFolder - testFilePathAndContent <- mapM filePathAndContent =<< findHaskellFiles testFolder - let sourceFiles = map (uncurry toSourceFile) sourceFilePathAndContent - let testFiles = map (uncurry toTestFile) testFilePathAndContent - let sourceToTestFileMap = associate sourceFiles testFiles - _ <- watchTree manager (fromText $ pack path) (const True) (eventHandler sourceToTestFileMap sourceFolder testFolder) - forever $ threadDelay maxBound + sourceFiles <- mapM (\x -> uncurry toSourceFile <$> filePathAndContent x) + =<< findHaskellFiles sourceFolder + testFiles <- mapM (\x -> uncurry toTestFile <$> filePathAndContent x) + =<< findHaskellFiles testFolder + let sourceToTestFileMap = associate sourceFiles testFiles + + lock <- newEmptyMVar + inProgress <- newIORef Map.empty + _ <- watchTree manager (fromText $ pack path) (const True) + (eventHandler lock inProgress (processEvent sourceToTestFileMap sourceFolder testFolder) . respondToEvent) + forever $ threadDelay maxBound + filePathAndContent :: String -> IO (FilePath, FileContent) filePathAndContent relativePath = do canonicalizedPath <- canonicalizePath relativePath @@ -47,10 +56,35 @@ findHaskellFiles :: String -> IO [String] findHaskellFiles = find always (extension ==? ".hs" ||? extension ==? ".lhs") -eventHandler :: SourceTestMap -> String -> String -> Event -> IO () -eventHandler sourceToTestFileMap sourceFolder testFolder event = let commands = processEvent sourceToTestFileMap sourceFolder testFolder event - in mapM_ executeCommand commands +-- 10th of a sec? seems ok. +dELAY = 100000 -executeCommand :: Command -> IO () -executeCommand command = let process = (try . callCommand) (show command) :: IO (Either SomeException ()) - in void $ forkIO $ process >> return () +-- eventHandler :: Show a => MVar () -> IORef (Map Command ()) -> (a + -- -> [Command]) -> a -> IO () +eventHandler lock inProgress handler Nothing = return () +eventHandler lock inProgress handler (Just (fp,time)) = do + commands <- join $ atomicModifyIORef' inProgress + (\running -> case Map.lookup fp running of + Just _ -> (running,return []) + Nothing -> (Map.insert fp () running, + do threadDelay dELAY + atomicModifyIORef' inProgress + (\hash -> (Map.delete fp hash, + ())) + return $ handler (fp,time) + )) + + mapM_ (runCommand lock) commands + +runCommand :: Show a => MVar () -> a -> IO () +runCommand lock command = do + bracket_ (putMVar lock ()) + (takeMVar lock) + (noisyTry (callCommand $ show command)) + +noisyTry :: IO () -> IO () +noisyTry f = do + (x :: Either SomeException ()) <- try f + case x of + Left y -> print ("error", y) + _ -> return () diff --git a/src/Arion/Types.hs b/src/Arion/Types.hs --- a/src/Arion/Types.hs +++ b/src/Arion/Types.hs @@ -10,33 +10,34 @@ typeOf ) where -import Data.List (isInfixOf) -import Data.List.Split (splitOn) -import Text.Regex.Posix ((=~), getAllTextMatches) -import Data.Map (Map) +import Data.List (isInfixOf) +import Data.List.Split (splitOn) +import Data.Map (Map) +import Data.Maybe (mapMaybe) +import Text.Regex.Posix (getAllTextMatches, (=~)) data Command = RunHaskell { sourceFolder :: String, testFolder :: String, commandString :: String } | - Echo String | - CabalExec { command :: Command } deriving (Eq) + Echo String + deriving (Eq,Ord) instance Show Command where - show (RunHaskell sourceFolder testFolder commandString) = "runhaskell -- -i" ++ sourceFolder ++ " -i" ++ testFolder ++ " " ++ commandString + show (RunHaskell sourceFolder testFolder commandString) = "cabal exec runhaskell -- -i" ++ sourceFolder ++ " -i" ++ testFolder ++ " " ++ commandString show (Echo stringToEcho) = "echo " ++ stringToEcho - show (CabalExec command) = "cabal exec " ++ show command + type FileContent = String type SourceTestMap = Map FilePath [TestFile] -data SourceFile = SourceFile { - sourceFilePath :: String, - moduleName :: String, +data SourceFile = SourceFile { + sourceFilePath :: String, + moduleName :: String, importedModules :: [String] } deriving (Eq, Ord, Show) -data TestFile = TestFile { +data TestFile = TestFile { testFilePath :: String, - imports :: [String] + imports :: [String] } deriving (Eq, Ord, Show) data FileType = Source | Test @@ -63,10 +64,16 @@ } getImports :: FileContent -> [String] -getImports fileContent = let importLines = getAllTextMatches $ fileContent =~ "import.*" :: [String] - imports = map ((\(_:x:_) -> x) . filter (not . (`elem` ["","qualified"])) . splitOn " ") importLines +getImports fileContent = let importLines = getAllTextMatches $ fileContent =~ "^import .*" :: [String] + imports = mapMaybe (getSecond . filter (not . (`elem` ["","qualified"])) . splitOn " ") importLines in imports + +getSecond (_:x:_) = Just x +getSecond _ = Nothing + +-- this is just wrong - we can't always find a module in a file. +-- need to rework to propagate Maybe up through toSourceFile etc. getModuleName :: FileContent -> String getModuleName fileContent = let moduleLine = fileContent =~ "(module\\s+.*\\s+.*)" :: String (_:moduleName:_)= splitOn " " moduleLine diff --git a/src/Arion/Utilities.hs b/src/Arion/Utilities.hs --- a/src/Arion/Utilities.hs +++ b/src/Arion/Utilities.hs @@ -3,29 +3,35 @@ dependencies ) where -import Arion.Types -import Data.Map (Map, fromList) -import Data.List (union) +import Arion.Types +import Data.List (nub, sort, union) +import Data.Map (Map, fromList) associate :: [SourceFile] -> [TestFile] -> Map FilePath [TestFile] associate sourceFiles testFiles = let sourcesAndDependencies = dependencies sourceFiles in fromList $ map (\(source, dependencies) -> - let testFilesFor source = filter (\testFile -> moduleName source `elem` imports testFile) testFiles + let testFilesFor source = filter (\testFile -> moduleName source `elem` imports testFile) testFiles testFilesForSource = testFilesFor source testFilesForDependencies = concatMap testFilesFor dependencies in (sourceFilePath source, testFilesForSource ++ testFilesForDependencies) ) sourcesAndDependencies dependencies :: [SourceFile] -> [(SourceFile, [SourceFile])] -dependencies [] = [] -dependencies sourceFiles = map (\file -> let dependencies = transitiveDependencies sourceFiles (importedModules file) - in (file, dependencies) - ) sourceFiles +dependencies sourceFiles = map (\file -> let dependencies = transitiveDependencies sourceFiles [] file + in (file, nub $ (filter ((/=) file) dependencies)) + ) sourceFiles -transitiveDependencies :: [SourceFile] -> [String] -> [SourceFile] -transitiveDependencies sourceFiles [] = [] -transitiveDependencies sourceFiles imports = let sourcesForImports = concatMap (findSourcesByModule sourceFiles) imports - in sourcesForImports ++ concatMap (transitiveDependencies sourceFiles) (map importedModules sourcesForImports) +transitiveDependencies :: [SourceFile] -> [SourceFile] -> SourceFile -> [SourceFile] +transitiveDependencies allSourceFiles sourcesThatIHaveSeenSoFar theSourceFile = + let sourcesThatImportMe = sourcesThatImport allSourceFiles (moduleName theSourceFile) + in case any (\source -> source `elem` sourcesThatIHaveSeenSoFar) sourcesThatImportMe of + True -> sourcesThatImportMe + False -> let soFar = sourcesThatIHaveSeenSoFar ++ [theSourceFile] + in sourcesThatImportMe ++ concatMap (transitiveDependencies allSourceFiles soFar) sourcesThatImportMe + findSourcesByModule :: [SourceFile] -> String -> [SourceFile] findSourcesByModule sourceFiles theModuleName = filter (\file -> moduleName file == theModuleName) sourceFiles + +sourcesThatImport :: [SourceFile] -> String -> [SourceFile] +sourcesThatImport sourceFiles theModuleName = filter (\file -> theModuleName `elem` (importedModules file)) sourceFiles