packages feed

feedback 0.1.0.5 → 0.2.0.0

raw patch · 7 files changed

+88/−81 lines, 7 files

Files

feedback.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           feedback-version:        0.1.0.5+version:        0.2.0.0 synopsis:       Declarative feedback loop manager homepage:       https://github.com/NorfairKing/feedback#readme bug-reports:    https://github.com/NorfairKing/feedback/issues
src/Feedback/Common/OptParse.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedLists #-}@@ -16,9 +15,7 @@ import Data.Maybe import qualified Data.Text as T 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 (pretty) import Path@@ -31,7 +28,7 @@     loopSettingOutputSettings :: !OutputSettings,     loopSettingHooksSettings :: !HooksSettings   }-  deriving (Show, Eq, Generic)+  deriving (Show)  combineToLoopSettings :: Flags -> Environment -> Maybe OutputConfiguration -> LoopConfiguration -> IO LoopSettings combineToLoopSettings Flags {..} Environment {} mDefaultOutputConfig LoopConfiguration {..} = do@@ -48,7 +45,7 @@     runSettingExtraEnv :: !(Map String String),     runSettingWorkingDir :: !(Maybe (Path Abs Dir))   }-  deriving (Show, Eq, Generic)+  deriving (Show)  combineToRunSettings :: RunConfiguration -> IO RunSettings combineToRunSettings RunConfiguration {..} = do@@ -61,7 +58,7 @@   { filterSettingGitignore :: !Bool,     filterSettingFind :: !(Maybe String)   }-  deriving (Show, Eq, Generic)+  deriving (Show)  combineToFilterSettings :: FilterConfiguration -> FilterSettings combineToFilterSettings FilterConfiguration {..} =@@ -72,7 +69,7 @@ data OutputSettings = OutputSettings   { outputSettingClear :: !Clear   }-  deriving (Show, Eq, Generic)+  deriving (Show)  combineToOutputSettings :: OutputFlags -> OutputConfiguration -> OutputSettings combineToOutputSettings OutputFlags {..} mConf =@@ -85,7 +82,7 @@   { hooksSettingBeforeAll :: Maybe RunSettings,     hooksSettingAfterFirst :: Maybe RunSettings   }-  deriving (Show, Eq, Generic)+  deriving (Show)  combineToHooksSettings :: HooksConfiguration -> IO HooksSettings combineToHooksSettings HooksConfiguration {..} = do@@ -97,8 +94,6 @@   { configLoops :: !(Map String LoopConfiguration),     configOutputConfiguration :: !(Maybe OutputConfiguration)   }-  deriving stock (Show, Eq, Generic)-  deriving (FromJSON, ToJSON) via (Autodocodec Configuration)  instance HasCodec Configuration where   codec =@@ -123,8 +118,7 @@     loopConfigOutputConfiguration :: !OutputConfiguration,     loopConfigHooksConfiguration :: !HooksConfiguration   }-  deriving stock (Show, Eq, Generic)-  deriving (FromJSON, ToJSON) via (Autodocodec LoopConfiguration)+  deriving (Eq)  instance HasCodec LoopConfiguration where   codec =@@ -192,8 +186,7 @@     runConfigExtraEnv :: !(Map String String),     runConfigWorkingDir :: !(Maybe FilePath)   }-  deriving stock (Show, Eq, Generic)-  deriving (FromJSON, ToJSON) via (Autodocodec RunConfiguration)+  deriving (Eq)  instance HasCodec RunConfiguration where   codec =@@ -234,8 +227,7 @@   { filterConfigGitignore :: !(Maybe Bool),     filterConfigFind :: !(Maybe String)   }-  deriving stock (Show, Eq, Generic)-  deriving (FromJSON, ToJSON) via (Autodocodec FilterConfiguration)+  deriving (Eq)  instance HasCodec FilterConfiguration where   codec =@@ -269,8 +261,7 @@ data OutputConfiguration = OutputConfiguration   { outputConfigClear :: !(Maybe Clear)   }-  deriving stock (Show, Eq, Generic)-  deriving (FromJSON, ToJSON) via (Autodocodec OutputConfiguration)+  deriving (Eq)  instance HasCodec OutputConfiguration where   codec =@@ -299,7 +290,7 @@   { hooksConfigurationBeforeAll :: !(Maybe RunConfiguration),     hooksConfigurationAfterFirst :: !(Maybe RunConfiguration)   }-  deriving (Show, Eq, Generic)+  deriving (Eq)  instance HasCodec HooksConfiguration where   codec =@@ -339,7 +330,6 @@ data Environment = Environment   { envConfigFile :: !(Maybe FilePath)   }-  deriving (Show, Eq, Generic)  getEnvironment :: IO Environment getEnvironment = Env.parse (Env.header "Environment") environmentParser@@ -386,13 +376,11 @@     flagConfigFile :: !(Maybe FilePath),     flagOutputFlags :: !OutputFlags   }-  deriving (Show, Eq, Generic)  data OutputFlags = OutputFlags   { outputFlagClear :: !(Maybe Clear),     outputFlagDebug :: Bool   }-  deriving (Show, Eq, Generic)  parseFlags :: OptParse.Parser Flags parseFlags =@@ -440,7 +428,7 @@       )  newtype Command = CommandScript {unScript :: String}-  deriving (Show, Eq, Generic)+  deriving (Show, Eq)  instance HasCodec Command where   codec = dimapCodec CommandScript unScript codec@@ -452,7 +440,7 @@     (requiredField "command" "the command to run on change (alias for 'script' for backward compatibility)")  data Clear = ClearScreen | DoNotClearScreen-  deriving (Show, Eq, Generic)+  deriving (Show, Eq)  instance HasCodec Clear where   codec = dimapCodec f g codec
src/Feedback/Common/Output.hs view
@@ -37,9 +37,6 @@ 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
src/Feedback/Loop.hs view
@@ -150,18 +150,7 @@    -- 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+  watchBasedOnFilter here watchManager eventChan f  #ifdef MIN_VERSION_safe_coloured_text_terminfo getTermCaps :: IO TerminalCapabilities@@ -174,7 +163,6 @@ data RestartEvent   = FSEvent !FS.Event   | StdinEvent !Char-  deriving (Show, Eq)  worker ::   ThreadId ->@@ -308,7 +296,6 @@   | OutputKilled   | OutputProcessStarted !RunSettings   | OutputProcessExited !ExitCode !Word64-  deriving (Show)  putOutput :: OutputSettings -> TerminalCapabilities -> ZonedTime -> Output -> IO () putOutput OutputSettings {..} terminalCapabilities loopBegin =
src/Feedback/Loop/Filter.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-}@@ -13,7 +14,10 @@ import qualified Data.Conduit.Combinators as C import qualified Data.Conduit.List as CL import Data.List-import Data.Set+import Data.Map (Map)+import qualified Data.Map as M+import Data.Maybe+import Data.Set (Set) import qualified Data.Set as S import qualified Data.Text as T import qualified Data.Text.Encoding as TE@@ -21,6 +25,7 @@ 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)@@ -36,29 +41,26 @@ getMinTTY = pure False #endif -data Filter = Filter-  { filterDirFilter :: Path Abs Dir -> Bool,-    filterFileFilter :: Path Abs File -> Bool-  }+data Filter+  = FilterWatchlist !(Set (Path Abs File))+  | FilterPredicate !(Path Abs Dir -> Bool) !(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-      }+  f1 <> f2 = case (f1, f2) of+    (FilterWatchlist s1, FilterWatchlist s2) -> FilterWatchlist (S.intersection s1 s2)+    (FilterWatchlist s, FilterPredicate dirPredicate filePredicate) ->+      FilterWatchlist $ S.filter filePredicate $ S.filter (dirPredicate . parent) s+    (FilterPredicate dirPredicate filePredicate, FilterWatchlist s) ->+      FilterWatchlist $ S.filter filePredicate $ S.filter (dirPredicate . parent) s+    (FilterPredicate dirPredicate1 filePredicate1, FilterPredicate dirPredicate2 filePredicate2) ->+      FilterPredicate (\d -> dirPredicate1 d && dirPredicate2 d) (\f -> filePredicate1 f && filePredicate2 f)  instance Monoid Filter where-  mempty = Filter {filterDirFilter = const True, filterFileFilter = const True}+  mempty = FilterPredicate (const True) (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)-        }+fileSetFilter = FilterWatchlist  mkCombinedFilter :: Path Abs Dir -> FilterSettings -> IO Filter mkCombinedFilter here filterSettings =@@ -94,13 +96,20 @@ gitLsFiles here = do   -- If there is no git directory, we'll get a 'fatal' message on stderr.   -- We don't need the user to see this, so we setStderr nullStream.-  let processConfig = setStderr nullStream $ shell "git ls-files"+  let processConfig = setStderr nullStream $ shell "git ls-files -z"   (ec, out) <- readProcessStdout processConfig-  set <- bytesFileSet here out+  set <- nullBytesFileSet here out   pure $ case ec of     ExitFailure _ -> Nothing     ExitSuccess -> Just set +nullBytesFileSet :: Path Abs Dir -> LB.ByteString -> IO (Set (Path Abs File))+nullBytesFileSet here lb =+  runConduit $+    CL.sourceList (LB8.split '\NUL' lb)+      .| C.map LB.toStrict+      .| fileSetBuilder here+ mkFindFilter :: Path Abs Dir -> FilterSettings -> IO Filter mkFindFilter here FilterSettings {..} = case filterSettingFind of   Nothing -> pure mempty@@ -110,13 +119,13 @@ filesFromFindArgs here args = do   let processConfig = setStdout createPipe $ shell $ "find " <> args   (ec, out) <- readProcessStdout processConfig-  set <- bytesFileSet here out+  set <- lineBytesFileSet here out   case ec of     ExitFailure _ -> die $ "Find failed: " <> show ec     ExitSuccess -> pure set -bytesFileSet :: Path Abs Dir -> LB.ByteString -> IO (Set (Path Abs File))-bytesFileSet here lb =+lineBytesFileSet :: Path Abs Dir -> LB.ByteString -> IO (Set (Path Abs File))+lineBytesFileSet here lb =   runConduit $     CL.sourceList (LB8.lines lb)       .| C.map LB.toStrict@@ -138,29 +147,54 @@  standardFilter :: Path Abs Dir -> Filter standardFilter here =-  Filter-    { filterDirFilter = not . isHiddenIn here,-      filterFileFilter = \f ->+  FilterPredicate+    (not . isHiddenIn here)+    ( \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-  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++watchBasedOnFilter :: Path Abs Dir -> WatchManager -> Chan FS.Event -> Filter -> IO StopListening+watchBasedOnFilter here watchManager eventChan = \case+  -- If we have a watchlist of all the, then we don't need to list any files.+  -- We just watch all the relevant directories.+  FilterWatchlist fileSet -> do+    let dirMap :: Map (Path Abs Dir) (Set (Path Rel File))+        dirMap =+          M.unionsWith S.union $+            map (\f -> M.singleton (parent f) (S.singleton (filename f))) $+              S.toList fileSet+        subdirPredicate :: Path Abs Dir -> Set (Path Rel File) -> Event -> Bool+        subdirPredicate subdir subFileSet e = fromMaybe False $ do+          absFile <- parseAbsFile $ eventPath e+          relFile <- stripProperPrefix subdir absFile+          pure $ S.member relFile subFileSet+        watchSubdir :: Path Abs Dir -> Set (Path Rel File) -> IO StopListening+        watchSubdir subdir subFileSet = do+          watchDirChan watchManager (fromAbsDir subdir) (subdirPredicate subdir subFileSet) eventChan+    mconcat <$> mapM (uncurry watchSubdir) (M.toList dirMap)+  -- If we use a predicate then we have no choice but to walk the directory tree.+  FilterPredicate dirPredicate filePredicate ->+    let descendHandler :: Path Abs Dir -> [Path Abs Dir] -> [Path Abs File] -> IO (WalkAction Abs)+        descendHandler dir subdirs _ =+          pure $+            WalkExclude $+              -- Don't descend into directories that are not in the filter, so we don't spend time listing them.+              filter (not . dirPredicate) $+                -- Don't descent into hidden directories+                filter (isHiddenIn dir) subdirs+        outputWriter :: Path Abs Dir -> [Path Abs Dir] -> [Path Abs File] -> IO StopListening+        outputWriter dir _ _ = do+          let eventFilter fsEvent = maybe False filePredicate $ parseAbsFile (eventPath fsEvent)+          watchDirChan watchManager (fromAbsDir dir) eventFilter eventChan+     in walkDirAccum (Just descendHandler) outputWriter here
src/Feedback/Loop/OptParse.hs view
@@ -70,7 +70,7 @@       [""],       layoutAsTable         ( map-            (uncurry loopConfigLine)+            (pure . uncurry loopConfigLine)             (M.toList (configLoops conf))         ),       [fore blue "Run ", fore yellow "feedback loopname", fore blue " to activate a feedback loop."]@@ -78,6 +78,7 @@  loopConfigLine :: String -> LoopConfiguration -> [Chunk] loopConfigLine loopName LoopConfiguration {..} =-  [ loopNameChunk $ loopName <> ":",+  [ loopNameChunk loopName,+    ": ",     maybe "no description" (chunk . T.pack) loopConfigDescription   ]
src/Feedback/Test/OptParse.hs view
@@ -18,7 +18,7 @@ data TestSettings = TestSettings   { testSettingLoops :: !(Map String LoopSettings)   }-  deriving (Show, Eq)+  deriving (Show)  combineToTestSettings :: Flags -> Environment -> Maybe Configuration -> IO TestSettings combineToTestSettings flags@Flags {..} environment mConf = do