feedback (empty) → 0.0.0.0
raw patch · 11 files changed
+1058/−0 lines, 11 filesdep +autodocodecdep +autodocodec-yamldep +base
Dependencies added: autodocodec, autodocodec-yaml, base, conduit, containers, envparse, feedback, fsnotify, optparse-applicative, path, path-io, pretty-show, safe-coloured-text, safe-coloured-text-layout, safe-coloured-text-terminfo, text, time, typed-process, unliftio, yaml
Files
- app/Loop.hs +6/−0
- app/Test.hs +6/−0
- feedback.cabal +88/−0
- src/Feedback/Common/OptParse.hs +397/−0
- src/Feedback/Common/Output.hs +90/−0
- src/Feedback/Common/Process.hs +70/−0
- src/Feedback/Loop.hs +146/−0
- src/Feedback/Loop/Filter.hs +113/−0
- src/Feedback/Loop/OptParse.hs +80/−0
- src/Feedback/Test.hs +28/−0
- src/Feedback/Test/OptParse.hs +34/−0
+ app/Loop.hs view
@@ -0,0 +1,6 @@+module Loop where++import Feedback.Loop++main :: IO ()+main = runFeedbackLoop
+ app/Test.hs view
@@ -0,0 +1,6 @@+module Test where++import Feedback.Test++main :: IO ()+main = runFeedbackTest
+ feedback.cabal view
@@ -0,0 +1,88 @@+cabal-version: 2.2++-- This file has been generated from package.yaml by hpack version 0.34.6.+--+-- see: https://github.com/sol/hpack++name: feedback+version: 0.0.0.0+synopsis: Declarative feedback loop manager+homepage: https://github.com/NorfairKing/feedback#readme+bug-reports: https://github.com/NorfairKing/feedback/issues+author: Tom Sydney Kerckhove+maintainer: syd@cs-syd.eu+copyright: Copyright (c) 2022 Tom Sydney Kerckhove+license: GPL-3.0-only+build-type: Simple++source-repository head+ type: git+ location: https://github.com/NorfairKing/feedback++library+ exposed-modules:+ Feedback.Common.OptParse+ Feedback.Common.Output+ Feedback.Common.Process+ Feedback.Loop+ Feedback.Loop.Filter+ Feedback.Loop.OptParse+ Feedback.Test+ Feedback.Test.OptParse+ other-modules:+ Paths_feedback+ autogen-modules:+ Paths_feedback+ hs-source-dirs:+ src+ build-depends:+ autodocodec+ , autodocodec-yaml+ , base >=4.7 && <5+ , conduit+ , containers+ , envparse+ , fsnotify+ , optparse-applicative+ , path+ , path-io+ , pretty-show+ , safe-coloured-text+ , safe-coloured-text-layout+ , safe-coloured-text-terminfo+ , text+ , time+ , typed-process+ , unliftio+ , yaml+ default-language: Haskell2010++executable feedback+ main-is: Loop.hs+ other-modules:+ Test+ Paths_feedback+ autogen-modules:+ Paths_feedback+ hs-source-dirs:+ app+ ghc-options: -threaded -rtsopts "-with-rtsopts=-N3 -I0" -main-is Loop.main+ build-depends:+ base >=4.7 && <5+ , feedback+ default-language: Haskell2010++executable feedback-test+ main-is: Test.hs+ other-modules:+ Loop+ Paths_feedback+ autogen-modules:+ Paths_feedback+ hs-source-dirs:+ app+ ghc-options: -threaded -rtsopts -with-rtsopts=-N -main-is Test.main+ build-depends:+ base >=4.7 && <5+ , feedback+ default-language: Haskell2010
+ src/Feedback/Common/OptParse.hs view
@@ -0,0 +1,397 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeApplications #-}++module Feedback.Common.OptParse where++import Autodocodec+import Autodocodec.Yaml+import Control.Applicative+import Data.Map (Map)+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 qualified Env+import GHC.Generics (Generic)+import Options.Applicative as OptParse+import qualified Options.Applicative.Help as OptParse (string)+import Path+import Path.IO+import Paths_feedback++data LoopSettings = LoopSettings+ { loopSettingRunSettings :: !RunSettings,+ loopSettingFilterSettings :: !FilterSettings,+ loopSettingOutputSettings :: !OutputSettings+ }+ deriving (Show, Eq, Generic)++combineToLoopSettings :: Flags -> Environment -> Maybe OutputConfiguration -> LoopConfiguration -> IO LoopSettings+combineToLoopSettings Flags {..} Environment {} mDefaultOutputConfig LoopConfiguration {..} = do+ loopSettingRunSettings <- combineToRunSettings loopConfigRunConfiguration+ let loopSettingFilterSettings = combineToFilterSettings loopConfigFilterConfiguration++ let outputConfig = maybe loopConfigOutputConfiguration (<> loopConfigOutputConfiguration) mDefaultOutputConfig+ let loopSettingOutputSettings = combineToOutputSettings flagOutputFlags outputConfig+ pure LoopSettings {..}++data RunSettings = RunSettings+ { runSettingCommand :: !Command,+ runSettingExtraEnv :: !(Map String String),+ runSettingWorkingDir :: !(Maybe (Path Abs Dir))+ }+ deriving (Show, Eq, Generic)++combineToRunSettings :: RunConfiguration -> IO RunSettings+combineToRunSettings RunConfiguration {..} = do+ let runSettingCommand = runConfigCommand+ let runSettingExtraEnv = runConfigExtraEnv+ runSettingWorkingDir <- mapM resolveDir' runConfigWorkingDir+ pure RunSettings {..}++data OutputSettings = OutputSettings+ { outputSettingClear :: !Clear+ }+ deriving (Show, Eq, Generic)++data FilterSettings = FilterSettings+ { filterSettingGitingore :: !Bool,+ filterSettingFind :: !(Maybe String)+ }+ deriving (Show, Eq, Generic)++combineToFilterSettings :: FilterConfiguration -> FilterSettings+combineToFilterSettings FilterConfiguration {..} =+ let filterSettingGitingore = fromMaybe True filterConfigGitignore+ filterSettingFind = filterConfigFind+ in FilterSettings {..}++combineToOutputSettings :: OutputFlags -> OutputConfiguration -> OutputSettings+combineToOutputSettings OutputFlags {..} mConf =+ let outputSettingClear = fromMaybe ClearScreen $ outputFlagClear <|> outputConfigClear mConf+ in OutputSettings {..}++data Configuration = Configuration+ { configLoops :: !(Map String LoopConfiguration),+ configOutputConfiguration :: !(Maybe OutputConfiguration)+ }+ deriving stock (Show, Eq, Generic)+ deriving (FromJSON, ToJSON) via (Autodocodec Configuration)++instance HasCodec Configuration where+ codec =+ object "Configuration" $+ Configuration+ <$> optionalFieldWithOmittedDefault' "loops" M.empty .= configLoops+ <*> optionalField "output" "default output configuration" .= configOutputConfiguration++data LoopConfiguration = LoopConfiguration+ { loopConfigDescription :: !(Maybe String),+ loopConfigRunConfiguration :: !RunConfiguration,+ loopConfigFilterConfiguration :: !FilterConfiguration,+ loopConfigOutputConfiguration :: !OutputConfiguration+ }+ deriving stock (Show, Eq, Generic)+ deriving (FromJSON, ToJSON) via (Autodocodec LoopConfiguration)++instance HasCodec LoopConfiguration where+ codec =+ named+ "LoopConfiguration"+ ( dimapCodec f g $+ eitherCodec (codec <?> "A bare command without any extra configuration") $+ object "LoopConfiguration" loopConfigurationObjectCodec+ )+ <??> loopConfigDocs+ where+ loopConfigDocs =+ [ "A LoopConfiguration specifies an entire feedback loop.",+ "",+ "It consists of three parts:",+ "* Filter Configuration: Which files to watch",+ "* Run Configuration: What to do when those files change",+ "* Output Configuration: What to see"+ ]+ f = \case+ Left s -> makeLoopConfiguration (CommandArgs s)+ Right loopConfig -> loopConfig+ g loopConfig =+ let runConfig = loopConfigRunConfiguration loopConfig+ c = runConfigCommand runConfig+ in case c of+ CommandArgs cmd | loopConfig == makeLoopConfiguration c -> Left cmd+ _ -> Right loopConfig++loopConfigurationObjectCodec :: JSONObjectCodec LoopConfiguration+loopConfigurationObjectCodec =+ LoopConfiguration+ <$> optionalField "description" "description of when to use this feedback loop" .= loopConfigDescription+ <*> parseAlternative+ (requiredField "run" "run configuration for this loop")+ runConfigurationObjectCodec+ .= loopConfigRunConfiguration+ <*> parseAlternative+ (requiredField "filter" "filter configuration for this loop")+ filterConfigurationObjectCodec+ .= loopConfigFilterConfiguration+ <*> parseAlternative+ (requiredField "output" "output configuration for this loop")+ outputConfigurationObjectCodec+ .= loopConfigOutputConfiguration++makeLoopConfiguration :: Command -> LoopConfiguration+makeLoopConfiguration c =+ LoopConfiguration+ { loopConfigDescription = Nothing,+ loopConfigRunConfiguration = makeRunConfiguration c,+ loopConfigFilterConfiguration = emptyFilterConfiguration,+ loopConfigOutputConfiguration = emptyOutputConfiguration+ }++data RunConfiguration = RunConfiguration+ { runConfigCommand :: !Command,+ runConfigExtraEnv :: !(Map String String),+ runConfigWorkingDir :: !(Maybe FilePath)+ }+ deriving stock (Show, Eq, Generic)+ deriving (FromJSON, ToJSON) via (Autodocodec RunConfiguration)++instance HasCodec RunConfiguration where+ codec =+ named "RunConfiguration" $+ object "RunConfiguration" runConfigurationObjectCodec++runConfigurationObjectCodec :: JSONObjectCodec RunConfiguration+runConfigurationObjectCodec =+ RunConfiguration+ <$> commandObjectCodec .= runConfigCommand+ <*> optionalFieldWithOmittedDefault "env" M.empty "extra environment variables to set" .= runConfigExtraEnv+ <*> optionalField "working-dir" "where the process will be run" .= runConfigWorkingDir++makeRunConfiguration :: Command -> RunConfiguration+makeRunConfiguration c =+ RunConfiguration+ { runConfigCommand = c,+ runConfigExtraEnv = M.empty,+ runConfigWorkingDir = Nothing+ }++data FilterConfiguration = FilterConfiguration+ { filterConfigGitignore :: !(Maybe Bool),+ filterConfigFind :: !(Maybe String)+ }+ deriving stock (Show, Eq, Generic)+ deriving (FromJSON, ToJSON) via (Autodocodec FilterConfiguration)++instance HasCodec FilterConfiguration where+ codec =+ named+ "FilterConfiguration"+ ( object "FilterConfiguration" filterConfigurationObjectCodec+ )+ <??> filterConfigurationDocs+ where+ filterConfigurationDocs =+ [ "By default, standard filters are applied and,",+ "if in a git repository, only files in the git repository are considered.",+ "If either 'git' or 'find' configuration are specified, only those are used."+ ]++filterConfigurationObjectCodec :: JSONObjectCodec FilterConfiguration+filterConfigurationObjectCodec =+ FilterConfiguration+ <$> optionalField "git" "whether to ignore files that are not in the git repo\nConcretely, this uses `git ls-files` to find files that are in the repo, so files that have been added but are also ignored by .gitignore will still be watched." .= filterConfigGitignore+ <*> optionalField "find" "arguments for the 'find' command to find files to be notified about" .= filterConfigFind++emptyFilterConfiguration :: FilterConfiguration+emptyFilterConfiguration =+ FilterConfiguration+ { filterConfigGitignore = Nothing,+ filterConfigFind = Nothing+ }++data OutputConfiguration = OutputConfiguration+ { outputConfigClear :: !(Maybe Clear)+ }+ deriving stock (Show, Eq, Generic)+ deriving (FromJSON, ToJSON) via (Autodocodec OutputConfiguration)++instance HasCodec OutputConfiguration where+ codec =+ named "OutputConfiguration" $+ object "OutputConfiguration" outputConfigurationObjectCodec++outputConfigurationObjectCodec :: JSONObjectCodec OutputConfiguration+outputConfigurationObjectCodec =+ OutputConfiguration+ <$> optionalField "clear" "whether to clear the screen runs" .= outputConfigClear++instance Semigroup OutputConfiguration where+ (<>) oc1 oc2 =+ OutputConfiguration+ { outputConfigClear = outputConfigClear oc1 <|> outputConfigClear oc2+ }++emptyOutputConfiguration :: OutputConfiguration+emptyOutputConfiguration =+ OutputConfiguration+ { outputConfigClear = Nothing+ }++getConfiguration :: Flags -> Environment -> IO (Maybe Configuration)+getConfiguration Flags {..} Environment {..} =+ case flagConfigFile <|> envConfigFile of+ Nothing -> defaultConfigFile >>= readYamlConfigFile+ Just cf -> do+ afp <- resolveFile' cf+ readYamlConfigFile afp++defaultConfigFile :: IO (Path Abs File)+defaultConfigFile = do+ here <- getCurrentDir+ resolveFile here "feedback.yaml"++data Environment = Environment+ { envConfigFile :: !(Maybe FilePath)+ }+ deriving (Show, Eq, Generic)++getEnvironment :: IO Environment+getEnvironment = Env.parse (Env.header "Environment") environmentParser++environmentParser :: Env.Parser Env.Error Environment+environmentParser =+ Env.prefixed "FEEDBACK_" $+ Environment+ <$> Env.var (fmap Just . Env.str) "CONFIG_FILE" (Env.def Nothing <> Env.help "Config file")++getFlags :: IO Flags+getFlags = customExecParser prefs_ flagsParser++prefs_ :: OptParse.ParserPrefs+prefs_ =+ OptParse.defaultPrefs+ { OptParse.prefShowHelpOnError = True,+ OptParse.prefShowHelpOnEmpty = True+ }++flagsParser :: OptParse.ParserInfo Flags+flagsParser =+ OptParse.info+ (OptParse.helper <*> parseFlags)+ ( mconcat+ [ OptParse.progDesc versionStr,+ OptParse.fullDesc,+ OptParse.footerDoc (Just $ OptParse.string footerStr)+ ]+ )+ where+ versionStr =+ "Version: " <> showVersion version+ footerStr =+ unlines+ [ Env.helpDoc environmentParser,+ "",+ "Configuration file format:",+ T.unpack (TE.decodeUtf8 (renderColouredSchemaViaCodec @Configuration))+ ]++data Flags = Flags+ { flagConfigFile :: !(Maybe FilePath),+ flagCommand :: !String,+ flagOutputFlags :: !OutputFlags,+ flagDebug :: Bool+ }+ deriving (Show, Eq, Generic)++data OutputFlags = OutputFlags+ { outputFlagClear :: !(Maybe Clear)+ }+ deriving (Show, Eq, Generic)++parseFlags :: OptParse.Parser Flags+parseFlags =+ Flags+ <$> optional+ ( strOption+ ( mconcat+ [ long "config-file",+ help "Path to an altenative config file",+ metavar "FILEPATH"+ ]+ )+ )+ <*> parseCommandFlags+ <*> parseOutputFlags+ <*> switch (mconcat [long "debug", help "show debug information"])++parseCommandFlags :: OptParse.Parser String+parseCommandFlags =+ let commandArg =+ strArgument+ ( mconcat+ [ help "The command to run",+ metavar "COMMAND"+ ]+ )+ in unwords <$> many commandArg++parseOutputFlags :: OptParse.Parser OutputFlags+parseOutputFlags =+ OutputFlags+ <$> parseClearFlag++data Command+ = CommandArgs !String+ | CommandScript !String+ deriving (Show, Eq, Generic)++commandObjectCodec :: JSONObjectCodec Command+commandObjectCodec =+ dimapCodec f g $+ eitherCodec+ (requiredField "command" "the command to run on change")+ (requiredField "script" "the script to run on change")+ where+ f = \case+ Left c -> CommandArgs c+ Right s -> CommandScript s+ g = \case+ CommandArgs c -> Left c+ CommandScript s -> Right s++data Clear = ClearScreen | DoNotClearScreen+ deriving (Show, Eq, Generic)++instance HasCodec Clear where+ codec = dimapCodec f g codec+ where+ f True = ClearScreen+ f False = DoNotClearScreen+ g ClearScreen = True+ g DoNotClearScreen = False++parseClearFlag :: OptParse.Parser (Maybe Clear)+parseClearFlag =+ optional $+ flag'+ ClearScreen+ ( mconcat+ [ long "clear",+ help "clear the screen between feedback"+ ]+ )+ <|> flag'+ DoNotClearScreen+ ( mconcat+ [ long "no-clear",+ help "do not clear the screen between feedback"+ ]+ )
+ src/Feedback/Common/Output.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# OPTIONS_GHC -fno-warn-unused-pattern-binds #-}++module Feedback.Common.Output where++import qualified Data.Map as M+import Data.Maybe+import qualified Data.Text as T+import Data.Time+import Data.Word+import Feedback.Common.OptParse+import Path+import System.Exit+import Text.Colour+import Text.Printf++putTimedChunks :: TerminalCapabilities -> [Chunk] -> IO ()+putTimedChunks terminalCapabilities chunks = do+ now <- getCurrentTime+ let timeChunk = fore yellow $ chunk $ T.pack $ formatTime defaultTimeLocale "%H:%M:%S" now+ putChunksWith terminalCapabilities $ timeChunk : " " : chunks ++ ["\n"]++indicatorChunk :: String -> Chunk+indicatorChunk = fore cyan . chunk . T.pack . printf "%-10s"++loopNameChunk :: String -> Chunk+loopNameChunk = fore yellow . chunk . T.pack++commandChunk :: String -> Chunk+commandChunk = fore blue . chunk . T.pack++startingLines :: RunSettings -> [[Chunk]]+startingLines RunSettings {..} =+ let RunSettings _ _ _ = undefined+ in concat+ [ case runSettingCommand of+ CommandArgs command ->+ [ [ indicatorChunk "starting",+ " ",+ commandChunk command+ ]+ ]+ CommandScript script ->+ [ [ indicatorChunk "starting script\n",+ chunk $ T.pack script+ ]+ ],+ [ [ indicatorChunk "working dir:",+ " ",+ chunk $ T.pack $ fromAbsDir workdir+ ]+ | workdir <- maybeToList runSettingWorkingDir+ ],+ if null runSettingExtraEnv+ then []+ else+ [indicatorChunk "extra env:"] :+ map+ ( \(k, v) ->+ [ " ",+ fore blue $ chunk (T.pack k),+ ": ",+ fore blue $ chunk (T.pack v)+ ]+ )+ (M.toList runSettingExtraEnv)+ ]++exitCodeChunks :: ExitCode -> [Chunk]+exitCodeChunks ec =+ [ indicatorChunk "exited:",+ " ",+ case ec of+ ExitSuccess ->+ fore green "success"+ ExitFailure c ->+ fore red $ chunk $ T.pack $ "failed: " <> show c+ ]++durationChunks :: Word64 -> [Chunk]+durationChunks nanosecs =+ let diffTime :: Double+ diffTime = fromIntegral nanosecs / 1_000_000_000+ in [ indicatorChunk "took",+ " ",+ chunk $+ T.pack $ printf "%4.2fs" diffTime+ ]
+ src/Feedback/Common/Process.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE RecordWildCards #-}+{-# OPTIONS_GHC -fno-warn-unused-pattern-binds #-}++module Feedback.Common.Process where++import Data.Map as M+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import Feedback.Common.OptParse+import Path+import Path.IO+import System.Environment as System (getEnvironment)+import System.Exit+import System.Process.Typed as Typed+import UnliftIO.IO.File++data ProcessHandle = ProcessHandle+ { processHandleProcess :: !P+ }++type P = Process () () ()++startProcessAndWait :: RunSettings -> IO ExitCode+startProcessAndWait runSettings = do+ processConfig <- makeProcessConfigFor runSettings+ startProcess processConfig >>= waitExitCode++startProcessHandle :: RunSettings -> IO ProcessHandle+startProcessHandle runSettings = do+ processConfig <- makeProcessConfigFor runSettings+ processHandleProcess <- startProcess processConfig+ pure ProcessHandle {..}++waitProcessHandle :: ProcessHandle -> IO ExitCode+waitProcessHandle ProcessHandle {..} = waitExitCode processHandleProcess++makeProcessConfigFor :: RunSettings -> IO (ProcessConfig () () ())+makeProcessConfigFor RunSettings {..} = do+ let RunSettings _ _ _ = undefined+ -- Set up the environment+ env <- System.getEnvironment+ let envForProcess = M.toList $ M.union runSettingExtraEnv (M.fromList env)+ -- Set up the command+ commandString <- case runSettingCommand of+ CommandArgs c -> pure c+ CommandScript s -> do+ -- Write the script to a file+ systemTempDir <- getTempDir+ scriptFile <- resolveFile systemTempDir "feedback-script.sh"+ writeBinaryFileDurableAtomic (fromAbsFile scriptFile) (TE.encodeUtf8 (T.pack s))+ -- Make the script executable+ oldPermissions <- getPermissions scriptFile+ let newPermissions = setOwnerExecutable True oldPermissions+ setPermissions scriptFile newPermissions++ pure $ fromAbsFile scriptFile++ pure $+ setStdout inherit+ . setStderr inherit+ . setStdin closed -- TODO make this configurable?+ . setEnv envForProcess+ . maybe id (setWorkingDir . fromAbsDir) runSettingWorkingDir+ $ shell commandString++stopProcessHandle :: ProcessHandle -> IO ()+stopProcessHandle ProcessHandle {..} = do+ stopProcess processHandleProcess+ -- No need to cancel the waiter thread.+ pure ()
+ src/Feedback/Loop.hs view
@@ -0,0 +1,146 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Feedback.Loop where++import Control.Monad+import qualified Data.Text as T+import Data.Word+import Feedback.Common.OptParse+import Feedback.Common.Output+import Feedback.Common.Process+import Feedback.Loop.Filter+import Feedback.Loop.OptParse+import GHC.Clock (getMonotonicTimeNSec)+import Path+import Path.IO+import System.Exit+import System.FSNotify as FS+import System.IO (hGetChar)+import System.Mem (performGC)+import Text.Colour+import Text.Colour.Capabilities.FromEnv (getTerminalCapabilitiesFromEnv)+import UnliftIO++runFeedbackLoop :: IO ()+runFeedbackLoop = do+ -- 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+ deriving (Show, Eq)++processWorker :: RunSettings -> Chan FS.Event -> Chan Output -> IO ()+processWorker runSettings eventChan outputChan = do+ let sendOutput = writeChan outputChan+ -- Record starting time+ start <- getMonotonicTimeNSec+ -- Start process+ processHandle <- startProcessHandle runSettings+ -- Output that the process has started+ sendOutput $ OutputProcessStarted runSettings++ -- So we don't need idle gc+ performGC++ -- 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++waitForEvent :: Chan FS.Event -> IO RestartEvent+waitForEvent eventChan = do+ isTerminal <- hIsTerminalDevice stdin+ if isTerminal+ then do+ hSetBuffering stdin NoBuffering+ either id id+ <$> race+ (StdinEvent <$> hGetChar stdin)+ (FSEvent <$> readChan eventChan)+ else FSEvent <$> readChan eventChan++data Output+ = 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
+ src/Feedback/Loop/Filter.hs view
@@ -0,0 +1,113 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Feedback.Loop.Filter where++import Data.Conduit+import qualified Data.Conduit.Combinators as C+import Data.List+import Data.Maybe+import Data.Set+import qualified Data.Set as S+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import Feedback.Common.OptParse+import Path+import Path.IO+import System.Exit+import System.FSNotify as FS+import System.Process.Typed as Typed+import UnliftIO++getStdinFiles :: Path Abs Dir -> IO (Maybe (Set FilePath))+getStdinFiles here = do+ isTerminal <- hIsTerminalDevice stdin+ if isTerminal+ 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++gitLsFiles :: Path Abs Dir -> IO (Maybe (Set FilePath))+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)++filesFromFindArgs :: Path Abs Dir -> String -> IO (Set FilePath)+filesFromFindArgs here args = do+ let processConfig = setStdout createPipe $ shell $ "find " <> args+ process <- startProcess processConfig+ ec <- waitExitCode process+ case ec of+ ExitFailure _ -> die $ "Find failed: " <> show ec+ ExitSuccess -> handleFileSet here (getStdout process)++handleFileSet :: Path Abs Dir -> Handle -> IO (Set FilePath)+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++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)+ ]++hiddenHere :: Path Abs Dir -> FilePath -> Bool+hiddenHere here filePath =+ (hidden <$> (parseAbsFile filePath >>= stripProperPrefix here)) /= Just False++hidden :: Path Rel File -> Bool+hidden = goFile+ where+ goFile :: Path Rel File -> Bool+ goFile f = isHiddenIn (parent f) f || goDir (parent f)+ goDir :: Path Rel Dir -> Bool+ goDir f+ | parent f == f = False+ | otherwise = isHiddenIn (parent f) f || goDir (parent f)++isHiddenIn :: Path b Dir -> Path b t -> Bool+isHiddenIn curdir ad =+ case stripProperPrefix curdir ad of+ Nothing -> False+ Just rp -> "." `isPrefixOf` toFilePath rp
+ src/Feedback/Loop/OptParse.hs view
@@ -0,0 +1,80 @@+{-# 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+import Feedback.Common.Output+import System.Exit+import Text.Colour+import Text.Colour.Layout+import Text.Colour.Term+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+ mLoopConfig <- case flagCommand of+ "" -> pure Nothing+ _ ->+ Just <$> case M.lookup flagCommand loops of+ Nothing -> do+ when (not (null loops)) $+ putStrLn $+ unwords+ [ "No loop found with name",+ show flagCommand <> ",",+ "interpreting it as a standalone command."+ ]+ pure $ makeLoopConfiguration $ CommandArgs flagCommand+ Just config -> do+ putStrLn $+ unwords+ [ "Interpreting",+ show flagCommand,+ "as the name of a configured loop."+ ]+ pure config+ case mLoopConfig of+ Nothing -> do+ putChunks $ intercalate ["\n"] $ prettyConfiguration mConf+ exitSuccess+ Just loopConfig -> do+ loopSets <-+ combineToLoopSettings+ flags+ environment+ (mConf >>= configOutputConfiguration)+ loopConfig+ when flagDebug $ pPrint loopSets+ pure loopSets++prettyConfiguration :: Maybe Configuration -> [[Chunk]]+prettyConfiguration mConf = case mConf of+ Nothing -> [[fore blue "No feedback loops have been configured here."]]+ Just conf ->+ [ [fore blue "The following feedback loops are available:"],+ [""],+ layoutAsTable+ ( map+ (uncurry loopConfigLine)+ (M.toList (configLoops conf))+ )+ ]++loopConfigLine :: String -> LoopConfiguration -> [Chunk]+loopConfigLine loopName LoopConfiguration {..} =+ [ loopNameChunk $ loopName <> ":",+ maybe "no description" (chunk . T.pack) loopConfigDescription+ ]
+ src/Feedback/Test.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Feedback.Test where++import Control.Monad+import qualified Data.Map as M+import Feedback.Common.OptParse+import Feedback.Common.Output+import Feedback.Common.Process+import Feedback.Test.OptParse+import GHC.Clock (getMonotonicTimeNSec)+import Text.Colour.Capabilities.FromEnv (getTerminalCapabilitiesFromEnv)++runFeedbackTest :: IO ()+runFeedbackTest = do+ TestSettings {..} <- getSettings+ terminalCapabilities <- getTerminalCapabilitiesFromEnv+ let put = putTimedChunks terminalCapabilities+ forM_ (M.toList testSettingLoops) $ \(loopName, LoopSettings {..}) -> do+ put [indicatorChunk "testing ", " ", loopNameChunk loopName]+ mapM_ put $ startingLines loopSettingRunSettings+ start <- getMonotonicTimeNSec+ ec <- startProcessAndWait loopSettingRunSettings+ end <- getMonotonicTimeNSec+ put $ exitCodeChunks ec+ let duration = end - start+ put $ durationChunks duration
+ src/Feedback/Test/OptParse.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE RecordWildCards #-}++module Feedback.Test.OptParse where++import Control.Monad+import Data.Map (Map)+import qualified Data.Map as M+import Feedback.Common.OptParse+import Text.Show.Pretty (pPrint)++getSettings :: IO TestSettings+getSettings = do+ flags <- getFlags+ env <- getEnvironment+ config <- getConfiguration flags env+ combineToTestSettings flags env config++data TestSettings = TestSettings+ { testSettingLoops :: !(Map String LoopSettings)+ }+ deriving (Show, Eq)++combineToTestSettings :: Flags -> Environment -> Maybe Configuration -> IO TestSettings+combineToTestSettings flags@Flags {..} environment mConf = do+ let filterFunc = case flagCommand of+ "" -> id+ _ -> M.filterWithKey (\k _ -> k == flagCommand)+ testSettingLoops <-+ traverse+ (combineToLoopSettings flags environment (mConf >>= configOutputConfiguration))+ (filterFunc $ maybe M.empty configLoops mConf)+ let testSets = TestSettings {..}+ when flagDebug $ pPrint testSets+ pure testSets