packages feed

multidir (empty) → 0.1.0.0

raw patch · 17 files changed

+1301/−0 lines, 17 filesdep +HUnitdep +basedep +cond

Dependencies added: HUnit, base, cond, containers, directory, filepath, filepattern, hspec, multidir, optparse-applicative, process, text, toml-reader

Files

+ CHANGELOG.md view
@@ -0,0 +1,11 @@+# Changelog for `multidir`++All notable changes to this project will be documented in this file.++The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/),+and this project adheres to the+[Haskell Package Versioning Policy](https://pvp.haskell.org/).++## Unreleased++## 0.1.0.0 - YYYY-MM-DD
+ LICENSE view
@@ -0,0 +1,28 @@+BSD 3-Clause License++Copyright (c) 2025, James Cranch++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this+   list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright notice,+   this list of conditions and the following disclaimer in the documentation+   and/or other materials provided with the distribution.++3. Neither the name of the copyright holder nor the names of its+   contributors may be used to endorse or promote products derived from+   this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,197 @@+# Multidir ("`muld`"): run tasks in multiple directories++This application exists to run tasks in several directories+sequentially. The motivating use is to view the status of, or fetch+remote changes to, multiple version control repositories.++The design differs from some other superficially similar applications+in that it is designed to be flexible: if you maintain a set of+repositories using several different version control systems,+requiring completely different commands to achieve analogous ends in+each directory, one can easily do so (and, in particular, there is no+built-in git-centric behaviour).++## Getting started (without explanations)++1. Clone the repository, and run `stack install` in it.+2. Copy `tasks.toml` and `recipes.toml` from `examples/` to+   `~/.config/muld/`.+3. Run `muld discover` on the directory containing all your projects.+4. Inspect `~/.config/muld/projs.toml` by hand to remove anything+   unwanted, and to add extra tags as desired.+5. Now you can run `muld status`, and `muld fetch` to fetch changes.++Steps 1 and 2 above can be replaced by:++1. Run `cabal update` and `cabal install multidir`.+2. Copy and paste `tasks.toml` and `recipes.toml` from the repository+   on Github to `~/.config/muld`.++## Getting started (with explanations)++You can build it from source by cloning the repository and running+`stack install` in it. This of course requires you to have [installed+Haskell/stack](https://www.haskell.org/ghcup/).++Configuration consists of providing three+[TOML](https://toml.io/en/v1.0.0) files:++* `projs.toml` lists the directories to be acted upon (together with+  tags which classify them).++* `tasks.toml` lists the tasks which may be run upon those+  directories, and explains how to do them; differing implementations+  can be given for differing tags.++* `recipes.toml` is used for autodiscovery; it contains instructions+  on what makes a directory suitable for discovery.++Vaguely useful samples of `recipes.toml` and `tasks.toml` can be found+in the `examples/` directory and copied in. Once `recipes.toml` is in+place, one can generate a `projs.toml` by running `muld discover` (see+below).++These configuration files are each searched for in the following+order:++1. Their locations can be supplied on the command-line (see below);+2. Failing that, their locations are deduced from the environment+   variables `$MULD_TASK_FILE` `$MULD_PROJ_FILE` and+   `$MULD_RECIPE_FILE`, if set;+3. Failing that, their locations are taken as `tasks.toml`,+   `projs.toml` and `recipes.toml` in `$XDG_CONFIG_HOME/muld` (if that+   environment variable is set);+4. Failing that, their locations are taken as `tasks.toml`,+   `projs.toml` and `recipes.toml` in `$HOME/.config/muld` (if that+   environment variable is set);+5. Failing that, an error is raised.++For most users, steps 3 and 4 have the same results.++## Command-line syntax++The following commands are built in. In every case there is+command-line assistance (type `muld COMMAND --help`):++* `muld discover` finds all subdirectories of the given directory+  matching the patterns in `recipes.toml`, and adds them to+  `projs.toml`.++* `muld register` adds the given directory to `projs.toml`.++* `muld list` lists the directories in `projs.toml`.++* `muld run` runs a supplied command in every directory.++* `muld where` list the locations of config files (useful for+  debugging, perhaps).++In addition, every task in `tasks.toml` gives another command which+can be called; that task is run in every directory.++## Selecting directories++Those commands listed above which operate on a collection of+directories (`list`, `run` and the task commands) can be put to work+on a user-defined set of directories. By default, it is those with the+`default` tag, but this can be adjusted using the `-s` flag.++The syntax is as follows:++* `muld list -s important` will list those repositories with the+  `important` tag;++* `muld list -s {/home/fred}` will list those repositories which are+  under `/home/fred`;++* these can be combined with the binary operators `&` (and), `|` (or)+  and, `\` (difference). Hence `muld list -s important\scary` will+  list the repositories which are `important` but not `scary`;++* parentheses are permitted for complex expressions;++* for ease, if a specification starts with an operator, it is treated+  as though `default` was specified first. So `muld list -s+  &interesting` lists the directories which are both `default` and+  `interesting`.++There is an `all` tag, which by default is added to all+repositories. One can remove the `all` tag from a repository, if+desired, but maybe that's not a very good idea.++## Defining tasks++User-defined tasks are in `tasks.toml`. They are listed by name, and+by what tag they operate on (allowing the same task to be run+differently for different types of directory).++The rule is that, for each directory, the tags are gone through in+order; the first tag with an implementation for that task is the one+which is used.++Here's an example:++    [fetch]+    description = "Downloads changes"+    [fetch.git]+    run = "git -c color.ui=always fetch"+    [fetch.jj]+    run = "TERM=xterm-color jj git fetch"++This defines a task which can be run on any directory with tags `git`+or `jj`.++## Defining recipes++Recipes for registering directories are in `recipes.toml`. Each recipe+consists of:++* the files required to trigger that recipe;++* the tags added if that recipe is triggered;++* the `discover` flag (which defaults to `True`) which says whether+  this recipe is enough on its own to discover a directory (or merely+  add extra tags to it if discovered for other reasons).++## General advice++In most setups, the default shell is not a login shell (`dash` rather+than `bash` under Debian, for example), and has not had read `.bashrc`+or anything. Hence one might need to be careful in defining tasks:++* specifying paths exactly if they're in `$PATH` in a login shell but+  not in the default shell;++* reassuring processes that they're okay to assume colour features for+  output (for example, prefacing jujutsu commands with+  `TERM=xterm-color`, and replacing `git` with `git -c+  color.ui=always`).++## Prior art++There are many other applications which do vaguely similar jobs. Examples+include:++* [Mani](https://alajmovic.com/posts/many-repo-cli-tool-in-go/) is+  heavyweight, fairly git-centric, and written in go.++* [Myrepos](https://myrepos.branchable.com/) is nice, but old and+  unloved; it is written in javascript for node.js.++## Development++The projects in [TODO.md](TODO.md) are probably all achievable, and I+will do them when I can be bothered (or when someone else can be+bothered).++I'd be happy to take suggestions for extra recipes or extra+implementations of tasks. I'm happy to take suggestions of extra tasks+(and if they're a bit specialist in nature, I may start a new+directory containing suggestions for more niche tasks).++Several of the other available applications support parallelism, which+we don't (at least not yet, and it's not high on my list of+priorities).++Bug reports are very welcome (just email me); there probably are some!
+ app/Main.hs view
@@ -0,0 +1,96 @@+module Main (main) where++import Multidir.Commands.Discover (parseArgsDiscover)+import Multidir.Commands.List (parseArgsList)+import Multidir.Commands.Register (parseArgsRegister)+import Multidir.Commands.Run (parseArgsRun)+import Multidir.Commands.Where (parseArgsWhere)+import Multidir.ReadConfig+import Multidir.RunTask (taskParser)+import Options.Applicative+import System.Directory (getCurrentDirectory)+++data Config = Config {+  configProjs :: Maybe String,+  configTasks :: Maybe String,+  configOtherArgs :: [String]+}++projsOption :: Parser (Maybe String)+projsOption = option (Just <$> str) (+  long "projs" <>+  short 'P' <>+  metavar "TOML" <>+  value Nothing <>+  help "Location of projects .toml file")++tasksOption :: Parser (Maybe String)+tasksOption = option (Just <$> str) (+  long "tasks" <>+  short 'T' <>+  metavar "TOML" <>+  value Nothing <>+  help "Location of tasks .toml file")++-- | The first phase of the argument parsing: are there instructions+-- on where to find the config files?+-- We search for the config files in the following order:+-- 1. from the command line+-- 2. from the environment variables+-- 3. from .config/multidir+parseConfig :: ParserInfo Config+parseConfig = let++  configParser = liftA3 Config projsOption tasksOption (many (strArgument mempty))++  information =+    progDesc "This message should not be seen" <>+    forwardOptions++  in info configParser information+++parseArgs :: FilePath -> Tasks -> FilePath -> Projs -> FilePath -> ParserInfo (IO ())+parseArgs _tasksFile tasks projsFile projs wd = let++  -- --help option (needed at least if running via Stack, harmless otherwise I think)+  helpOption :: Parser (a -> a)+  helpOption =+    abortOption (ShowHelpText Nothing) (+      long "help" <>+      short 'h' <>+      help "Show this help text")++  information =+    fullDesc <>+    progDesc "Run commands in multiple directories"++  commands =+    command "discover" (parseArgsDiscover wd projsFile) <>+    command "list" (parseArgsList projs wd) <>+    command "register" (parseArgsRegister wd projsFile) <>+    command "run" (parseArgsRun projs wd) <>+    command "where" parseArgsWhere++  parser =+    projsOption *> -- this is only for the help text+    tasksOption *> -- this is only for the help text+    helpOption <*>+    (hsubparser commands <|> taskParser tasks projs wd)++  in info parser information+++main :: IO ()+main = do+  wd <- getCurrentDirectory+  conf <- execParser parseConfig+  tasksFile <- tasksFilename $ configTasks conf+  tasks <- readTasks tasksFile+  projsFile <- projsFilename $ configProjs conf+  projs <- readProjs projsFile+  let remainingArgs = configOtherArgs conf+  let parser = parseArgs tasksFile tasks projsFile projs wd+  go <- handleParseResult $ execParserPure defaultPrefs parser remainingArgs+  go
+ multidir.cabal view
@@ -0,0 +1,108 @@+cabal-version: 2.2++-- This file has been generated from package.yaml by hpack version 0.37.0.+--+-- see: https://github.com/sol/hpack++name:           multidir+version:        0.1.0.0+synopsis:       Simple tool for running commands in multiple directories+description:    Please see the README on GitHub at <https://github.com/jcranch/multidir#README>+category:       Command Line Tools+homepage:       https://github.com/jcranch/multidir#readme+bug-reports:    https://github.com/jcranch/multidir/issues+author:         James Cranch+maintainer:     cranch@cantab.net+copyright:      James Cranch 2025+license:        BSD-3-Clause+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    CHANGELOG.md++source-repository head+  type: git+  location: https://github.com/jcranch/multidir++library+  exposed-modules:+      Multidir.Commands.Discover+      Multidir.Commands.List+      Multidir.Commands.Register+      Multidir.Commands.Run+      Multidir.Commands.Where+      Multidir.Iterate+      Multidir.ReadConfig+      Multidir.RunTask+      Multidir.Selection+      TOML.Decode.Extra+  other-modules:+      Paths_multidir+  autogen-modules:+      Paths_multidir+  hs-source-dirs:+      src+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -fprint-potential-instances -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -Wwarn=missing-home-modules+  build-depends:+      base >=4.7 && <5+    , cond ==0.5.*+    , containers ==0.7.*+    , directory ==1.3.*+    , filepath ==1.5.*+    , filepattern >=0.1.3 && <0.2+    , optparse-applicative >=0.18.1 && <0.19+    , process ==1.6.*+    , text ==2.1.*+    , toml-reader >=0.2.1 && <0.3+  default-language: Haskell2010++executable muld+  main-is: Main.hs+  other-modules:+      Paths_multidir+  autogen-modules:+      Paths_multidir+  hs-source-dirs:+      app+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      base >=4.7 && <5+    , cond ==0.5.*+    , containers ==0.7.*+    , directory ==1.3.*+    , filepath ==1.5.*+    , filepattern >=0.1.3 && <0.2+    , multidir+    , optparse-applicative >=0.18.1 && <0.19+    , process ==1.6.*+    , text ==2.1.*+    , toml-reader >=0.2.1 && <0.3+  default-language: Haskell2010++test-suite Muld-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Multidir.SelectionSpec+      Paths_multidir+  autogen-modules:+      Paths_multidir+  hs-source-dirs:+      test+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -Wwarn=missing-home-modules -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      HUnit ==1.6.*+    , base >=4.7 && <5+    , cond ==0.5.*+    , containers ==0.7.*+    , directory ==1.3.*+    , filepath ==1.5.*+    , filepattern >=0.1.3 && <0.2+    , hspec >=2.7 && <2.12+    , multidir+    , optparse-applicative >=0.18.1 && <0.19+    , process ==1.6.*+    , text ==2.1.*+    , toml-reader >=0.2.1 && <0.3+  default-language: Haskell2010
+ src/Multidir/Commands/Discover.hs view
@@ -0,0 +1,87 @@+-- | Search for repositories+module Multidir.Commands.Discover (+  parseArgsDiscover,+  ) where++import Data.Foldable (traverse_)+import Data.Maybe (fromMaybe)+import Multidir.Commands.Register (investigate, writeProj)+import Multidir.ReadConfig+import Options.Applicative+import System.Directory (doesDirectoryExist, listDirectory, pathIsSymbolicLink)+import System.FilePath ((</>))+++discoverWith :: Recipes -> FilePath -> Bool -> Projs -> FilePath -> IO ()+discoverWith recipes target includeHidden alreadyKnown = let++  visible ('.':_) = includeHidden+  visible _ = True++  inner dir = do++    b <- doesDirectoryExist dir+    c <- if b then not <$> pathIsSymbolicLink dir else pure False+    if c && not (isProj dir alreadyKnown)+      then do+        (tags, discovered) <- investigate dir recipes+        if discovered+          then do+            putStrLn dir+            putStrLn ("  " <> show tags)+            putStrLn ""+            writeProj dir tags target+          else do+            traverse_ (inner . (dir </>)) . filter visible =<< listDirectory dir+      else do+        pure ()++  in inner+++discover :: Maybe FilePath -> FilePath -> Bool -> Bool -> FilePath -> IO ()+discover recipesDir target includeHidden rediscover startDir = do+  recipes <- readRecipes =<< recipesFilename recipesDir+  alreadyKnown <- if rediscover+    then pure emptyProjs+    else readProjs target+  discoverWith recipes target includeHidden alreadyKnown startDir+++parseArgsDiscover :: FilePath -> FilePath -> ParserInfo (IO ())+parseArgsDiscover wd projsFile = let++  information = progDesc "Search for project directories"++  recipesOpt = option (Just <$> str) (+    long "recipes" <>+    short 'R' <>+    metavar "TOML" <>+    value Nothing <>+    help "Location of recipes .toml file")++  dirArgument = strArgument (+    metavar "DIR" <>+    help "Directory to add")++  dirArgumentOpt = fromMaybe wd <$> optional dirArgument++  targetOption = strOption (+    long "output" <>+    short 'o' <>+    help "File to write to (if not config file)" <>+    value projsFile)++  includeHiddenSwitch = switch (+    long "include-all" <>+    short 'i' <>+    help "Include hidden directories")++  rediscoverSwitch = switch (+    long "rediscover" <>+    short 'r' <>+    help "Discover even if already listed")++  parser = discover <$> recipesOpt <*> targetOption <*> includeHiddenSwitch <*> rediscoverSwitch <*> dirArgumentOpt++  in info parser information
+ src/Multidir/Commands/List.hs view
@@ -0,0 +1,18 @@+module Multidir.Commands.List (+  parseArgsList,+  ) where++import Data.Foldable (traverse_)+import Multidir.ReadConfig+import Multidir.Selection (Selection, applySelection, optSelection)+import Options.Applicative+++runList :: Projs -> FilePath -> Selection -> IO ()+runList projs wd f = traverse_ (putStrLn . projDir) . getProjs $ applySelection f wd projs++parseArgsList :: Projs -> FilePath -> ParserInfo (IO ())+parseArgsList projs wd = let+  information = progDesc "List directories"+  parser = runList projs wd <$> optSelection+  in info parser information
+ src/Multidir/Commands/Register.hs view
@@ -0,0 +1,105 @@+-- | Add a repository+module Multidir.Commands.Register (+  investigate,+  writeProj,+  parseArgsRegister,+  ) where++import Data.Foldable (foldlM)+import Data.Maybe (fromMaybe)+import qualified Data.Set as S+import Data.Text (Text)+import Multidir.ReadConfig+import Options.Applicative+import System.Directory (doesPathExist, makeAbsolute)+import System.Exit (exitFailure)+import System.FilePath ((</>))+import System.FilePattern.Directory+++andM :: Monad m => (a -> m Bool) -> [a] -> m Bool+andM _ [] = pure True+andM f (x:xs) = do+  a <- f x+  if a then andM f xs else pure False+++-- | A common base for the registering/discovering functionality+-- Returns tags, and whether it was worthy of being discovered.+investigate :: FilePath -> Recipes -> IO ([Text], Bool)+investigate fp = let++  matchGlob :: FilePattern -> IO Bool+  matchGlob g = not . null <$> getDirectoryFiles fp [g]++  matchFile :: String -> IO Bool+  matchFile f = doesPathExist (fp </> f)++  new [] x (tagList, tagSet, discovered) = (tagList, tagSet, discovered || x)+  new (t:ts) x (tagList, tagSet, discovered)+    | S.member t tagSet = new ts x (tagList, tagSet, discovered)+    | otherwise = new ts x (t:tagList, S.insert t tagSet, discovered)++  try d m = do+    b <- liftA2 (&&) (andM matchFile (recipeFiles m)) (andM matchGlob (recipeGlobs m))+    pure $ if b+      then new (recipeTags m) (recipeDiscover m) d+      else d++  finalise (tagList, _, discovered) = (reverse tagList, discovered)++  in fmap finalise . foldlM try ([], S.empty, False) . getRecipes+++writeProj :: FilePath -> [Text] -> FilePath -> IO ()+writeProj dir tags target = appendFile target (+  "[" <> show dir <> "]\n" <>+  "tags = " <> show tags <> "\n\n")+++register :: Bool -> Maybe FilePath -> FilePath -> FilePath -> IO ()+register force recipesDir rawDir target = do+  dir <- makeAbsolute rawDir+  recipes <- readRecipes =<< recipesFilename recipesDir+  (tags, discover) <- investigate dir recipes+  if force || discover+    then do+      putStrLn (show tags)+      writeProj dir tags target+    else do+      putStrLn "Nothing to register"+      exitFailure+++parseArgsRegister :: FilePath -> FilePath -> ParserInfo (IO ())+parseArgsRegister wd projsFile = let++  information = progDesc "Add a project directory"++  forceSwitch = switch (+    long "force" <>+    short 'f' <>+    help "Add even if we wouldn't normally add such a directory")++  recipesOpt = option (Just <$> str) (+    long "recipes" <>+    short 'R' <>+    metavar "TOML" <>+    value Nothing <>+    help "Location of recipes .toml file")++  dirArgument = strArgument (+    metavar "DIR" <>+    help "Directory to add")++  dirArgumentOpt = fromMaybe wd <$> optional dirArgument++  targetOption = strOption (+    long "output" <>+    short 'o' <>+    help "File to write to (if not config file)" <>+    value projsFile)++  parser = register <$> forceSwitch <*> recipesOpt <*> dirArgumentOpt <*> targetOption++  in info parser information
+ src/Multidir/Commands/Run.hs view
@@ -0,0 +1,47 @@+-- | Run an arbitrary command+--+-- Also used by RunTask+module Multidir.Commands.Run (+  runString,+  runStrings,+  parseArgsRun,+  ) where++import qualified Data.Map.Strict as M+import Multidir.Iterate (onAll)+import Multidir.ReadConfig+import Multidir.Selection (applySelection, optSelection)+import Options.Applicative+import System.Exit (ExitCode(..))+import System.Process+++runString :: String -> Proj -> IO Bool+runString s p = do+  let c = (shell s) {+    cwd = Just $ projDir p,+    env = Just . M.assocs $ projEnv p+  }+  (_, _, _, h) <- createProcess c+  x <- waitForProcess h+  putStrLn ""+  pure $ case x of+    ExitSuccess -> True+    ExitFailure _ -> False++runStrings :: [String] -> Proj -> IO Bool+runStrings [] _ = pure True+runStrings (s:t) p = do+  f <- runString s p+  if f+    then runStrings t p+    else pure False++parseArgsRun :: Projs -> FilePath -> ParserInfo (IO ())+parseArgsRun projs wd = let+  information = progDesc "Run a shell script in each directory"+  argCommand = strArgument (+    metavar "SHELLSCRIPT")+  run s f = onAll (runString s) (applySelection f wd projs)+  parser = liftA2 run argCommand optSelection+  in info parser information
+ src/Multidir/Commands/Where.hs view
@@ -0,0 +1,21 @@+module Multidir.Commands.Where (+  parseArgsWhere,+  ) where++import Multidir.ReadConfig+import Options.Applicative+++runWhere :: IO ()+runWhere = do+  putStr "tasks:   "+  putStrLn =<< tasksFilename Nothing+  putStr "projs:   "+  putStrLn =<< projsFilename Nothing+  putStr "recipes: "+  putStrLn =<< recipesFilename Nothing++parseArgsWhere :: ParserInfo (IO ())+parseArgsWhere = let+  information = progDesc "Show location of config files"+  in info (pure runWhere) information
+ src/Multidir/Iterate.hs view
@@ -0,0 +1,44 @@+module Multidir.Iterate (+  onAll,+  ) where++import Data.Monoid (Ap(..))+import Multidir.ReadConfig+++data Results = Results {+  attempts :: Int,+  fails :: Int+}++instance Semigroup Results where+  Results a1 f1 <> Results a2 f2 = Results (a1 + a2) (f1 + f2)++instance Monoid Results where+  mempty = Results 0 0++result :: Bool -> Results+result b = Results {+  attempts = 1,+  fails = if b then 0 else 1+}++reportResults :: Results -> IO ()+reportResults r = let+  f 0 = "all successful"+  f 1 = "1 failure"+  f n = show n <> " failures"+  in putStrLn ("finished: " <> show (attempts r) <> " directories, " <> f (fails r))++-- | Announce the repository+onOne :: (Proj -> IO Bool) -> Proj -> IO Results+onOne f p = do+  putStrLn (projDir p)+  result <$> f p++-- | Takes a function which operates on a project, returning+-- success/failure+onAll :: (Proj -> IO Bool) -> Projs -> IO ()+onAll f (Projs l) = do+  r <- getAp $ foldMap (Ap . onOne f) l+  reportResults r
+ src/Multidir/ReadConfig.hs view
@@ -0,0 +1,202 @@+{-# LANGUAGE GeneralisedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}++module Multidir.ReadConfig (++  Specification(..),++  Task(..),+  Tasks(..),+  tasksFilename,+  readTasks,+  emptyTasks,+  +  Proj(..),+  Projs(..),+  projsFilename,+  readProjs,+  isProj,+  emptyProjs,++  Recipe(..),+  Recipes(..),+  recipesFilename,+  readRecipes,+  emptyRecipes,+  ) where++import Control.Exception (IOException, catch)+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as M+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.IO as T+import System.Environment (lookupEnv)+import System.Exit (exitFailure)+import System.FilePath ((</>))+import TOML.Decode+import TOML.Decode.Extra+import TOML.Error+import TOML.Value+++data Specification = Specification {+  specCommand :: String,+  specEnv :: Map String String+}++instance DecodeTOML Specification where+  tomlDecoder = decodeTableWith $ \t -> do+    (t', e) <- removeFieldOpt "env" t+    (_, r) <- removeField "run" t'+    pure $ Specification {+      specCommand = r,+      specEnv = fromMaybe M.empty e+    }+++data Task = Task {+  taskDescription :: Maybe Text,+  taskSpecByTag :: Map Text Specification+}++instance DecodeTOML Task where+  tomlDecoder = decodeTableWith $ \t -> do+    (t', description) <- removeFieldOptWith tomlDecoder "description" t+    byTag <- processTableValuesWith tomlDecoder t'+    pure $ Task {+      taskDescription = description,+      taskSpecByTag = byTag+    }++newtype Tasks = Tasks {+  byTask :: Map Text Task+}++emptyTasks :: Tasks+emptyTasks = Tasks mempty+++instance DecodeTOML Tasks where+  tomlDecoder = Tasks <$> getTableOf tomlDecoder+++data Proj = Proj {+  projDir :: FilePath,+  projTags :: [Text],+  projEnv :: Map String String+} deriving (Show)+++newtype Projs = Projs {+  getProjs :: [Proj]+}++emptyProjs :: Projs+emptyProjs = Projs mempty++isProj :: FilePath -> Projs -> Bool+isProj p = any ((== p) . projDir) . getProjs+++decodeProj :: Text -> Table -> DecodeM Proj+decodeProj n t = do++  -- Pull out the "tags" field+  (t', l) <- removeFieldOptWith tomlDecoder "tags" t++  -- The remaining fields are config+  c <- processTableValuesWith tomlDecoder t'++  pure $ Proj {+    projDir = T.unpack n,+    projTags = fromMaybe [] l,+    projEnv = M.mapKeys T.unpack c+  }+++instance DecodeTOML Projs where+  tomlDecoder = let+    f (n, t) = addContextItem (Key n) $ decodeTableWithM (decodeProj n) t+    in decodeTableWith (fmap Projs . traverse f . M.assocs)+++data Recipe = Recipe {+  recipeTags :: [Text],+  recipeFiles :: [String],+  recipeGlobs :: [String],+  recipeDiscover :: Bool+} deriving (Show)++instance DecodeTOML Recipe where+  tomlDecoder = Recipe <$>+    getField "tags" <*>+    (fromMaybe [] <$> getFieldOpt "files") <*>+    (fromMaybe [] <$> getFieldOpt "globs") <*>+    (fromMaybe True <$> getFieldOpt "discover")++newtype Recipes = Recipes {+  getRecipes :: [Recipe]+} deriving (Show)++instance DecodeTOML Recipes where+  tomlDecoder = Recipes <$> getField "recipes"++emptyRecipes :: Recipes+emptyRecipes = Recipes []++++-- | Decode filename+-- Returns `Nothing` if file not found+decodeFileIfFound :: DecodeTOML a => FilePath -> IO (Maybe (Either TOMLError a))+decodeFileIfFound p = let+  toml = fmap Just (T.readFile p) `catch` (\e -> const (pure Nothing) (e :: IOException))+  in fmap decode <$> toml+++-- | Decode filename; exits in case of error, uses default in case of file not found+decodeFileWithDefault :: DecodeTOML a => a -> FilePath -> IO a+decodeFileWithDefault d p = do+  a <- decodeFileIfFound p+  case a of+    Just (Left e) -> do+      putStrLn ("Error in " <> p <> ": " <> show e)+      exitFailure+    Nothing -> pure d+    Just (Right x) -> pure x+++infixr 2 <||>+-- | An idiom for "failing that"+(<||>) :: Monad m => m (Maybe a) -> m a -> m a+u <||> v = maybe v pure =<< u+  ++getConfigFilename :: FilePath -> String -> Maybe FilePath -> IO FilePath+getConfigFilename fileName envVar fromArgs = let+  fromEnv = lookupEnv envVar+  fromXDG = fmap ((</> fileName) . (</> "muld")) <$> lookupEnv "XDG_CONFIG_HOME"+  fromHome = fmap ((</> fileName) . (</> ".config/muld")) <$> lookupEnv "HOME"+  stuck = pure $ error "Don't know where to find config filename"+  in pure fromArgs <||> fromEnv <||> fromXDG <||> fromHome <||> stuck++tasksFilename :: Maybe FilePath -> IO FilePath+tasksFilename = getConfigFilename "tasks.toml" "MULD_TASK_FILE"++projsFilename :: Maybe FilePath -> IO FilePath+projsFilename = getConfigFilename "projs.toml" "MULD_PROJ_FILE"++recipesFilename :: Maybe FilePath -> IO FilePath+recipesFilename = getConfigFilename "recipes.toml" "MULD_RECIPE_FILE"+++readTasks :: FilePath -> IO Tasks+readTasks = decodeFileWithDefault emptyTasks++readProjs :: FilePath -> IO Projs+readProjs = decodeFileWithDefault emptyProjs++readRecipes :: FilePath -> IO Recipes+readRecipes = decodeFileWithDefault emptyRecipes
+ src/Multidir/RunTask.hs view
@@ -0,0 +1,55 @@+-- | Run a task+module Multidir.RunTask (+  runTask,+  taskParser,+  ) where++import qualified Data.Map.Strict as M+import qualified Data.Text as T+import Multidir.Commands.Run (runString)+import Multidir.Iterate (onAll)+import Multidir.ReadConfig+import Multidir.Selection (applySelection, optSelection)+import Options.Applicative+++getSpec :: Task -> Proj -> Maybe Specification+getSpec t p = let+  inner [] = Nothing+  inner (x:xs) = case M.lookup x (taskSpecByTag t) of+    Just s -> Just s+    Nothing -> inner xs+  in inner (projTags p)+++-- | Add extra environment from the Specification into the Proj+withExtraEnv :: Specification -> Proj -> Proj+withExtraEnv s p = p {+  projEnv = M.union (projEnv p) (specEnv s)+  }+++runTask :: Task -> Proj -> IO Bool+runTask t p = case getSpec t p of+  Nothing -> False <$ putStrLn "No specification"+  Just s -> runString (specCommand s) (withExtraEnv s p)+++taskParser :: Tasks -> Projs -> FilePath -> Parser (IO ())+taskParser tasks projs wd = let++  taskCommand c t = let++    run f = onAll (runTask t) (applySelection f wd projs)++    parser = run <$> optSelection++    information = case taskDescription t of+      Just d -> progDesc $ T.unpack d+      Nothing -> mempty++    in command (T.unpack c) $ info parser information++  in hsubparser (M.foldMapWithKey taskCommand (byTask tasks) <>+                 commandGroup "User-defined commands:" <>+                 hidden)
+ src/Multidir/Selection.hs view
@@ -0,0 +1,125 @@+{-# LANGUAGE GeneralisedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}++-- | A group of directories to work on+module Multidir.Selection (+  Selection(..),+  applySelection,+  optSelection,+  parseSelection,+  ) where++import Prelude hiding ((&&), (||), not)+import Data.Algebra.Boolean+import Data.Bifunctor (first)+import Data.Char (isAlphaNum)+import Data.List (isPrefixOf)+import Data.Text (Text)+import qualified Data.Text as T+import Options.Applicative+import System.FilePath++import Multidir.ReadConfig+++-- | A hand-rolled Alternative-like functionality for a parser+orElse :: Monoid e => (a -> Either e b) -> (a -> Either e b) -> (a -> Either e b)+orElse f g x = case f x of+  Right y -> Right y+  Left e1 -> case g x of+    Right y -> Right y+    Left e2 -> Left (e1 <> e2)+++newtype Selection = Selection {+  select :: FilePath -> Proj -> Bool+} deriving (Boolean)++(\\) :: Selection -> Selection -> Selection+x \\ y = x && not y++tagSelection :: Text -> Selection+tagSelection t = Selection $ \_ -> elem t . projTags++defaultSelection :: Selection+defaultSelection = tagSelection "default"++isSubdir :: FilePath -> FilePath -> Bool+isSubdir x y = splitDirectories x `isPrefixOf` splitDirectories y++dirSelection :: FilePath -> Selection+dirSelection p = Selection $ \d q ->+  isSubdir (normalise (d </> p)) (projDir q)+++-- | Legal characters for tags+isTagChar :: Char -> Bool+isTagChar c = isAlphaNum c || c == '-' || c == '_' || c == '@'+++parseSelection :: String -> Either String Selection+parseSelection = let++  initialExpr :: String -> Either String (Selection, String)+  initialExpr = expr `orElse` continue defaultSelection++  expr :: String -> Either String (Selection, String)+  expr a = do+    (x, b) <- atom a+    continue x b++  continue :: Selection -> String -> Either String (Selection, String)+  continue x ('|':a) = do+    (y, b) <- atom a+    continue (x || y) b+  continue x ('&':a) = do+    (y, b) <- atom a+    continue (x && y) b+  continue x ('\\':a) = do+    (y, b) <- atom a+    continue (x \\ y) b+  continue x s = Right (x, s)++  atom :: String -> Either String (Selection, String)+  atom ('!':a) = do+    (x, b) <- atom a+    pure (not x, b)+  atom ('(':a) = do+    (x, b) <- expr a+    case b of+      (')':c) -> Right (x, c)+      u -> Left ("Expected closed bracket but saw: " <> u)+  atom ('{':a) = let+    f ('}':b) = Right ("",b)+    f (c:b) = first (c:) <$> f b+    f "" = Left ("Expected a close brace")+    in first dirSelection <$> f a+  atom a@(u:a')+    | isTagChar u = let+        (us,v) = span isTagChar a'+        in Right (tagSelection (T.pack (u:us)), v)+    | otherwise = Left ("Expected an item, got " <> a)+  atom "" = Left "Expected an item, got nothing"++  go s = case initialExpr s of+    Left e -> Left e+    Right (x, "") -> Right x+    Right (_, r) -> Left ("Unexpected input in selection: " <> r)++  in go+++applySelection :: Selection -> FilePath -> Projs -> Projs+applySelection (Selection f) d (Projs t) = Projs (filter (f d) t)+++optSelection :: Parser Selection+optSelection = let+  reader = eitherReader parseSelection+  mods =+    long "select" <>+    short 's' <>+    help "a set of projects to operate on" <>+    value defaultSelection <>+    metavar "SELECTION"+  in option reader mods
+ src/TOML/Decode/Extra.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TupleSections #-}++-- | Extra functionality for decoding TOML files+module TOML.Decode.Extra (+  decodeTableWith,+  decodeTableWithM,+  getTableOf,+  removeField,+  removeFieldOpt,+  removeFieldWith,+  removeFieldOptWith,+  processTableValuesWith,+  ) where++import Data.Map.Strict (Map)+import qualified Data.Map.Strict as M+import Data.Text (Text)+import TOML.Decode+import TOML.Error+import TOML.Value+++pop :: Ord k => k -> Map k v -> (Maybe v, Map k v)+pop = M.alterF (,Nothing)++-- | We only want to process a table+decodeTableWithM :: (Table -> DecodeM a) -> Value -> DecodeM a+decodeTableWithM f = \case+  Table t -> f t+  v       -> typeMismatch v++-- | We only want to process a table+decodeTableWith :: (Table -> DecodeM a) -> Decoder a+decodeTableWith = Decoder . decodeTableWithM++-- Now moved upstream+getTableOf :: Decoder a -> Decoder (Map Text a)+getTableOf decoder =+  makeDecoder $ \case+    Table t -> M.traverseWithKey (\k -> addContextItem (Key k) . runDecoder decoder) t+    v -> typeMismatch v++-- | Remove a field, raising error if absent; return rest of table+removeFieldWith :: Decoder a -> Text -> Table -> DecodeM (Table, a)+removeFieldWith d k m = case pop k m of+  (Just v, m') -> (m',) <$> addContextItem (Key k) (unDecoder d v)+  (Nothing, _) -> DecodeM (Left . (, MissingField) . (<> [Key k]))++-- | Remove a field, signalling presence in Maybe; return rest of table+removeFieldOptWith :: Decoder a -> Text -> Table -> DecodeM (Table, Maybe a)+removeFieldOptWith d k m = case pop k m of+  (Just v,  m') -> (m',) . Just <$> addContextItem (Key k) (unDecoder d v)+  (Nothing, m') -> pure (m', Nothing)++-- | Remove a field, raising error if absent; return rest of table+removeField :: DecodeTOML a => Text -> Table -> DecodeM (Table, a)+removeField k m = case pop k m of+  (Just v, m') -> (m',) <$> addContextItem (Key k) (unDecoder tomlDecoder v)+  (Nothing, _) -> DecodeM (Left . (, MissingField) . (<> [Key k]))++-- | Remove a field, signalling presence in Maybe; return rest of table+removeFieldOpt :: DecodeTOML a => Text -> Table -> DecodeM (Table, Maybe a)+removeFieldOpt k m = case pop k m of+  (Just v,  m') -> (m',) . Just <$> addContextItem (Key k) (unDecoder tomlDecoder v)+  (Nothing, m') -> pure (m', Nothing)++-- | Run a decoder on the values of a table+processTableValuesWith :: Decoder a -> Table -> DecodeM (Map Text a)+processTableValuesWith d = M.traverseWithKey (\k -> addContextItem (Key k) . unDecoder d)
+ test/Multidir/SelectionSpec.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++module Multidir.SelectionSpec (spec) where++import qualified Data.Map as M+import Multidir.ReadConfig+import Multidir.Selection+import Test.Hspec+++{-+shouldBeLeft :: Show b => (a -> IO ()) -> Either a b -> IO ()+shouldBeLeft f = \case+  Left x -> f x+  Right y -> expectationFailure ("was meant to be Left: " <> show y)+-}++shouldBeRight :: Show a => (b -> IO ()) -> Either a b -> IO ()+shouldBeRight f = \case+  Left x -> expectationFailure ("was meant to be Right: " <> show x)+  Right y -> f y++shouldMatch :: String -> FilePath -> Proj -> IO ()+shouldMatch s workingDir proj = let+  t (Selection f) = (workingDir, proj) `shouldSatisfy` uncurry f+  in shouldBeRight t $ parseSelection s++shouldNotMatch :: String -> FilePath -> Proj -> IO ()+shouldNotMatch s workingDir proj = let+  t (Selection f) = (workingDir, proj) `shouldNotSatisfy` uncurry f+  in shouldBeRight t $ parseSelection s++shouldNotParse :: String -> IO ()+shouldNotParse s = case parseSelection s of+  Left _ -> pure ()+  Right _ -> expectationFailure ("Should not parse: " <> s)++spec :: Spec+spec = do++  describe "single tag" $ do+    it "should find a tag (1)" $+      shouldMatch "tagA" "/dir1" (Proj "/dir2" ["tagA", "tagB"] M.empty)+    it "should find a tag (2)" $+      shouldMatch "tagB" "/dir1" (Proj "/dir2" ["tagA", "tagB"] M.empty)+    it "should not find a tag" $+      shouldNotMatch "tagC" "/dir1" (Proj "/dir2" ["tagA", "tagB"] M.empty)++  describe "single dir" $ do+    it "should match directory (subdir)" $+      shouldMatch "{dir11}" "/dir1" (Proj "/dir1/dir11" ["tagA", "tagB"] M.empty)+    it "should match directory (current dir)" $+      shouldMatch "{./}" "/dir1" (Proj "/dir1/dir11" ["tagA", "tagB"] M.empty)+    it "should match directory (absolute dir)" $+      shouldMatch "{/dir1}" "/dir2" (Proj "/dir1/dir11" ["tagA", "tagB"] M.empty)+    it "should not match directory (subdir)" $+      shouldNotMatch "{dir11}" "/dir1" (Proj "/dir1/dir12" ["tagA", "tagB"] M.empty)+    it "should not match directory (absolute dir)" $+      shouldNotMatch "{/dir2}" "/dir2" (Proj "/dir1/dir12" ["tagA", "tagB"] M.empty)++  describe "combinators" $ do+    it "or (1)" $+      shouldMatch "tagA|tagB" "/dir1" (Proj "/dir2" ["tagA", "tagC"] M.empty)+    it "or (2)" $+      shouldMatch "tagB|tagC" "/dir1" (Proj "/dir2" ["tagA", "tagC"] M.empty)+    it "or (3)" $+      shouldNotMatch "tagA|tagB" "/dir1" (Proj "/dir2" ["tagC", "tagD"] M.empty)+    it "and (1)" $+      shouldMatch "tagA&tagB" "/dir1" (Proj "/dir2" ["tagA", "tagB"] M.empty)+    it "and (2)" $+      shouldNotMatch "tagA&tagC" "/dir1" (Proj "/dir2" ["tagA", "tagB"] M.empty)+    it "and (3)" $+      shouldNotMatch "tagA&tagC" "/dir1" (Proj "/dir2" ["tagB", "tagC"] M.empty)+    it "not (1)" $+      shouldMatch "!tagA" "/dir1" (Proj "/dir2" ["tagB"] M.empty)+    it "not (1)" $+      shouldNotMatch "!tagA" "/dir1" (Proj "/dir2" ["tagA"] M.empty)++  describe "miscellaneous parsing failures" $ do+    it "double operators" $ do+      shouldNotParse "&&"+      shouldNotParse "x&&"+      shouldNotParse "&&y"+      shouldNotParse "x&&y"
+ test/Spec.hs view
@@ -0,0 +1,2 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}+-- Autodiscover spec files