diff --git a/feedback.cabal b/feedback.cabal --- a/feedback.cabal +++ b/feedback.cabal @@ -1,11 +1,11 @@ cabal-version: 2.2 --- This file has been generated from package.yaml by hpack version 0.34.6. +-- This file has been generated from package.yaml by hpack version 0.34.7. -- -- see: https://github.com/sol/hpack name: feedback -version: 0.0.0.0 +version: 0.1.0.0 synopsis: Declarative feedback loop manager homepage: https://github.com/NorfairKing/feedback#readme bug-reports: https://github.com/NorfairKing/feedback/issues @@ -37,8 +37,9 @@ src build-depends: autodocodec - , autodocodec-yaml + , autodocodec-yaml >=0.2 , base >=4.7 && <5 + , bytestring , conduit , containers , envparse @@ -49,12 +50,18 @@ , pretty-show , safe-coloured-text , safe-coloured-text-layout - , safe-coloured-text-terminfo , text , time , typed-process + , unix , unliftio , yaml + if os(windows) + build-depends: + Win32 >=2.13.2 + else + build-depends: + safe-coloured-text-terminfo default-language: Haskell2010 executable feedback @@ -66,7 +73,7 @@ Paths_feedback hs-source-dirs: app - ghc-options: -threaded -rtsopts "-with-rtsopts=-N3 -I0" -main-is Loop.main + ghc-options: -threaded -rtsopts -optP-Wno-nonportable-include-path "-with-rtsopts=-N3 -I0" -main-is Loop.main build-depends: base >=4.7 && <5 , feedback diff --git a/src/Feedback/Common/OptParse.hs b/src/Feedback/Common/OptParse.hs --- a/src/Feedback/Common/OptParse.hs +++ b/src/Feedback/Common/OptParse.hs @@ -15,9 +15,9 @@ import qualified Data.Map as M import Data.Maybe import qualified Data.Text as T -import qualified Data.Text.Encoding as TE import Data.Version import Data.Yaml (FromJSON, ToJSON) +import Debug.Trace import qualified Env import GHC.Generics (Generic) import Options.Applicative as OptParse @@ -62,20 +62,22 @@ deriving (Show, Eq, Generic) data FilterSettings = FilterSettings - { filterSettingGitingore :: !Bool, + { filterSettingGitignore :: !Bool, filterSettingFind :: !(Maybe String) } deriving (Show, Eq, Generic) combineToFilterSettings :: FilterConfiguration -> FilterSettings combineToFilterSettings FilterConfiguration {..} = - let filterSettingGitingore = fromMaybe True filterConfigGitignore + let filterSettingGitignore = fromMaybe True filterConfigGitignore filterSettingFind = filterConfigFind in FilterSettings {..} combineToOutputSettings :: OutputFlags -> OutputConfiguration -> OutputSettings combineToOutputSettings OutputFlags {..} mConf = - let outputSettingClear = fromMaybe ClearScreen $ outputFlagClear <|> outputConfigClear mConf + let outputSettingClear = + fromMaybe (if outputFlagDebug then DoNotClearScreen else ClearScreen) $ + outputFlagClear <|> outputConfigClear mConf in OutputSettings {..} data Configuration = Configuration @@ -246,13 +248,15 @@ } getConfiguration :: Flags -> Environment -> IO (Maybe Configuration) -getConfiguration Flags {..} Environment {..} = - case flagConfigFile <|> envConfigFile of - Nothing -> defaultConfigFile >>= readYamlConfigFile - Just cf -> do - afp <- resolveFile' cf - readYamlConfigFile afp +getConfiguration Flags {..} Environment {..} = do + fp <- case flagConfigFile <|> envConfigFile of + Nothing -> defaultConfigFile + Just cf -> resolveFile' cf + getConfigurationFromFile fp +getConfigurationFromFile :: Path Abs File -> IO (Maybe Configuration) +getConfigurationFromFile = readYamlConfigFile + defaultConfigFile :: IO (Path Abs File) defaultConfigFile = do here <- getCurrentDir @@ -300,26 +304,27 @@ [ Env.helpDoc environmentParser, "", "Configuration file format:", - T.unpack (TE.decodeUtf8 (renderColouredSchemaViaCodec @Configuration)) + T.unpack (renderColouredSchemaViaCodec @Configuration) ] data Flags = Flags - { flagConfigFile :: !(Maybe FilePath), - flagCommand :: !String, - flagOutputFlags :: !OutputFlags, - flagDebug :: Bool + { flagCommand :: !String, + flagConfigFile :: !(Maybe FilePath), + flagOutputFlags :: !OutputFlags } deriving (Show, Eq, Generic) data OutputFlags = OutputFlags - { outputFlagClear :: !(Maybe Clear) + { outputFlagClear :: !(Maybe Clear), + outputFlagDebug :: Bool } deriving (Show, Eq, Generic) parseFlags :: OptParse.Parser Flags parseFlags = Flags - <$> optional + <$> parseCommandFlags + <*> optional ( strOption ( mconcat [ long "config-file", @@ -328,9 +333,7 @@ ] ) ) - <*> parseCommandFlags <*> parseOutputFlags - <*> switch (mconcat [long "debug", help "show debug information"]) parseCommandFlags :: OptParse.Parser String parseCommandFlags = @@ -338,15 +341,30 @@ strArgument ( mconcat [ help "The command to run", - metavar "COMMAND" + metavar "COMMAND", + completer (listIOCompleter defaultConfigFileCompleter) ] ) - in unwords <$> many commandArg + escapeChar = \case + '"' -> "\\\"" + '\'' -> "\\\'" + c -> [c] + quote = ("\"" <>) . (<> "\"") . concatMap escapeChar + quoteIfNecessary "" = quote "" + quoteIfNecessary s = if ' ' `elem` s then quote s else s + pieceBackTogether = unwords . map quoteIfNecessary + in pieceBackTogether . traceShowId <$> many commandArg +defaultConfigFileCompleter :: IO [String] +defaultConfigFileCompleter = do + mConfig <- defaultConfigFile >>= getConfigurationFromFile + pure $ M.keys (maybe [] configLoops mConfig) + parseOutputFlags :: OptParse.Parser OutputFlags parseOutputFlags = OutputFlags <$> parseClearFlag + <*> switch (mconcat [long "debug", help "show debug information"]) data Command = CommandArgs !String diff --git a/src/Feedback/Common/Output.hs b/src/Feedback/Common/Output.hs --- a/src/Feedback/Common/Output.hs +++ b/src/Feedback/Common/Output.hs @@ -16,14 +16,23 @@ import Text.Colour import Text.Printf -putTimedChunks :: TerminalCapabilities -> [Chunk] -> IO () -putTimedChunks terminalCapabilities chunks = do - now <- getCurrentTime +putTimedChunks :: TerminalCapabilities -> ZonedTime -> [Chunk] -> IO () +putTimedChunks terminalCapabilities loopBegin chunks = do + now <- getZonedTime let timeChunk = fore yellow $ chunk $ T.pack $ formatTime defaultTimeLocale "%H:%M:%S" now - putChunksWith terminalCapabilities $ timeChunk : " " : chunks ++ ["\n"] + let relativeTimeStr :: NominalDiffTime -> String + relativeTimeStr ndt = + let d = realToFrac ndt :: Double + in printf "%6.2fs" d + let relativeTimeChunk = fore cyan $ chunk $ T.pack $ relativeTimeStr $ diffUTCTime (zonedTimeToUTC now) (zonedTimeToUTC loopBegin) + putChunksLocaleWith terminalCapabilities $ timeChunk : " " : relativeTimeChunk : " " : chunks ++ ["\n"] + +putDone :: TerminalCapabilities -> ZonedTime -> IO () +putDone terminalCapabilities loopBegin = putTimedChunks terminalCapabilities loopBegin [indicatorChunk "done"] + indicatorChunk :: String -> Chunk -indicatorChunk = fore cyan . chunk . T.pack . printf "%-10s" +indicatorChunk = fore cyan . chunk . T.pack . printf "%-12s" loopNameChunk :: String -> Chunk loopNameChunk = fore yellow . chunk . T.pack diff --git a/src/Feedback/Common/Process.hs b/src/Feedback/Common/Process.hs --- a/src/Feedback/Common/Process.hs +++ b/src/Feedback/Common/Process.hs @@ -58,7 +58,7 @@ pure $ setStdout inherit . setStderr inherit - . setStdin closed -- TODO make this configurable? + . setStdin nullStream -- TODO make this configurable? . setEnv envForProcess . maybe id (setWorkingDir . fromAbsDir) runSettingWorkingDir $ shell commandString diff --git a/src/Feedback/Loop.hs b/src/Feedback/Loop.hs --- a/src/Feedback/Loop.hs +++ b/src/Feedback/Loop.hs @@ -1,11 +1,16 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} module Feedback.Loop where +import Control.Concurrent (ThreadId, myThreadId) +import Control.Exception (AsyncException (UserInterrupt)) import Control.Monad import qualified Data.Text as T +import Data.Time import Data.Word import Feedback.Common.OptParse import Feedback.Common.Output @@ -19,8 +24,17 @@ import System.FSNotify as FS import System.IO (hGetChar) import System.Mem (performGC) +import System.Posix.Signals as Signal +#ifdef MIN_VERSION_Win32 +import System.Win32.MinTTY (isMinTTYHandle) +import System.Win32.Types (withHandleToHANDLE) +#endif import Text.Colour +#ifdef MIN_VERSION_safe_coloured_text_terminfo import Text.Colour.Capabilities.FromEnv (getTerminalCapabilitiesFromEnv) +#else +import Text.Colour.Capabilities (TerminalCapabilities(..)) +#endif import UnliftIO runFeedbackLoop :: IO () @@ -28,77 +42,188 @@ -- The outer loop happens here, before 'getLoopSettings' -- so that the loop can be the thing that's being worked on as well. here <- getCurrentDir - mStdinFiles <- getStdinFiles here - forever $ do - LoopSettings {..} <- getLoopSettings - eventChan <- newChan - outputChan <- newChan - -- 0.1 second debouncing, 0.001 was too little - let conf = FS.defaultConfig {confDebounce = Debounce 0.1} - FS.withManagerConf conf $ \watchManager -> do - eventFilter <- mkEventFilter here mStdinFiles loopSettingFilterSettings - stopListeningAction <- - FS.watchTree - watchManager - (fromAbsDir here) -- Where to watch - eventFilter - $ \event -> do - writeChan eventChan event - race_ - (processWorker loopSettingRunSettings eventChan outputChan) - (outputWorker loopSettingOutputSettings outputChan) - stopListeningAction -data RestartEvent = FSEvent !FS.Event | StdinEvent !Char + -- We must get the stdin filter beforehand, because stdin can only be + -- consumed once and we'll want to be able to reread filters below. + stdinFilter <- mkStdinFilter here + + -- Figure out if colours are supported up front, no need to do that in the + -- loop. + terminalCapabilities <- getTermCaps + + -- Get the threadid for a child process to throw an exception to when it's + -- being killed by the user. + mainThreadId <- myThreadId + + -- Get the flags and the environment up front, because they don't change + -- anyway. + -- This is also important because autocompletion won't work if we output + -- something before parsing the flags. + flags <- getFlags + env <- getEnvironment + + let doSingleLoop loopBegin = do + -- We show a 'preparing' chunk before we get the settings because sometimes + -- getting the settings can take a while, for example in big repositories. + putTimedChunks terminalCapabilities loopBegin [indicatorChunk "preparing"] + + -- Get the loop configuration within the loop, so that the loop + -- configuration can be what is being worked on. + mConfiguration <- getConfiguration flags env + loopSettings <- combineToSettings flags env mConfiguration + + FS.withManagerConf FS.defaultConfig $ \watchManager -> do + -- Set up watchers for each relevant directory and send the FSNotify + -- events down this event channel. + eventChan <- newChan + stopListeningAction <- + startWatching + here + stdinFilter + terminalCapabilities + loopBegin + loopSettings + watchManager + eventChan + + -- Start the process and put output. + worker mainThreadId loopSettings terminalCapabilities loopBegin eventChan + `finally` stopListeningAction + + let singleIteration = do + -- Record when the loop began so we can show relative times nicely. + loopBegin <- getZonedTime + doSingleLoop loopBegin `finally` putDone terminalCapabilities loopBegin + + forever singleIteration + +startWatching :: + Path Abs Dir -> + Filter -> + TerminalCapabilities -> + ZonedTime -> + LoopSettings -> + WatchManager -> + Chan FS.Event -> + IO StopListening +startWatching here stdinFilter terminalCapabilities loopBegin LoopSettings {..} watchManager eventChan = do + let sendOutput :: Output -> IO () + sendOutput = putOutput loopSettingOutputSettings terminalCapabilities loopBegin + + -- Build the filter that says which files and directories to care about + sendOutput OutputFiltering + f <- (stdinFilter <>) <$> mkCombinedFilter here loopSettingFilterSettings + + -- Set up the fsnotify watchers based on that filter + sendOutput OutputWatching + let descendHandler :: Path Abs Dir -> [Path Abs Dir] -> [Path Abs File] -> IO (WalkAction Abs) + descendHandler dir subdirs _ = + -- Don't descent into hidden directories + pure $ WalkExclude $ filter (isHiddenIn dir) subdirs + outputWriter :: Path Abs Dir -> [Path Abs Dir] -> [Path Abs File] -> IO StopListening + outputWriter dir _ _ = + if filterDirFilter f dir + then do + let eventFilter fsEvent = maybe False (filterFileFilter f) $ parseAbsFile (eventPath fsEvent) + watchDirChan watchManager (fromAbsDir dir) eventFilter eventChan + else pure (pure ()) + walkDirAccum (Just descendHandler) outputWriter here + +#ifdef MIN_VERSION_safe_coloured_text_terminfo +getTermCaps :: IO TerminalCapabilities +getTermCaps = getTerminalCapabilitiesFromEnv +#else +getTermCaps :: IO TerminalCapabilities +getTermCaps = pure WithoutColours +#endif + +data RestartEvent + = FSEvent !FS.Event + | StdinEvent !Char deriving (Show, Eq) -processWorker :: RunSettings -> Chan FS.Event -> Chan Output -> IO () -processWorker runSettings eventChan outputChan = do - let sendOutput = writeChan outputChan - -- Record starting time +worker :: ThreadId -> LoopSettings -> TerminalCapabilities -> ZonedTime -> Chan FS.Event -> IO () +worker mainThreadId LoopSettings {..} terminalCapabilities loopBegin eventChan = do + let sendOutput :: Output -> IO () + sendOutput = putOutput loopSettingOutputSettings terminalCapabilities loopBegin + + -- Record starting time of the process. + -- This is different from 'loopBegin' because preparing the watchers may take + -- a nontrivial amount of time. start <- getMonotonicTimeNSec - -- Start process - processHandle <- startProcessHandle runSettings - -- Output that the process has started - sendOutput $ OutputProcessStarted runSettings - -- So we don't need idle gc + -- Start the process process + processHandle <- startProcessHandle loopSettingRunSettings + sendOutput $ OutputProcessStarted loopSettingRunSettings + + -- Perform GC after the process has started, because that's when we're + -- waiting anyway, so that we don't need idle gc. performGC + -- Make sure we kill the process and wait for it to exit if a user presses + -- C-c. + installKillHandler mainThreadId processHandle + + -- From here on we will wait for either: + -- 1. A change to a file that we are watching, or + -- 2. The process to finish. + + -- 1. If An event happened first, output it and kill the process. + let handleEventHappened event = do + -- Output the event that has fired + sendOutput $ OutputEvent event + -- Output that killing will start + sendOutput OutputKilling + -- Kill the process + stopProcessHandle processHandle + -- Output that the process has been killed + sendOutput OutputKilled + -- Wait for the process to finish (should have by now) + ec <- waitProcessHandle processHandle + -- Record the end time + end <- getMonotonicTimeNSec + -- Output that the process has finished + sendOutput $ OutputProcessExited ec (end - start) + + -- 2. If the process finished first, show the result and wait for an event anyway + let handleProcessDone ec = do + end <- getMonotonicTimeNSec + sendOutput $ OutputProcessExited ec (end - start) + -- Output the event that made the rerun happen + event <- waitForEvent eventChan + sendOutput $ OutputEvent event + -- Either wait for it to finish or wait for an event eventOrDone <- race (waitForEvent eventChan) (waitProcessHandle processHandle) + case eventOrDone of - -- If An event happened first, output it and kill the process. - Left event -> do - -- Output the event that has fired - sendOutput $ OutputEvent event - -- Output that killing will start - sendOutput OutputKilling - -- Kill the process - stopProcessHandle processHandle - -- Output that the process has been killed - sendOutput OutputKilled - -- Wait for the process to finish (should have by now) - ec <- waitProcessHandle processHandle - -- Record the end time - end <- getMonotonicTimeNSec - -- Output that the process has finished - sendOutput $ OutputProcessExited ec (end - start) - -- If the process finished first, show the result and wait for an event anyway - Right ec -> do - end <- getMonotonicTimeNSec - sendOutput $ OutputProcessExited ec (end - start) - -- Output the event that made the rerun happen - event <- waitForEvent eventChan - sendOutput $ OutputEvent event + Left event -> handleEventHappened event + Right ec -> handleProcessDone ec +installKillHandler :: ThreadId -> ProcessHandle -> IO () +installKillHandler mainThreadId processHandle = do + let killHandler :: Signal.Handler + killHandler = CatchOnce $ do + stopProcessHandle processHandle + _ <- waitProcessHandle processHandle + -- Throw a 'UserInterrupt' to the main thread so that the main thread + -- can print done after the child processes have exited. + throwTo mainThreadId UserInterrupt + + -- Install this kill handler for sigINT only. + -- In the case of sigKILL, which we can't really be sure to catch anyway, + -- crash harder. + _ <- installHandler sigINT killHandler Nothing + pure () + waitForEvent :: Chan FS.Event -> IO RestartEvent waitForEvent eventChan = do isTerminal <- hIsTerminalDevice stdin - if isTerminal + isMinTTY <- getMinTTY + if isTerminal || isMinTTY then do hSetBuffering stdin NoBuffering either id id @@ -108,39 +233,41 @@ else FSEvent <$> readChan eventChan data Output - = OutputEvent !RestartEvent + = OutputFiltering + | OutputWatching + | OutputEvent !RestartEvent | OutputKilling | OutputKilled | OutputProcessStarted !RunSettings | OutputProcessExited !ExitCode !Word64 deriving (Show) -outputWorker :: OutputSettings -> Chan Output -> IO () -outputWorker OutputSettings {..} outputChan = do - terminalCapabilities <- getTerminalCapabilitiesFromEnv - let put = putTimedChunks terminalCapabilities - forever $ do - event <- readChan outputChan - case event of - OutputEvent restartEvent -> do - put $ - indicatorChunk "event:" : case restartEvent of - FSEvent fsEvent -> - [ case fsEvent of - Added {} -> fore green " added " - Modified {} -> fore yellow " modified " - Removed {} -> fore red " removed " - Unknown {} -> " unknown ", - chunk $ T.pack $ eventPath fsEvent - ] - StdinEvent c -> [chunk $ T.pack $ show c] - OutputKilling -> put [indicatorChunk "killing"] - OutputKilled -> put [indicatorChunk "killed"] - OutputProcessStarted runSettings -> do - case outputSettingClear of - ClearScreen -> putStr "\ESCc" - DoNotClearScreen -> pure () - mapM_ put $ startingLines runSettings - OutputProcessExited ec nanosecs -> do - put $ exitCodeChunks ec - put $ durationChunks nanosecs +putOutput :: OutputSettings -> TerminalCapabilities -> ZonedTime -> Output -> IO () +putOutput OutputSettings {..} terminalCapabilities loopBegin = + let put = putTimedChunks terminalCapabilities loopBegin + in \case + OutputFiltering -> put [indicatorChunk "filtering"] + OutputWatching -> put [indicatorChunk "watching"] + OutputEvent restartEvent -> do + put $ + indicatorChunk "event:" : + " " : case restartEvent of + FSEvent fsEvent -> + [ case fsEvent of + Added {} -> fore green " added " + Modified {} -> fore yellow " modified " + Removed {} -> fore red " removed " + Unknown {} -> " unknown ", + chunk $ T.pack $ eventPath fsEvent + ] + StdinEvent c -> [fore magenta "manual restart: ", chunk $ T.pack $ show c] + OutputKilling -> put [indicatorChunk "killing"] + OutputKilled -> put [indicatorChunk "killed"] + OutputProcessStarted runSettings -> do + case outputSettingClear of + ClearScreen -> putStr "\ESCc" + DoNotClearScreen -> pure () + mapM_ put $ startingLines runSettings + OutputProcessExited ec nanosecs -> do + put $ exitCodeChunks ec + put $ durationChunks nanosecs diff --git a/src/Feedback/Loop/Filter.hs b/src/Feedback/Loop/Filter.hs --- a/src/Feedback/Loop/Filter.hs +++ b/src/Feedback/Loop/Filter.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} @@ -5,10 +6,13 @@ module Feedback.Loop.Filter where +import Data.ByteString (ByteString) +import qualified Data.ByteString.Lazy as LB +import qualified Data.ByteString.Lazy.Char8 as LB8 import Data.Conduit import qualified Data.Conduit.Combinators as C +import qualified Data.Conduit.List as CL import Data.List -import Data.Maybe import Data.Set import qualified Data.Set as S import qualified Data.Text as T @@ -17,84 +21,131 @@ import Path import Path.IO import System.Exit -import System.FSNotify as FS import System.Process.Typed as Typed +#ifdef MIN_VERSION_Win32 +import System.Win32.MinTTY (isMinTTYHandle) +import System.Win32.Types (withHandleToHANDLE) +#endif import UnliftIO -getStdinFiles :: Path Abs Dir -> IO (Maybe (Set FilePath)) +#ifdef MIN_VERSION_Win32 +getMinTTY :: IO Bool +getMinTTY = withHandleToHANDLE stdin isMinTTYHandle +#else +getMinTTY :: IO Bool +getMinTTY = pure False +#endif + +data Filter = Filter + { filterDirFilter :: Path Abs Dir -> Bool, + filterFileFilter :: Path Abs File -> Bool + } + +instance Semigroup Filter where + f1 <> f2 = + Filter + { filterDirFilter = \d -> filterDirFilter f1 d && filterDirFilter f2 d, + filterFileFilter = \f -> filterFileFilter f1 f && filterFileFilter f2 f + } + +instance Monoid Filter where + mempty = Filter {filterDirFilter = const True, filterFileFilter = const True} + mappend = (<>) + +fileSetFilter :: Set (Path Abs File) -> Filter +fileSetFilter fileSet = + let dirSet = S.map parent fileSet + in Filter + { filterDirFilter = (`S.member` dirSet), + filterFileFilter = (`S.member` fileSet) + } + +mkCombinedFilter :: Path Abs Dir -> FilterSettings -> IO Filter +mkCombinedFilter here filterSettings = + mconcat + <$> sequence + [ mkGitFilter here filterSettings, + mkFindFilter here filterSettings, + pure $ standardFilter here + ] + +mkStdinFilter :: Path Abs Dir -> IO Filter +mkStdinFilter here = maybe mempty fileSetFilter <$> getStdinFiles here + +getStdinFiles :: Path Abs Dir -> IO (Maybe (Set (Path Abs File))) getStdinFiles here = do isTerminal <- hIsTerminalDevice stdin - if isTerminal + isMinTTY <- getMinTTY + if isTerminal || isMinTTY then pure Nothing else (Just <$> handleFileSet here stdin) `catch` (\(_ :: IOException) -> pure Nothing) -mkEventFilter :: Path Abs Dir -> Maybe (Set FilePath) -> FilterSettings -> IO (FS.Event -> Bool) -mkEventFilter here mStdinFiles FilterSettings {..} = do - let mFilter mSet event = maybe True (eventPath event `S.member`) mSet - let stdinFilter = mFilter mStdinFiles - mFindFiles <- mapM (filesFromFindArgs here) filterSettingFind - let findFilter = mFilter mFindFiles - mGitFiles <- - if filterSettingGitingore - then gitLsFiles here - else pure Nothing - let gitFilter = mFilter mGitFiles - let standardFilter = standardEventFilter here - pure $ - if isJust mStdinFiles - then stdinFilter - else - if isJust mFindFiles - then findFilter - else combineFilters [standardFilter, gitFilter] - -combineFilters :: [FS.Event -> Bool] -> FS.Event -> Bool -combineFilters filters event = all ($ event) filters +mkGitFilter :: Path Abs Dir -> FilterSettings -> IO Filter +mkGitFilter here FilterSettings {..} = do + if filterSettingGitignore + then do + mGitFiles <- gitLsFiles here + pure $ maybe mempty fileSetFilter mGitFiles + else pure mempty -gitLsFiles :: Path Abs Dir -> IO (Maybe (Set FilePath)) +gitLsFiles :: Path Abs Dir -> IO (Maybe (Set (Path Abs File))) gitLsFiles here = do - let processConfig = setStdout createPipe $ shell "git ls-files" - process <- startProcess processConfig - ec <- waitExitCode process - case ec of - ExitFailure _ -> pure Nothing - ExitSuccess -> Just <$> handleFileSet here (getStdout process) + let processConfig = shell "git ls-files" + (ec, out) <- readProcessStdout processConfig + set <- bytesFileSet here out + pure $ case ec of + ExitFailure _ -> Nothing + ExitSuccess -> Just set -filesFromFindArgs :: Path Abs Dir -> String -> IO (Set FilePath) +mkFindFilter :: Path Abs Dir -> FilterSettings -> IO Filter +mkFindFilter here FilterSettings {..} = case filterSettingFind of + Nothing -> pure mempty + Just args -> fileSetFilter <$> filesFromFindArgs here args + +filesFromFindArgs :: Path Abs Dir -> String -> IO (Set (Path Abs File)) filesFromFindArgs here args = do let processConfig = setStdout createPipe $ shell $ "find " <> args - process <- startProcess processConfig - ec <- waitExitCode process + (ec, out) <- readProcessStdout processConfig + set <- bytesFileSet here out case ec of ExitFailure _ -> die $ "Find failed: " <> show ec - ExitSuccess -> handleFileSet here (getStdout process) + ExitSuccess -> pure set -handleFileSet :: Path Abs Dir -> Handle -> IO (Set FilePath) +bytesFileSet :: Path Abs Dir -> LB.ByteString -> IO (Set (Path Abs File)) +bytesFileSet here lb = + runConduit $ + CL.sourceList (LB8.lines lb) + .| C.map LB.toStrict + .| fileSetBuilder here + +handleFileSet :: Path Abs Dir -> Handle -> IO (Set (Path Abs File)) handleFileSet here h = runConduit $ C.sourceHandle h .| C.linesUnboundedAscii - .| C.concatMap TE.decodeUtf8' - .| C.map T.unpack - .| C.mapM (resolveFile here) - .| C.map fromAbsFile - .| C.foldMap S.singleton + .| fileSetBuilder here -standardEventFilter :: Path Abs Dir -> FS.Event -> Bool -standardEventFilter here fsEvent = - and - [ -- It's not one of those files that vim makes - (filename <$> parseAbsFile (eventPath fsEvent)) /= Just [relfile|4913|], - not $ "~" `isSuffixOf` eventPath fsEvent, - -- It's not a hidden file - not $ hiddenHere here (eventPath fsEvent) - ] +fileSetBuilder :: Path Abs Dir -> ConduitT ByteString Void IO (Set (Path Abs File)) +fileSetBuilder here = + C.concatMap TE.decodeUtf8' + .| C.map T.unpack + .| C.mapM (resolveFile here) + .| C.foldMap S.singleton -hiddenHere :: Path Abs Dir -> FilePath -> Bool -hiddenHere here filePath = - (hidden <$> (parseAbsFile filePath >>= stripProperPrefix here)) /= Just False +standardFilter :: Path Abs Dir -> Filter +standardFilter here = + Filter + { filterDirFilter = not . isHiddenIn here, + filterFileFilter = \f -> + and + [ not $ isHiddenIn here f, + -- It's not one of those files that vim makes + not $ "~" `isSuffixOf` fromAbsFile f, + filename f /= [relfile|4913|] + ] + } hidden :: Path Rel File -> Bool hidden = goFile diff --git a/src/Feedback/Loop/OptParse.hs b/src/Feedback/Loop/OptParse.hs --- a/src/Feedback/Loop/OptParse.hs +++ b/src/Feedback/Loop/OptParse.hs @@ -1,10 +1,10 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} module Feedback.Loop.OptParse where import Control.Monad -import Data.List import qualified Data.Map as M import qualified Data.Text as T import Feedback.Common.OptParse @@ -12,16 +12,11 @@ import System.Exit import Text.Colour import Text.Colour.Layout -import Text.Colour.Term +#ifdef MIN_VERSION_safe_coloured_text_terminfo +import Text.Colour.Term (putChunksLocale) +#endif import Text.Show.Pretty (pPrint) -getLoopSettings :: IO LoopSettings -getLoopSettings = do - flags <- getFlags - env <- getEnvironment - config <- getConfiguration flags env - combineToSettings flags env config - combineToSettings :: Flags -> Environment -> Maybe Configuration -> IO LoopSettings combineToSettings flags@Flags {..} environment mConf = do let loops = maybe M.empty configLoops mConf @@ -48,7 +43,7 @@ pure config case mLoopConfig of Nothing -> do - putChunks $ intercalate ["\n"] $ prettyConfiguration mConf + put $ concatMap (<> ["\n"]) $ prettyConfiguration mConf exitSuccess Just loopConfig -> do loopSets <- @@ -57,9 +52,16 @@ environment (mConf >>= configOutputConfiguration) loopConfig - when flagDebug $ pPrint loopSets + when (outputFlagDebug flagOutputFlags) $ pPrint loopSets pure loopSets + where +#ifdef MIN_VERSION_safe_coloured_text_terminfo + put = putChunksLocale +#else + put = putChunksLocaleWith WithoutColours +#endif + prettyConfiguration :: Maybe Configuration -> [[Chunk]] prettyConfiguration mConf = case mConf of Nothing -> [[fore blue "No feedback loops have been configured here."]] @@ -70,7 +72,8 @@ ( map (uncurry loopConfigLine) (M.toList (configLoops conf)) - ) + ), + [fore blue "Run ", fore yellow "feedback loopname", fore blue " to activate a feedback loop."] ] loopConfigLine :: String -> LoopConfiguration -> [Chunk] diff --git a/src/Feedback/Test.hs b/src/Feedback/Test.hs --- a/src/Feedback/Test.hs +++ b/src/Feedback/Test.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -5,18 +6,24 @@ import Control.Monad import qualified Data.Map as M +import Data.Time import Feedback.Common.OptParse import Feedback.Common.Output import Feedback.Common.Process import Feedback.Test.OptParse import GHC.Clock (getMonotonicTimeNSec) +import Text.Colour.Capabilities (TerminalCapabilities (..)) + +#ifdef MIN_VERSION_safe_coloured_text_terminfo import Text.Colour.Capabilities.FromEnv (getTerminalCapabilitiesFromEnv) +#endif runFeedbackTest :: IO () runFeedbackTest = do TestSettings {..} <- getSettings - terminalCapabilities <- getTerminalCapabilitiesFromEnv - let put = putTimedChunks terminalCapabilities + terminalCapabilities <- getTermCaps + begin <- getZonedTime + let put = putTimedChunks terminalCapabilities begin forM_ (M.toList testSettingLoops) $ \(loopName, LoopSettings {..}) -> do put [indicatorChunk "testing ", " ", loopNameChunk loopName] mapM_ put $ startingLines loopSettingRunSettings @@ -26,3 +33,11 @@ put $ exitCodeChunks ec let duration = end - start put $ durationChunks duration + +#ifdef MIN_VERSION_safe_coloured_text_terminfo +getTermCaps :: IO TerminalCapabilities +getTermCaps = getTerminalCapabilitiesFromEnv +#else +getTermCaps :: IO TerminalCapabilities +getTermCaps = pure WithoutColours +#endif diff --git a/src/Feedback/Test/OptParse.hs b/src/Feedback/Test/OptParse.hs --- a/src/Feedback/Test/OptParse.hs +++ b/src/Feedback/Test/OptParse.hs @@ -30,5 +30,5 @@ (combineToLoopSettings flags environment (mConf >>= configOutputConfiguration)) (filterFunc $ maybe M.empty configLoops mConf) let testSets = TestSettings {..} - when flagDebug $ pPrint testSets + when (outputFlagDebug flagOutputFlags) $ pPrint testSets pure testSets