feedback 0.0.0.0 → 0.1.0.0
raw patch · 9 files changed
+416/−186 lines, 9 filesdep +Win32dep +bytestringdep +unixdep ~autodocodec-yaml
Dependencies added: Win32, bytestring, unix
Dependency ranges changed: autodocodec-yaml
Files
- feedback.cabal +12/−5
- src/Feedback/Common/OptParse.hs +39/−21
- src/Feedback/Common/Output.hs +14/−5
- src/Feedback/Common/Process.hs +1/−1
- src/Feedback/Loop.hs +211/−84
- src/Feedback/Loop/Filter.hs +106/−55
- src/Feedback/Loop/OptParse.hs +15/−12
- src/Feedback/Test.hs +17/−2
- src/Feedback/Test/OptParse.hs +1/−1
feedback.cabal view
@@ -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
src/Feedback/Common/OptParse.hs view
@@ -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
src/Feedback/Common/Output.hs view
@@ -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
src/Feedback/Common/Process.hs view
@@ -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
src/Feedback/Loop.hs view
@@ -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
src/Feedback/Loop/Filter.hs view
@@ -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
src/Feedback/Loop/OptParse.hs view
@@ -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]
src/Feedback/Test.hs view
@@ -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
src/Feedback/Test/OptParse.hs view
@@ -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