├── .envrc ├── .gitignore ├── ChangeLog.md ├── LICENSE ├── README.md ├── Setup.hs ├── app └── Main.hs ├── common.nix ├── default.nix ├── nix ├── sources.json └── sources.nix ├── package.yaml ├── reddup.cabal ├── shell.nix ├── src ├── Config.hs ├── Git.hs ├── GitParse.hs ├── Handler.hs ├── Handler │ └── Git.hs ├── Options.hs ├── Reddup.hs ├── ShellUtil.hs ├── Trackable.hs └── Trackable │ ├── Data.hs │ └── Util.hs ├── stack.yaml ├── stack.yaml.lock └── test └── Spec.hs /.envrc: -------------------------------------------------------------------------------- 1 | eval "$(lorri direnv)" -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work/ 2 | *~ 3 | result* 4 | -------------------------------------------------------------------------------- /ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Changelog for reddup 2 | 3 | ## Unreleased changes 4 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Author name here (c) 2018 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Author name here nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Reddup 2 | 3 | A program to help keep things tidy. 4 | 5 | [![asciicast](https://asciinema.org/a/355687.svg)](https://asciinema.org/a/355687) 6 | 7 | This should be considered alpha quality. It works for me with few bugs, but it 8 | still has very few users, so you may encounter problems. 9 | If you have any questions, feel free to use issues or send an email. 10 | 11 | ## Overview 12 | 13 | I like to keep my computer neat and organized: code changes committed, branches 14 | pushed, downloads in the correct place, etc. 15 | 16 | The command `reddup` helps me make this cleanup process easy to do, so that I do 17 | it more often, and also know when I need to do it. 18 | 19 | The idea is, you define locations/specifications for what you want to keep tidy 20 | in `~/.reddup.yml`, and then run `reddup`. The command then reads the system and 21 | reports anything that is out of place. 22 | 23 | Reddup also includes an interactive mode (`-i`, inspired by `git add -p`) 24 | which can be used to "clean up" the untidy things that have been found. 25 | 26 | ## Support 27 | 28 | For a few reasons (which may be overcomable), `reddup` requires that it be on a 29 | unix-like environment. Sorry, Windows users, if you want to use Reddup, you're forced to run it via the WSL. 30 | 31 | # Capabilities 32 | 33 | What can `reddup` do specifically? Right now, it helps you keep directories and 34 | git repositories nice and tidy. 35 | 36 | ## Directories (that should be empty) 37 | 38 | Often, we have directories that are temporary storage places. For example, on my 39 | mac, I consider `~/Desktop` and `~/Downloads` to be two such directories. 40 | 41 | When configured with a location of type `inbox`, `reddup` looks for any files 42 | inside the specified directory. In non-interactive mode, it will 43 | will print these files for your inspection. 44 | 45 | In interactive mode (with `-i`), `reddup` will interactively help you to handle 46 | each file in a handled directory. Options include: 47 | 48 | - Deleting 49 | - Renaming 50 | - Moving to a predefined list of destinations 51 | - Running custom commands defined in the configuration file (WIP) 52 | - Opening a shell at location to run ad-hoc commands 53 | 54 | ## Git Repositories 55 | 56 | When configured with a location of type `git`, `reddup` checks the git 57 | repository to ensure that it is "tidy". It checks that there are: 58 | 59 | - no unstaged changes 60 | - no untracked files 61 | - no staged, uncommitted changes 62 | - no unpushed branches 63 | 64 | In non-interactive mode, it will will print these files for your inspection. 65 | 66 | In interactive mode (with `-i`), `reddup` will interactively help you "reddup" 67 | the repository. 68 | 69 | In force mode (when the repository has a `force: true` flag), it will 70 | automatically create a WIP commit and push branches to remote. The force flag 71 | is optional, and false by default. 72 | 73 | Options include: 74 | 75 | - Committing all changes (deleted, staged, unstaged, untracked). 76 | - Push any branch that are unpushed to upstream. 77 | - Run any ad-hoc commands entered. 78 | - Running custom commands defined in the configuration file. 79 | 80 | # Configuration 81 | 82 | Reddup looks for its configuration file at `~/.reddup.yml`. 83 | 84 | ## Example 85 | 86 | Here is the one I am using right now: 87 | 88 | ``` 89 | locations: 90 | - type: git 91 | location: ~/EF 92 | force: true 93 | - type: git 94 | location: ~/Reference 95 | - type: git 96 | location: ~/Projects/* 97 | - type: inbox 98 | location: ~/Desktop 99 | ignored_files: 100 | - .DS_Store 101 | - type: inbox 102 | location: ~/Inbox 103 | ignored_files: 104 | - .DS_Store 105 | handlers: 106 | inbox: 107 | commands: 108 | - name: (o)pen 109 | cmd: open "$FILE" 110 | key: o 111 | - name: open (e)nclosing dir 112 | cmd: open . 113 | key: e 114 | refile_dests: 115 | - name: (b)ooks 116 | char: b 117 | dir: ~/Nextcloud/books 118 | - name: (p)apers 119 | char: p 120 | dir: ~/Nextcloud/papers 121 | - name: p(r)ivate 122 | char: r 123 | dir: ~/Nextcloud/private 124 | - name: (f)unny 125 | char: f 126 | dir: ~/Nextcloud/funny 127 | ``` 128 | 129 | # Installation 130 | 131 | Currently, there is no binary installation available. 132 | 133 | - Install Stack: https://docs.haskellstack.org/en/stable/README/ 134 | 135 | - Clone or download repo. 136 | 137 | - `stack build` to build the project. 138 | 139 | - `stack exec reddup` to run. 140 | 141 | - To use it from anywhere on the system: 142 | 143 | - Install it to `~/.local/bin` by running `stack install`. 144 | 145 | - Add that that to your path, if it is not already added, (e.g. add 146 | `export PATH="~/.local/bin:$PATH"` to the end of your `~/.bashrc` and/or 147 | `~/.bash_profile` files). 148 | 149 | # Enhancements 150 | 151 | Have any requests for functionality? Please file an issue. PRs welcome. 152 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /app/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Main where 4 | 5 | import qualified Data.Text as T 6 | import Prelude hiding (FilePath, concat) 7 | import qualified Turtle as Tu 8 | 9 | import qualified Config as C 10 | import Control.Monad.Reader 11 | import qualified Options as O 12 | import qualified Reddup as R 13 | import qualified Trackable as Track 14 | 15 | extractConfig :: Either String C.Config -> Tu.Shell C.Config 16 | extractConfig eitherConfig = 17 | let 18 | die :: String -> Tu.Shell C.Config 19 | die errorMsg = Tu.die ("error parsing config: " Tu.<> (T.pack errorMsg)) 20 | in either die return eitherConfig 21 | 22 | checkConfig' :: C.Config -> Tu.Shell C.ProcessedConfig 23 | checkConfig' config = 24 | let 25 | checkResult = C.processConfig config 26 | die :: Tu.Text -> Tu.Shell C.ProcessedConfig 27 | die = Tu.die . ("error in config: " <>) 28 | in either (die . C.configErrorsDisplay) return checkResult 29 | 30 | main :: IO () 31 | main = Tu.sh $ do 32 | opts <- O.parseOpts 33 | eitherConfig <- C.loadConfig 34 | configUnchecked <- extractConfig eitherConfig 35 | pconfig <- checkConfig' configUnchecked 36 | let reddup = R.ReddupD pconfig opts 37 | runReaderT doIt reddup 38 | 39 | doIt :: R.Reddup () 40 | doIt = do 41 | ask >>= (R.debug . T.pack . show) 42 | trackable <- Track.configToTrackables 43 | Track.handleTrackable trackable 44 | R.debug "done" 45 | -------------------------------------------------------------------------------- /common.nix: -------------------------------------------------------------------------------- 1 | let 2 | sources = import ./nix/sources.nix; 3 | pkgs = import sources.nixpkgs { 4 | config = {}; 5 | }; 6 | gis = import sources.gitignore { inherit (pkgs) lib; }; 7 | 8 | ghcide = pkgs.haskell.packages.ghc883.ghcide; 9 | 10 | self = { 11 | inherit (pkgs) niv; 12 | inherit pkgs ghcide; 13 | inherit (gis) gitignoreSource; 14 | }; 15 | 16 | in 17 | self 18 | -------------------------------------------------------------------------------- /default.nix: -------------------------------------------------------------------------------- 1 | let 2 | inherit (import ./common.nix) pkgs gitignoreSource; 3 | in 4 | pkgs.haskell.packages.ghc883.callCabal2nix "reddup" (gitignoreSource ./.) {} 5 | -------------------------------------------------------------------------------- /nix/sources.json: -------------------------------------------------------------------------------- 1 | { 2 | "gitignore": { 3 | "branch": "master", 4 | "description": "Nix function for filtering local git sources", 5 | "homepage": "", 6 | "owner": "hercules-ci", 7 | "repo": "gitignore", 8 | "rev": "c4662e662462e7bf3c2a968483478a665d00e717", 9 | "sha256": "1npnx0h6bd0d7ql93ka7azhj40zgjp815fw2r6smg8ch9p7mzdlx", 10 | "type": "tarball", 11 | "url": "https://github.com/hercules-ci/gitignore/archive/c4662e662462e7bf3c2a968483478a665d00e717.tar.gz", 12 | "url_template": "https://github.com///archive/.tar.gz" 13 | }, 14 | "niv": { 15 | "branch": "master", 16 | "description": "Easy dependency management for Nix projects", 17 | "homepage": "https://github.com/nmattia/niv", 18 | "owner": "nmattia", 19 | "repo": "niv", 20 | "rev": "ab9cc41caf44d1f1d465d8028e4bc0096fd73238", 21 | "sha256": "17k52n8zwp832cqifsc4458mhy4044wmk22f807171hf6p7l4xvr", 22 | "type": "tarball", 23 | "url": "https://github.com/nmattia/niv/archive/ab9cc41caf44d1f1d465d8028e4bc0096fd73238.tar.gz", 24 | "url_template": "https://github.com///archive/.tar.gz" 25 | }, 26 | "nixpkgs": { 27 | "branch": "nixpkgs-unstable", 28 | "description": "A read-only mirror of NixOS/nixpkgs tracking the released channels. Send issues and PRs to", 29 | "homepage": "https://github.com/NixOS/nixpkgs", 30 | "owner": "NixOS", 31 | "repo": "nixpkgs-channels", 32 | "rev": "b8c367a7bd05e3a514c2b057c09223c74804a21b", 33 | "sha256": "0y17zxhwdw0afml2bwkmhvkymd9fv242hksl3l3xz82gmlg1zks4", 34 | "type": "tarball", 35 | "url": "https://github.com/NixOS/nixpkgs-channels/archive/b8c367a7bd05e3a514c2b057c09223c74804a21b.tar.gz", 36 | "url_template": "https://github.com///archive/.tar.gz" 37 | } 38 | } 39 | -------------------------------------------------------------------------------- /nix/sources.nix: -------------------------------------------------------------------------------- 1 | # This file has been generated by Niv. 2 | 3 | let 4 | 5 | # 6 | # The fetchers. fetch_ fetches specs of type . 7 | # 8 | 9 | fetch_file = pkgs: spec: 10 | if spec.builtin or true then 11 | builtins_fetchurl { inherit (spec) url sha256; } 12 | else 13 | pkgs.fetchurl { inherit (spec) url sha256; }; 14 | 15 | fetch_tarball = pkgs: spec: 16 | if spec.builtin or true then 17 | builtins_fetchTarball { inherit (spec) url sha256; } 18 | else 19 | pkgs.fetchzip { inherit (spec) url sha256; }; 20 | 21 | fetch_git = spec: 22 | builtins.fetchGit { url = spec.repo; inherit (spec) rev ref; }; 23 | 24 | fetch_builtin-tarball = spec: 25 | builtins.trace 26 | '' 27 | WARNING: 28 | The niv type "builtin-tarball" will soon be deprecated. You should 29 | instead use `builtin = true`. 30 | 31 | $ niv modify -a type=tarball -a builtin=true 32 | '' 33 | builtins_fetchTarball { inherit (spec) url sha256; }; 34 | 35 | fetch_builtin-url = spec: 36 | builtins.trace 37 | '' 38 | WARNING: 39 | The niv type "builtin-url" will soon be deprecated. You should 40 | instead use `builtin = true`. 41 | 42 | $ niv modify -a type=file -a builtin=true 43 | '' 44 | (builtins_fetchurl { inherit (spec) url sha256; }); 45 | 46 | # 47 | # Various helpers 48 | # 49 | 50 | # The set of packages used when specs are fetched using non-builtins. 51 | mkPkgs = sources: 52 | let 53 | sourcesNixpkgs = 54 | import (builtins_fetchTarball { inherit (sources.nixpkgs) url sha256; }) {}; 55 | hasNixpkgsPath = builtins.any (x: x.prefix == "nixpkgs") builtins.nixPath; 56 | hasThisAsNixpkgsPath = == ./.; 57 | in 58 | if builtins.hasAttr "nixpkgs" sources 59 | then sourcesNixpkgs 60 | else if hasNixpkgsPath && ! hasThisAsNixpkgsPath then 61 | import {} 62 | else 63 | abort 64 | '' 65 | Please specify either (through -I or NIX_PATH=nixpkgs=...) or 66 | add a package called "nixpkgs" to your sources.json. 67 | ''; 68 | 69 | # The actual fetching function. 70 | fetch = pkgs: name: spec: 71 | 72 | if ! builtins.hasAttr "type" spec then 73 | abort "ERROR: niv spec ${name} does not have a 'type' attribute" 74 | else if spec.type == "file" then fetch_file pkgs spec 75 | else if spec.type == "tarball" then fetch_tarball pkgs spec 76 | else if spec.type == "git" then fetch_git spec 77 | else if spec.type == "builtin-tarball" then fetch_builtin-tarball spec 78 | else if spec.type == "builtin-url" then fetch_builtin-url spec 79 | else 80 | abort "ERROR: niv spec ${name} has unknown type ${builtins.toJSON spec.type}"; 81 | 82 | # Ports of functions for older nix versions 83 | 84 | # a Nix version of mapAttrs if the built-in doesn't exist 85 | mapAttrs = builtins.mapAttrs or ( 86 | f: set: with builtins; 87 | listToAttrs (map (attr: { name = attr; value = f attr set.${attr}; }) (attrNames set)) 88 | ); 89 | 90 | # fetchTarball version that is compatible between all the versions of Nix 91 | builtins_fetchTarball = { url, sha256 }@attrs: 92 | let 93 | inherit (builtins) lessThan nixVersion fetchTarball; 94 | in 95 | if lessThan nixVersion "1.12" then 96 | fetchTarball { inherit url; } 97 | else 98 | fetchTarball attrs; 99 | 100 | # fetchurl version that is compatible between all the versions of Nix 101 | builtins_fetchurl = { url, sha256 }@attrs: 102 | let 103 | inherit (builtins) lessThan nixVersion fetchurl; 104 | in 105 | if lessThan nixVersion "1.12" then 106 | fetchurl { inherit url; } 107 | else 108 | fetchurl attrs; 109 | 110 | # Create the final "sources" from the config 111 | mkSources = config: 112 | mapAttrs ( 113 | name: spec: 114 | if builtins.hasAttr "outPath" spec 115 | then abort 116 | "The values in sources.json should not have an 'outPath' attribute" 117 | else 118 | spec // { outPath = fetch config.pkgs name spec; } 119 | ) config.sources; 120 | 121 | # The "config" used by the fetchers 122 | mkConfig = 123 | { sourcesFile ? ./sources.json 124 | , sources ? builtins.fromJSON (builtins.readFile sourcesFile) 125 | , pkgs ? mkPkgs sources 126 | }: rec { 127 | # The sources, i.e. the attribute set of spec name to spec 128 | inherit sources; 129 | 130 | # The "pkgs" (evaluated nixpkgs) to use for e.g. non-builtin fetchers 131 | inherit pkgs; 132 | }; 133 | in 134 | mkSources (mkConfig {}) // { __functor = _: settings: mkSources (mkConfig settings); } 135 | -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | name: reddup 2 | version: 0.1.0.0 3 | github: "JoelMcCracken/reddup" 4 | license: BSD3 5 | author: "Joel N. McCraken" 6 | maintainer: "mccracken.joel@gmail.com" 7 | copyright: "2018 Joel N. McCracken" 8 | 9 | extra-source-files: 10 | - README.md 11 | - ChangeLog.md 12 | 13 | # Metadata used when publishing your package 14 | # synopsis: Short description of your package 15 | # category: Web 16 | 17 | # To avoid duplicated efforts in documentation and dealing with the 18 | # complications of embedding Haddock markup inside cabal files, it is 19 | # common to point users to the README.md file. 20 | description: Please see the README on GitHub at 21 | 22 | dependencies: 23 | - base >= 4.7 && < 5 24 | - exceptions 25 | 26 | library: 27 | source-dirs: 28 | - src 29 | dependencies: 30 | - raw-strings-qq 31 | - turtle 32 | - text >= 1.2.1 33 | - directory >= 1.2.2.0 34 | - unix >= 2.7.1 35 | - parsec 36 | - process 37 | - containers 38 | - foldl >= 1.2.1 39 | - yaml >= 0.8.22 40 | - bytestring >= 0.10.6 41 | - mtl 42 | 43 | executables: 44 | reddup: 45 | main: Main.hs 46 | source-dirs: app 47 | ghc-options: 48 | - -threaded 49 | - -rtsopts 50 | - -with-rtsopts=-N 51 | dependencies: 52 | - reddup 53 | - turtle 54 | - text 55 | - bytestring >= 0.10.6 56 | - mtl 57 | 58 | tests: 59 | reddup-test: 60 | main: Spec.hs 61 | source-dirs: test 62 | ghc-options: 63 | - -threaded 64 | - -rtsopts 65 | - -with-rtsopts=-N 66 | dependencies: 67 | - reddup 68 | -------------------------------------------------------------------------------- /reddup.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.33.0. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | -- 7 | -- hash: bc8807e97cd71551721d7f627a070431e8e0b262ff750e92f0ab624167a5c60b 8 | 9 | name: reddup 10 | version: 0.1.0.0 11 | description: Please see the README on GitHub at 12 | homepage: https://github.com/JoelMcCracken/reddup#readme 13 | bug-reports: https://github.com/JoelMcCracken/reddup/issues 14 | author: Joel N. McCraken 15 | maintainer: mccracken.joel@gmail.com 16 | copyright: 2018 Joel N. McCracken 17 | license: BSD3 18 | license-file: LICENSE 19 | build-type: Simple 20 | extra-source-files: 21 | README.md 22 | ChangeLog.md 23 | 24 | source-repository head 25 | type: git 26 | location: https://github.com/JoelMcCracken/reddup 27 | 28 | library 29 | exposed-modules: 30 | Config 31 | Git 32 | GitParse 33 | Handler 34 | Handler.Git 35 | Options 36 | Reddup 37 | ShellUtil 38 | Trackable 39 | Trackable.Data 40 | Trackable.Util 41 | other-modules: 42 | Paths_reddup 43 | hs-source-dirs: 44 | src 45 | build-depends: 46 | base >=4.7 && <5 47 | , bytestring >=0.10.6 48 | , containers 49 | , directory >=1.2.2.0 50 | , exceptions 51 | , foldl >=1.2.1 52 | , mtl 53 | , parsec 54 | , process 55 | , raw-strings-qq 56 | , text >=1.2.1 57 | , turtle 58 | , unix >=2.7.1 59 | , yaml >=0.8.22 60 | default-language: Haskell2010 61 | 62 | executable reddup 63 | main-is: Main.hs 64 | other-modules: 65 | Paths_reddup 66 | hs-source-dirs: 67 | app 68 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 69 | build-depends: 70 | base >=4.7 && <5 71 | , bytestring >=0.10.6 72 | , exceptions 73 | , mtl 74 | , reddup 75 | , text 76 | , turtle 77 | default-language: Haskell2010 78 | 79 | test-suite reddup-test 80 | type: exitcode-stdio-1.0 81 | main-is: Spec.hs 82 | other-modules: 83 | Paths_reddup 84 | hs-source-dirs: 85 | test 86 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 87 | build-depends: 88 | base >=4.7 && <5 89 | , exceptions 90 | , reddup 91 | default-language: Haskell2010 92 | -------------------------------------------------------------------------------- /shell.nix: -------------------------------------------------------------------------------- 1 | let 2 | inherit (import ./common.nix) pkgs ghcide; 3 | in 4 | pkgs.mkShell rec { 5 | nativeBuildInputs = with pkgs; [ 6 | cabal2nix 7 | haskell.compiler.ghc883 8 | haskellPackages.ghcid 9 | ghcide 10 | ]; 11 | } 12 | -------------------------------------------------------------------------------- /src/Config.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Config where 4 | 5 | import qualified Data.Bifunctor as BF 6 | import Data.ByteString as BS 7 | import qualified Data.List as List 8 | import qualified Data.Map.Strict as M 9 | import Data.Maybe (fromMaybe) 10 | import Data.Text hiding (empty) 11 | import qualified Data.Text as T 12 | import Data.Yaml (FromJSON (..), (.:), (.:?)) 13 | import qualified Data.Yaml as Y 14 | import qualified ShellUtil 15 | import qualified System.IO as SIO 16 | import qualified Turtle as Tu 17 | 18 | data ProcessedConfig = 19 | ProcessedConfig 20 | { rawConfig :: Config 21 | , inboxHandlerCommands :: CustomHandlers 22 | , inboxRefileDests :: RefileDests 23 | , gitHandlerCommands :: !CustomGitHandlers 24 | } deriving (Eq, Show) 25 | 26 | type CustomHandlers = M.Map T.Text InboxHandlerCommandSpec 27 | -- / key is the letter of command 28 | type CustomGitHandlers = M.Map T.Text GitHandlerCommandSpec 29 | type RefileDests = M.Map T.Text InboxHandlerRefileDestSpec 30 | 31 | data Config = 32 | Config 33 | { locations :: [LocationSpec] 34 | , handlers :: HandlerSpecs 35 | } deriving (Eq, Show) 36 | 37 | data LocationSpec 38 | = GitLoc GitLocation 39 | | InboxLoc InboxLocation 40 | deriving (Eq, Show) 41 | 42 | data GitLocation = GitLocation 43 | { gitLocation :: Text 44 | , gitForce :: Bool 45 | } 46 | deriving (Eq, Show) 47 | 48 | data InboxLocation = InboxLocation 49 | { inboxLocation :: Text 50 | , ignoredFiles :: [Text] 51 | } 52 | deriving (Eq, Show) 53 | 54 | data HandlerSpecs 55 | = HandlerSpecs 56 | { handlerSpecInbox :: Maybe InboxHandlerSpec 57 | , handlerSpecGit :: Maybe GitHandlerSpec 58 | } 59 | deriving (Eq, Show) 60 | 61 | newtype GitHandlerSpec 62 | = GitHandlerSpec {gitCommands :: Maybe [GitHandlerCommandSpec]} 63 | deriving (Eq, Show) 64 | 65 | data GitHandlerCommandSpec = 66 | GitHandlerCommandSpec 67 | { gitCmdName :: !Text 68 | , gitCmdSpecCmd :: !Text 69 | , gitCmdKey :: !Text 70 | } deriving (Eq, Show) 71 | 72 | data InboxHandlerSpec = 73 | InboxHandlerSpec 74 | { commands :: Maybe [InboxHandlerCommandSpec] 75 | , refileDests :: Maybe [InboxHandlerRefileDestSpec] 76 | } deriving (Eq, Show) 77 | 78 | data InboxHandlerCommandSpec = 79 | InboxHandlerCommandSpec 80 | { cmdName :: Text 81 | , cmdSpecCmd :: Text 82 | , cmdKey :: Text 83 | } deriving (Eq, Show) 84 | 85 | data InboxHandlerRefileDestSpec = 86 | InboxHandlerRefileDestSpec 87 | { refileDestName :: Text 88 | , refileDestKey :: Text 89 | , refileDestDir :: Text 90 | } deriving (Eq, Show) 91 | 92 | instance FromJSON Config where 93 | parseJSON (Y.Object v) = 94 | Config <$> 95 | v .: "locations" <*> 96 | v .: "handlers" 97 | parseJSON _ = fail "error parsing config" 98 | 99 | instance FromJSON LocationSpec where 100 | parseJSON = Y.withObject "LocationSpec" $ \v -> do 101 | type' <- v .: "type" 102 | location' <- v .: "location" 103 | force <- v .:? "force" 104 | ignoredFiles' <- v .:? "ignored_files" 105 | case (T.unpack $ type') of 106 | "git" -> return $ GitLoc $ GitLocation location' (fromMaybe False force) 107 | "inbox" -> return $ InboxLoc $ InboxLocation location' (fromMaybe [] ignoredFiles') 108 | _ -> fail $ "Location type must be either 'git' or 'inbox', found '" <> T.unpack type' <> "'" 109 | 110 | 111 | instance FromJSON HandlerSpecs where 112 | parseJSON (Y.Object v) = 113 | HandlerSpecs <$> 114 | v .:? "inbox" <*> 115 | v .:? "git" 116 | parseJSON _ = fail "error parsing handler specs" 117 | 118 | instance FromJSON InboxHandlerSpec where 119 | parseJSON (Y.Object v) = 120 | InboxHandlerSpec <$> 121 | v .:? "commands" <*> 122 | v .:? "refile_dests" 123 | parseJSON _ = fail "error parsing inbox handler spec" 124 | 125 | instance FromJSON GitHandlerSpec where 126 | parseJSON (Y.Object v) = 127 | GitHandlerSpec <$> 128 | v .:? "commands" 129 | parseJSON _ = fail "error parsing git handler spec" 130 | 131 | instance FromJSON GitHandlerCommandSpec where 132 | parseJSON (Y.Object v) = 133 | GitHandlerCommandSpec <$> 134 | v .: "name" <*> 135 | v .: "cmd" <*> 136 | v .: "key" 137 | parseJSON _ = fail "error parsing git handler command" 138 | 139 | instance FromJSON InboxHandlerCommandSpec where 140 | parseJSON (Y.Object v) = 141 | InboxHandlerCommandSpec <$> 142 | v .: "name" <*> 143 | v .: "cmd" <*> 144 | v .: "key" 145 | parseJSON _ = fail "error parsing inbox handler command" 146 | 147 | instance FromJSON InboxHandlerRefileDestSpec where 148 | parseJSON (Y.Object v) = 149 | InboxHandlerRefileDestSpec <$> 150 | v .: "name" <*> 151 | v .: "char" <*> 152 | v .: "dir" 153 | parseJSON _ = fail "error parsing inbox handler command" 154 | 155 | getConfigFilename :: Tu.Shell SIO.FilePath 156 | getConfigFilename = fmap (Tu.fromString . T.unpack . Tu.lineToText) (ShellUtil.expandGlob "~/.reddup.yml") 157 | 158 | loadConfig :: Tu.Shell (Either String Config) 159 | loadConfig = do 160 | configFilename <- getConfigFilename 161 | configContents <- Tu.liftIO $ (BS.readFile configFilename :: IO BS.ByteString) 162 | let eresults = Y.decodeEither' configContents :: Either Y.ParseException Config 163 | return (BF.first Y.prettyPrintParseException eresults) 164 | 165 | data ConfigError 166 | = ErrorCmdHandlerKeyWrongNumChars InboxHandlerCommandSpec 167 | | ErrorRefileDestKeyWrongNumChars InboxHandlerRefileDestSpec 168 | | ErrorGitCmdHandlerKeyWrongNumChars GitHandlerCommandSpec 169 | deriving (Eq, Show) 170 | 171 | processGitCommandHandlers :: 172 | Maybe [GitHandlerCommandSpec] -> 173 | ([ConfigError], CustomGitHandlers) 174 | processGitCommandHandlers maybeCmdSpecs = 175 | let 176 | cmdSpecs :: [GitHandlerCommandSpec] 177 | cmdSpecs = fromMaybe [] maybeCmdSpecs 178 | 179 | hasRightNumChars spec = (List.length $ T.unpack $ (gitCmdKey spec) ) > 0 180 | 181 | (rightNumCharsCmds, wrongNumCharsCmds) = List.partition hasRightNumChars cmdSpecs 182 | 183 | errors = 184 | (ErrorGitCmdHandlerKeyWrongNumChars <$> wrongNumCharsCmds) 185 | 186 | toPair spec = (gitCmdKey spec, spec) 187 | 188 | successes = toPair <$> rightNumCharsCmds 189 | in 190 | (errors, M.fromList successes) 191 | 192 | processInboxCommandHandlers :: 193 | Maybe [InboxHandlerCommandSpec] -> 194 | ([ConfigError], CustomHandlers) 195 | processInboxCommandHandlers maybeCmdSpecs = 196 | let 197 | cmdSpecs :: [InboxHandlerCommandSpec] 198 | cmdSpecs = fromMaybe [] maybeCmdSpecs 199 | 200 | hasRightNumChars spec = (List.length $ T.unpack $ (cmdKey spec) ) > 0 201 | 202 | (rightNumCharsCmds, 203 | wrongNumCharsCmds) = List.partition hasRightNumChars cmdSpecs 204 | 205 | errors = 206 | (ErrorCmdHandlerKeyWrongNumChars <$> wrongNumCharsCmds) 207 | 208 | toPair spec = (cmdKey spec, spec) 209 | 210 | successes = toPair <$> rightNumCharsCmds 211 | in 212 | (errors, M.fromList successes) 213 | 214 | processConfig :: Config -> Either [ConfigError] ProcessedConfig 215 | processConfig config = 216 | let 217 | inboxHandlerCommands' :: Maybe [InboxHandlerCommandSpec] 218 | inboxHandlerCommands' = commands =<< handlerSpecInbox (handlers config) 219 | 220 | (ihcErrors, ihcSuccesses) = processInboxCommandHandlers inboxHandlerCommands' 221 | 222 | inboxRefileDests' :: Maybe [InboxHandlerRefileDestSpec] 223 | inboxRefileDests' = refileDests =<< handlerSpecInbox (handlers config) 224 | 225 | (refileErrors, refileDests') = processRefileDests inboxRefileDests' 226 | 227 | gitHandlerCommands' :: Maybe [GitHandlerCommandSpec] 228 | gitHandlerCommands' = gitCommands =<< handlerSpecGit (handlers config) 229 | 230 | (ghcErrors, ghcSuccesses) = processGitCommandHandlers gitHandlerCommands' 231 | 232 | allErrors = ihcErrors ++ refileErrors ++ ghcErrors 233 | 234 | newConfig = ProcessedConfig 235 | { rawConfig = config 236 | , inboxHandlerCommands = ihcSuccesses 237 | , inboxRefileDests = refileDests' 238 | , gitHandlerCommands = ghcSuccesses 239 | } 240 | in 241 | if List.length allErrors > 0 then 242 | Left allErrors 243 | else 244 | Right newConfig 245 | 246 | moreThanOneChar :: String -> Bool 247 | moreThanOneChar str = 248 | List.length str > 0 249 | 250 | processRefileDests :: Maybe [InboxHandlerRefileDestSpec] -> ([ConfigError], RefileDests) 251 | processRefileDests maybeRefileDestSpecs = 252 | let 253 | refileSpecs :: [InboxHandlerRefileDestSpec] 254 | refileSpecs = maybe [] id maybeRefileDestSpecs 255 | 256 | hasRightNumChars :: InboxHandlerRefileDestSpec -> Bool 257 | hasRightNumChars spec = moreThanOneChar $ T.unpack $ refileDestKey spec 258 | 259 | (rightNumCharsCmds, 260 | wrongNumCharsCmds) = List.partition hasRightNumChars refileSpecs 261 | 262 | errors = ErrorRefileDestKeyWrongNumChars <$> wrongNumCharsCmds 263 | 264 | toPair spec = (refileDestKey spec, spec) 265 | 266 | successes = toPair <$> rightNumCharsCmds 267 | in 268 | (errors, M.fromList successes) 269 | 270 | configErrorsDisplay :: [ConfigError] -> Text 271 | configErrorsDisplay ce = 272 | foldMap configErrorDisplay ce 273 | 274 | configErrorDisplay :: ConfigError -> Text 275 | configErrorDisplay ce = 276 | case ce of 277 | ErrorCmdHandlerKeyWrongNumChars handlerSpec -> 278 | let 279 | cmdName' = T.pack $ show $ cmdName handlerSpec 280 | cmdKey' = T.pack $ show $ cmdKey handlerSpec 281 | in 282 | "key for command " <> 283 | cmdName' <> 284 | ", key value is " <> 285 | cmdKey' <> 286 | ", key must be at least one character long.\n" 287 | ErrorRefileDestKeyWrongNumChars handlerSpec -> 288 | let 289 | name = T.pack $ show $ refileDestName handlerSpec 290 | key = T.pack $ show $ refileDestKey handlerSpec 291 | in 292 | "key for refile destination " <> 293 | name <> 294 | ", key value is " <> 295 | key <> 296 | ", key must be at least one character long." 297 | ErrorGitCmdHandlerKeyWrongNumChars handlerSpec -> 298 | let 299 | cmdName' = T.pack $ show $ gitCmdName handlerSpec 300 | cmdKey' = T.pack $ show $ gitCmdKey handlerSpec 301 | in 302 | "key for command " <> 303 | cmdName' <> 304 | ", key value is " <> 305 | cmdKey' <> 306 | ", key must be at least one character long.\n" 307 | -------------------------------------------------------------------------------- /src/Git.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE DeriveAnyClass #-} 3 | 4 | module Git where 5 | 6 | import Data.Text (concat) 7 | import Turtle 8 | import Prelude hiding (FilePath, concat) 9 | import qualified Control.Foldl as Fold 10 | 11 | import GitParse 12 | 13 | gitStatus :: Shell GitStatus 14 | gitStatus = do 15 | let statusStream = inshell "git status --porcelain" Turtle.empty 16 | fmap parseGitStatusLine statusStream 17 | 18 | gitBranches :: Shell GitBranch 19 | gitBranches = do 20 | let branchStream = inshell "git branch" Turtle.empty 21 | fmap parseGitBranchLine branchStream 22 | 23 | lengthOfOutput :: Shell Turtle.Line -> Shell Int 24 | lengthOfOutput cmd = Turtle.fold cmd Fold.length 25 | 26 | remoteBranchContainsBranch :: GitBranch -> Shell Bool 27 | remoteBranchContainsBranch (GitBranch name) = do 28 | let command = inshell (concat ["git branch -r --contains ", name]) Turtle.empty 29 | len <- lengthOfOutput command 30 | return $ len > 0 31 | 32 | withoutRemote :: Shell GitBranch -> GitBranch -> Shell GitBranch 33 | withoutRemote accum next = do 34 | remoteFound <- remoteBranchContainsBranch next 35 | if remoteFound then 36 | accum 37 | else 38 | accum <|> return next 39 | 40 | unpushedGitBranches :: Shell GitBranch 41 | unpushedGitBranches = join $ fold gitBranches $ Fold withoutRemote mzero id 42 | -------------------------------------------------------------------------------- /src/GitParse.hs: -------------------------------------------------------------------------------- 1 | module GitParse ( parseGitBranchLine 2 | , parseGitStatusLine 3 | , GitStatus(..) 4 | , GitBranch(..) 5 | ) where 6 | 7 | import Prelude (Show, Eq, Either(..), String, ($), return, (>>), (.)) 8 | 9 | import Data.Text 10 | import qualified Text.ParserCombinators.Parsec as P 11 | import Text.ParserCombinators.Parsec ((<|>), try) 12 | import Turtle hiding ((<|>)) 13 | 14 | newtype GitBranch 15 | = GitBranch Text 16 | deriving (Show, Eq) 17 | 18 | data GitStatus 19 | = Added Text 20 | | AddedAndModified Text 21 | | Staged Text 22 | | StagedAndUnstaged Text 23 | | Unstaged Text 24 | | Untracked Text 25 | | Deleted Text 26 | | Unknown Text 27 | deriving (Show, Eq) 28 | 29 | gitStatusLineParser :: P.Parser GitStatus 30 | gitStatusLineParser = do 31 | try parseUntracked 32 | <|> try parseAdded 33 | <|> try parseAddedAndModified 34 | <|> try parseStaged 35 | <|> try parseStagedAndUnstaged 36 | <|> try parseDeleted 37 | <|> try parseUnstaged 38 | 39 | parseUntracked :: P.Parser GitStatus 40 | parseUntracked = do 41 | _ <- P.string "??" 42 | value <- parseValueAfterLabel 43 | return $ Untracked (fromString value) 44 | 45 | parseAdded :: P.Parser GitStatus 46 | parseAdded = do 47 | _ <- P.string "A " 48 | value <- parseValueAfterLabel 49 | return $ Added (fromString value) 50 | 51 | parseAddedAndModified :: P.Parser GitStatus 52 | parseAddedAndModified = do 53 | _ <- P.string "AM" 54 | value <- parseValueAfterLabel 55 | return $ AddedAndModified (fromString value) 56 | 57 | parseStaged :: P.Parser GitStatus 58 | parseStaged = do 59 | _ <- P.string "M " 60 | value <- parseValueAfterLabel 61 | return $ Staged (fromString value) 62 | 63 | parseStagedAndUnstaged :: P.Parser GitStatus 64 | parseStagedAndUnstaged = do 65 | _ <- P.string "MM" 66 | value <- parseValueAfterLabel 67 | return $ StagedAndUnstaged (fromString value) 68 | 69 | parseDeleted :: P.Parser GitStatus 70 | parseDeleted = do 71 | _ <- P.string " D" 72 | value <- parseValueAfterLabel 73 | return $ Deleted (fromString value) 74 | 75 | parseUnstaged :: P.Parser GitStatus 76 | parseUnstaged = do 77 | _ <- P.string " M" 78 | value <- parseValueAfterLabel 79 | return $ Unstaged (fromString value) 80 | 81 | parseValueAfterLabel :: P.Parser String 82 | parseValueAfterLabel = do 83 | _ <- P.space 84 | P.many P.anyChar 85 | 86 | parseGitStatusLine :: Turtle.Line -> GitStatus 87 | parseGitStatusLine line = 88 | let 89 | parsed = P.parse gitStatusLineParser "git status --porcelain" ((unpack . lineToText) line) 90 | in 91 | case parsed of 92 | Left _ -> Unknown (lineToText line) 93 | Right value -> value 94 | 95 | gitBranchLineParser :: P.Parser GitBranch 96 | gitBranchLineParser = 97 | let 98 | spacesThenAnything = (P.spaces >> P.many P.anyChar) 99 | branchNameParser :: P.Parser String 100 | branchNameParser = (P.string "*" >> spacesThenAnything) 101 | <|> spacesThenAnything 102 | in do 103 | name <- branchNameParser 104 | return $ GitBranch (fromString name) 105 | 106 | parseGitBranchLine :: Turtle.Line -> GitBranch 107 | parseGitBranchLine line = 108 | let 109 | parsed = P.parse gitBranchLineParser "git branch" ((unpack . lineToText) line) 110 | in 111 | case parsed of 112 | Left _ -> GitBranch (lineToText line) 113 | Right value -> value 114 | -------------------------------------------------------------------------------- /src/Handler.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Handler where 4 | 5 | import qualified Data.Text as T 6 | import qualified Data.Text.IO as TIO 7 | import Prelude hiding (FilePath, concat) 8 | import qualified Turtle as Tu 9 | import Turtle (()) 10 | import Trackable.Data 11 | import Trackable.Util 12 | import qualified System.IO as IO 13 | import qualified ShellUtil 14 | import qualified Config as C 15 | import qualified Data.Map.Strict as M 16 | import qualified Reddup as R 17 | import Control.Monad.Reader (ask, lift, runReaderT, liftIO) 18 | import qualified Data.List as List 19 | import Data.Foldable (traverse_) 20 | 21 | handleInbox :: NHFile -> R.Reddup () 22 | handleInbox nh = do 23 | isInteractive <- R.isInteractive 24 | if isInteractive then 25 | inboxInteractiveHandler nh 26 | else 27 | inboxPrintHandler nh 28 | 29 | inboxPrintHandler :: NHFile -> R.Reddup () 30 | inboxPrintHandler (NHFile (InboxDirTrackable inbox locSpec) file) = do 31 | let isIgnored = isFileIgnored file locSpec 32 | inbox' <- lift $ pathToTextOrError inbox 33 | file' <- lift $ pathToTextOrError file 34 | let formatted = inbox' <> ": file present " <> file' 35 | if isIgnored then do 36 | return () 37 | else 38 | liftIO $ TIO.putStrLn $ formatted 39 | 40 | inboxInteractiveHandler :: NHFile -> R.Reddup () 41 | inboxInteractiveHandler nh@(NHFile (InboxDirTrackable _inbox locSpec) file) = do 42 | file' <- lift $ pathToTextOrError file 43 | let isIgnored = isFileIgnored file locSpec 44 | if isIgnored then 45 | R.verbose $ file' <> " is in ignored list. skipping." 46 | else do 47 | R.verbose $ file' <> " is not in ignored list, handling." 48 | inboxHandlerMenu nh 49 | 50 | inboxHandlerMenu :: NHFile -> R.Reddup () 51 | inboxHandlerMenu nh@(NHFile (InboxDirTrackable inbox _locSpec) file) = do 52 | reddup <- ask 53 | let config = R.reddupConfig reddup 54 | inbox' <- lift $ pathToTextOrError inbox 55 | file' <- lift $ pathToTextOrError file 56 | let fmtMsg = inbox' <> ": file present " <> file' 57 | let inboxHandlerCommands = C.inboxHandlerCommands config 58 | Tu.echo $ Tu.fromString $ Tu.encodeString file 59 | selection <- Tu.liftIO $ do 60 | putStrLn $ T.unpack $ fmtMsg 61 | putStrLn "Action choices:" 62 | putStrLn "(d)elete" 63 | putStrLn "(r)ename file" 64 | putStrLn "open a (s)hell" 65 | putStrLn "continue to (n)ext" 66 | putStrLn "re(f)ile to location" 67 | printMenuCustomCommands $ M.elems inboxHandlerCommands 68 | putStrLn "(q)uit" 69 | putStr "Selection: " 70 | IO.hFlush IO.stdout 71 | getLine 72 | case selection of 73 | "d" -> do 74 | Tu.echo "deleting." 75 | isItADir <- Tu.testdir file 76 | if isItADir then 77 | Tu.rmdir file 78 | else 79 | Tu.rm file 80 | "s" -> do 81 | inboxHandlerInteractiveShell nh 82 | "f" -> do 83 | handleRefile nh 84 | "n" -> 85 | Tu.echo "continuing to to next item." 86 | -- just return from this handler, nothing left to do 87 | "r" -> 88 | handleRename nh 89 | "q" -> do 90 | Tu.exit Tu.ExitSuccess 91 | _ -> do 92 | R.debug $ T.pack $ show $ inboxHandlerCommands 93 | let result = M.lookup (T.pack $ selection) inboxHandlerCommands 94 | case result of 95 | Just cmd -> do 96 | inboxHandlerCommand nh cmd 97 | inboxInteractiveHandler nh 98 | Nothing -> do 99 | Tu.echo $ Tu.fromString $ "input unrecognized: '" <> selection <>"'" 100 | inboxInteractiveHandler nh 101 | 102 | inboxHandlerInteractiveShell :: NHFile -> R.Reddup () 103 | inboxHandlerInteractiveShell nh@(NHFile _idt file) = do 104 | let envVars = [("FILE", Tu.encodeString file)] 105 | Tu.echo "Starting bash. Reddup will continue when subshell exits." 106 | Tu.echo "Filename available in shell as $FILE." 107 | Tu.liftIO $ ShellUtil.openInteractiveShell envVars 108 | destinationExists <- Tu.testfile file 109 | if destinationExists then do 110 | Tu.echo "file still exists, continuing processing" 111 | inboxInteractiveHandler nh 112 | else 113 | Tu.echo "file no longer exists, continuing to next file" 114 | 115 | inboxHandlerCommand :: NHFile -> C.InboxHandlerCommandSpec -> R.Reddup () 116 | inboxHandlerCommand (NHFile _idt file) cmd = do 117 | let envVars = [("FILE", Tu.encodeString file)] 118 | _ <- Tu.liftIO $ ShellUtil.shellCmdWithEnv (C.cmdSpecCmd cmd) envVars 119 | pure () 120 | 121 | isFileIgnored :: FilePath -> C.LocationSpec -> Bool 122 | isFileIgnored file locSpec = 123 | let 124 | ignored = ignoredFiles locSpec 125 | dir = Tu.parent file 126 | ignored' = (dir ) <$> ignored 127 | in 128 | List.any (file ==) ignored' 129 | 130 | ignoredFiles :: C.LocationSpec -> [Tu.FilePath] 131 | ignoredFiles locSpec = 132 | case locSpec of 133 | C.GitLoc _ -> [] 134 | C.InboxLoc (C.InboxLocation _ ignoredFiles') -> 135 | Tu.fromString . T.unpack <$> ignoredFiles' 136 | 137 | force :: C.LocationSpec -> Bool 138 | force locSpec = 139 | case locSpec of 140 | C.GitLoc (C.GitLocation _ f) -> f 141 | _ -> False 142 | 143 | 144 | printMenuCustomCommands :: [C.InboxHandlerCommandSpec] -> IO () 145 | printMenuCustomCommands ihcSpecs = do 146 | printStrings $ (T.unpack . C.cmdName) <$> ihcSpecs 147 | 148 | printRefileDests :: [C.InboxHandlerRefileDestSpec] -> IO () 149 | printRefileDests refileDests = do 150 | printStrings $ ( ("destination: " <>) . T.unpack . C.refileDestName) <$> refileDests 151 | 152 | printStrings :: [String] -> IO () 153 | printStrings = traverse_ putStrLn 154 | 155 | handleRefile :: NHFile -> R.Reddup () 156 | handleRefile nh@(NHFile _ filePath) = do 157 | reddup <- ask 158 | let config = R.reddupConfig reddup 159 | liftIO $ putStrLn $ show config 160 | let inboxRefileDests = C.inboxRefileDests config 161 | filePath' <- lift $ pathToTextOrError filePath 162 | liftIO $ TIO.putStrLn $ "Refiling " <> filePath' 163 | liftIO $ TIO.putStrLn $ "Choose destination, or (q) to quit: " 164 | liftIO $ printRefileDests $ M.elems inboxRefileDests 165 | 166 | dest <- T.pack <$> (liftIO $ getLine) 167 | 168 | case dest of 169 | "q" -> do 170 | liftIO $ putStrLn "quitting." 171 | _ -> do 172 | let result = M.lookup dest inboxRefileDests 173 | case result of 174 | Just target -> do 175 | R.debug $ T.pack $ show target 176 | refileTo nh target 177 | Nothing -> do 178 | liftIO $ putStrLn $ "destination unrecognized: '" <> T.unpack dest <>"'" 179 | handleRefile nh 180 | 181 | refileTo :: NHFile -> C.InboxHandlerRefileDestSpec -> R.Reddup () 182 | refileTo nh@(NHFile _inboxTrackable filePath) refileDest = do 183 | let filename = Tu.filename filePath 184 | let destDirRaw = C.refileDestDir refileDest 185 | let accessError = liftIO $ putStrLn $ "problem accessing directoy " <> T.unpack destDirRaw 186 | mdestDir <- lift $ ShellUtil.expandOne destDirRaw 187 | case mdestDir of 188 | Just destDir -> do 189 | let 190 | destDirFP :: Tu.FilePath 191 | destDirFP = Tu.fromString $ T.unpack $ Tu.lineToText $ destDir 192 | newFilename = destDirFP filename 193 | testResult <- liftIO $ Tu.testdir destDirFP 194 | if testResult then do 195 | R.debug $ "Moving to dest " <> (T.pack $ Tu.encodeString newFilename) 196 | destExists <- Tu.testfile newFilename 197 | if destExists then do 198 | liftIO $ putStrLn "File currently exists at destination." 199 | handleRefile nh 200 | else do 201 | Tu.mv filePath newFilename 202 | else do 203 | accessError 204 | Nothing -> do 205 | accessError 206 | 207 | handleRename :: NHFile -> R.Reddup () 208 | handleRename nh@(NHFile inbox filePath) = do 209 | reddup <- ask 210 | let run cmd = runReaderT cmd reddup 211 | filePath' <- lift $ pathToTextOrError filePath 212 | lift $ Tu.liftIO $ do 213 | putStrLn $ "Renaming file. original name " <> (T.unpack filePath') 214 | putStr $ "Enter new name: " 215 | IO.hFlush IO.stdout 216 | newName <- getLine 217 | let newPath = (Tu.directory filePath) (Tu.fromText $ T.pack newName) 218 | destinationExists <- Tu.testfile newPath 219 | if destinationExists then do 220 | putStrLn "Error, destination exists. Choose another name." 221 | Tu.sh $ run $ handleRename nh 222 | else do 223 | putStrLn $ "new name: " <> newName 224 | putStrLn "(a)ccept new name" 225 | putStrLn "(c)ancel renaming (go back to previous menu)" 226 | putStrLn "(t)ry again (enter a new name)" 227 | IO.hFlush IO.stdout 228 | renameSelection <- getLine 229 | case renameSelection of 230 | "a" -> do 231 | Tu.sh $ do 232 | Tu.mv filePath newPath 233 | let nh' = NHFile inbox newPath 234 | run $ inboxInteractiveHandler nh' 235 | "c" -> 236 | Tu.sh $ run $ inboxInteractiveHandler nh 237 | "t" -> 238 | Tu.sh $ run $ handleRename nh 239 | _ -> do 240 | putStrLn $ "input unrecognized: '" <> renameSelection <>"'" 241 | Tu.sh $ run $ handleRename nh 242 | -------------------------------------------------------------------------------- /src/Handler/Git.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Handler.Git where 4 | 5 | import qualified Config as C 6 | import qualified Control.Foldl as L 7 | import Control.Monad (forever) 8 | import Control.Monad.Reader (ask, guard, lift, liftIO, runReaderT) 9 | import Data.Foldable (traverse_) 10 | import qualified Data.Map.Strict as M 11 | import qualified Data.Text as T 12 | import qualified Git 13 | import qualified GitParse as GP 14 | import qualified Handler as H 15 | import qualified Reddup as R 16 | import qualified ShellUtil 17 | import qualified System.IO as IO 18 | import Trackable.Data 19 | import Trackable.Util 20 | import qualified Turtle as Tu 21 | 22 | gitHandler' :: GitRepoTrackable -> R.Reddup () 23 | gitHandler' grt@(GitRepoTrackable dir locSpec) = do 24 | R.verbose $ "checking " <> (T.pack $ show dir) 25 | lift $ Tu.cd dir 26 | dirExists <- lift $ Tu.testdir ".git" 27 | if dirExists then do 28 | isInteractive <- R.isInteractive 29 | if isInteractive then 30 | processGitInteractive grt 31 | else 32 | if H.force locSpec 33 | then do 34 | lift $ processGitNonInteractiveForce grt 35 | else lift $ processGitNonInteractive grt 36 | else 37 | errorNotGitRepo grt 38 | 39 | numShell :: Tu.Shell a -> Tu.Shell Int 40 | numShell sh = Tu.fold sh L.length 41 | 42 | processGitInteractive :: GitRepoTrackable -> R.Reddup () 43 | processGitInteractive grt@(GitRepoTrackable dir _locSpec) = do 44 | R.verbose $ T.pack $ "Git Repo: " <> Tu.encodeString dir 45 | let gitStatus = checkGitStatus grt 46 | 47 | numStatus <- lift $ numShell gitStatus 48 | 49 | if numStatus > 0 then 50 | processGitWorkDir grt 51 | else 52 | return () 53 | 54 | let gitUnpushed = Git.unpushedGitBranches 55 | 56 | numUnpushed <- lift $ numShell Git.unpushedGitBranches 57 | 58 | if numUnpushed > 0 then 59 | processGitUnpushed grt gitUnpushed 60 | else 61 | return () 62 | 63 | processGitWorkDir :: GitRepoTrackable -> R.Reddup () 64 | processGitWorkDir grt@(GitRepoTrackable dir _locSpec) = do 65 | reddup <- ask 66 | let 67 | run :: R.Reddup () -> IO () 68 | run = Tu.sh . (flip runReaderT) reddup 69 | 70 | let config = R.reddupConfig reddup 71 | let gitHandlerCommands = C.gitHandlerCommands config 72 | 73 | liftIO $ putStrLn $ 74 | "Git repo " <> 75 | Tu.encodeString dir <> 76 | ": workdir dirty " 77 | 78 | liftIO $ do 79 | putStrLn "Actions:" 80 | putStrLn "open a (s)hell" 81 | putStrLn "git (d)iff (diff of working dir and index)" 82 | putStrLn "git d(i)ff --cached (diff of index and HEAD)" 83 | putStrLn "git s(t)atus" 84 | putStrLn "(w)ip commit (`git add .; git commit -m 'WIP'` )" 85 | putStrLn "continue to (n)ext item" 86 | 87 | printMenuCustomCommands $ M.elems gitHandlerCommands 88 | 89 | putStrLn "(q)uit" 90 | putStr "Choice: " 91 | IO.hFlush IO.stdout 92 | selection <- getLine 93 | case selection of 94 | "s" -> do 95 | putStrLn "Starting bash. Reddup will continue when subshell exits." 96 | ShellUtil.openInteractiveShell [] 97 | run $ processGitInteractive grt 98 | "d" -> do 99 | Tu.sh $ Tu.shell "git diff" Tu.empty 100 | run $ processGitInteractive grt 101 | "n" -> 102 | putStrLn "continuing to next." 103 | "i" -> do 104 | Tu.sh $ Tu.shell "git diff --cached" Tu.empty 105 | run $ processGitInteractive grt 106 | "t" -> do 107 | Tu.sh $ Tu.shell "git status" Tu.empty 108 | run $ processGitInteractive grt 109 | "w" -> do 110 | Tu.sh $ Tu.inshell "git add .; git commit -m 'WIP'" Tu.empty 111 | run $ processGitInteractive grt 112 | "q" -> do 113 | Tu.sh $ Tu.exit Tu.ExitSuccess 114 | _ -> do 115 | let result = M.lookup (T.pack $ selection) gitHandlerCommands 116 | case result of 117 | Just cmd -> do 118 | Tu.sh $ Tu.inshell (C.gitCmdSpecCmd cmd) Tu.empty 119 | run $ processGitInteractive grt 120 | Nothing -> do 121 | putStrLn $ "input unrecognized: '" <> selection <>"'" 122 | run $ processGitInteractive grt 123 | 124 | printStrings :: [String] -> IO () 125 | printStrings = traverse_ putStrLn 126 | 127 | printMenuCustomCommands :: [C.GitHandlerCommandSpec] -> IO () 128 | printMenuCustomCommands ghcSpecs = do 129 | printStrings $ (T.unpack . C.gitCmdName) <$> ghcSpecs 130 | 131 | processGitUnpushed :: GitRepoTrackable -> Tu.Shell GP.GitBranch -> R.Reddup () 132 | processGitUnpushed grt@(GitRepoTrackable dir _locSpec) branchShell = do 133 | reddup <- ask 134 | 135 | let 136 | run :: R.Reddup () -> IO () 137 | run = Tu.sh . (flip runReaderT) reddup 138 | 139 | branch@(GP.GitBranch branchName) <- lift $ branchShell 140 | 141 | bl <- Tu.fold Git.unpushedGitBranches L.list 142 | 143 | guard $ elem branch bl 144 | 145 | liftIO $ putStrLn $ 146 | "Git repo " <> 147 | Tu.encodeString dir <> 148 | ": unpushed branch " <> 149 | T.unpack branchName 150 | 151 | target <- lift $ readPushTarget branch 152 | merge <- lift $ readMerge branch 153 | 154 | let targetAndMerge = (,) <$> target <*> merge 155 | 156 | let unrecognized selection = do 157 | putStrLn $ "input unrecognized: '" <> selection <>"'" 158 | run $ processGitInteractive grt 159 | 160 | liftIO $ do 161 | putStrLn "Actions:" 162 | putStrLn "open a (s)hell" 163 | gitPushLabel branchName targetAndMerge 164 | putStrLn "continue to (n)ext item" 165 | putStrLn "(q)uit" 166 | putStr "Choice: " 167 | IO.hFlush IO.stdout 168 | selection <- getLine 169 | case selection of 170 | "s" -> do 171 | putStrLn "Starting bash. Reddup will continue when subshell exits." 172 | ShellUtil.openInteractiveShell [] 173 | run $ processGitInteractive grt 174 | "n" -> 175 | putStrLn "continuing to next." 176 | "p" -> do 177 | gitPushCmd branchName targetAndMerge (unrecognized selection) 178 | "q" -> do 179 | Tu.sh $ Tu.exit Tu.ExitSuccess 180 | _ -> do 181 | unrecognized selection 182 | 183 | readPushTarget :: GP.GitBranch -> Tu.Shell (Maybe T.Text) 184 | readPushTarget branch = do 185 | pr <- readPushRemote branch 186 | r <- readRemote branch 187 | return $ pr Tu.<|> r 188 | 189 | readGitConfig :: T.Text -> Tu.Shell (Maybe T.Text) 190 | readGitConfig cmd = do 191 | mConfigOutput <- ShellUtil.firstShell $ Tu.inshell cmd Tu.empty 192 | return $ Tu.lineToText <$> mConfigOutput 193 | 194 | readRemote :: GP.GitBranch -> Tu.Shell (Maybe T.Text) 195 | readRemote (GP.GitBranch branchName) = do 196 | let command = "git config branch." <> branchName <> ".remote || true" 197 | readGitConfig command 198 | 199 | readPushRemote :: GP.GitBranch -> Tu.Shell (Maybe T.Text) 200 | readPushRemote (GP.GitBranch branchName) = do 201 | let command = "git config branch." <> branchName <> ".pushRemote || true" 202 | readGitConfig command 203 | 204 | readMerge :: GP.GitBranch -> Tu.Shell (Maybe T.Text) 205 | readMerge (GP.GitBranch branchName) = do 206 | let command = "git config branch." <> branchName <> ".merge || true" 207 | readGitConfig command 208 | 209 | gitPushLabel :: T.Text -> Maybe (T.Text, T.Text) -> IO () 210 | gitPushLabel branchName = 211 | maybe unavailable (uncurry available) 212 | where 213 | unavailable = 214 | putStrLn "(git push not available, pushremote and/or merge configuration not set)" 215 | available target merge = 216 | putStrLn $ "git (p)ush " <> T.unpack target <> " " <> T.unpack branchName <> ":" <> T.unpack merge 217 | 218 | gitPushCmd :: T.Text -> Maybe (T.Text, T.Text) -> IO () -> IO () 219 | gitPushCmd branchName targetAndMerge unrecognized = 220 | case targetAndMerge of 221 | Just (target, merge) -> 222 | let 223 | cmd = "git push -v " <> target <> " " <> branchName <> ":" <> merge 224 | in 225 | Tu.sh $ Tu.inshell cmd Tu.empty 226 | Nothing -> unrecognized 227 | 228 | checkGitProblems :: GitRepoTrackable -> Tu.Shell NHGit 229 | checkGitProblems grt = 230 | checkGitUnpushed grt Tu.<|> checkGitStatus grt 231 | 232 | checkGitStatus :: GitRepoTrackable -> Tu.Shell NHGit 233 | checkGitStatus grt = 234 | NHGit grt . NHStatus <$> Git.gitStatus 235 | 236 | checkGitUnpushed :: GitRepoTrackable -> Tu.Shell NHGit 237 | checkGitUnpushed grt = 238 | NHGit grt . NHUnpushedBranch <$> Git.unpushedGitBranches 239 | 240 | gitPrintHandler :: NHGit -> Tu.Shell () 241 | gitPrintHandler (NHGit (GitRepoTrackable dir' _locSpec) nhg) = do 242 | dir <- pathToTextOrError dir' 243 | let formatPath :: T.Text -> T.Text -> T.Text -> T.Text 244 | formatPath path statusItem label = 245 | path <> ": " <> label <> " '" <> statusItem <> "'" 246 | format = 247 | case nhg of 248 | NHStatus (GP.Added f) -> formatPath dir f "file added" 249 | NHStatus (GP.AddedAndModified f) -> formatPath dir f "file added and modified" 250 | NHStatus (GP.Staged f) -> formatPath dir f "staged changes" 251 | NHStatus (GP.Unstaged f) -> formatPath dir f "unstaged changes" 252 | NHStatus (GP.StagedAndUnstaged f) -> formatPath dir f "staged and unstaged changes" 253 | NHStatus (GP.Untracked f) -> formatPath dir f "untracked file" 254 | NHStatus (GP.Deleted f) -> formatPath dir f "file deleted" 255 | NHStatus (GP.Unknown f) -> formatPath dir f "(unknown git status)" 256 | NHUnpushedBranch (GP.GitBranch branchName) -> 257 | dir <> ": Unpushed branch '" <> branchName <> "'" 258 | NHNotGitRepo -> dir <> ": is not a git repo" 259 | liftIO $ putStrLn $ T.unpack $ format 260 | 261 | processGitNonInteractive :: GitRepoTrackable -> Tu.Shell () 262 | processGitNonInteractive grTrack = do 263 | checkGitProblems grTrack >>= gitPrintHandler 264 | 265 | processGitNonInteractiveForce :: GitRepoTrackable -> Tu.Shell () 266 | processGitNonInteractiveForce grTrack = 267 | forever $ 268 | checkGitProblems grTrack >>= tryFixGitProblem 269 | 270 | tryFixGitProblem :: NHGit -> Tu.Shell () 271 | tryFixGitProblem nh@(NHGit _ nhg) = do 272 | case nhg of 273 | NHStatus (GP.Added _) -> 274 | addAndWipCommit 275 | NHStatus (GP.AddedAndModified _) -> 276 | addAndWipCommit 277 | NHStatus (GP.Staged _) -> 278 | addAndWipCommit 279 | NHStatus (GP.Unstaged _) -> 280 | addAndWipCommit 281 | NHStatus (GP.StagedAndUnstaged _) -> 282 | addAndWipCommit 283 | NHStatus (GP.Untracked _) -> 284 | addAndWipCommit 285 | NHStatus (GP.Deleted _) -> 286 | addAndWipCommit 287 | NHUnpushedBranch branch@(GP.GitBranch branchName) -> do 288 | targetAndMerge <- (,) <$> readPushTarget branch <*> readMerge branch 289 | liftIO $ gitPushCmd branchName (go targetAndMerge) mempty 290 | _ -> do 291 | gitPrintHandler nh 292 | Tu.mzero 293 | where 294 | go :: (Maybe a, Maybe a) -> Maybe (a, a) 295 | go (Just a, Just b) = Just (a, b) 296 | go _ = Nothing 297 | 298 | addAndWipCommit :: Tu.MonadIO m => m () 299 | addAndWipCommit = 300 | Tu.sh $ Tu.inshell "git add .; git commit -m 'reddup auto WIP commit'" Tu.empty 301 | 302 | errorNotGitRepo :: GitRepoTrackable -> R.Reddup () 303 | errorNotGitRepo (GitRepoTrackable dir _locSpec) = do 304 | liftIO $ putStrLn $ "Warning: Not a git repository: " <> Tu.encodeString dir 305 | -------------------------------------------------------------------------------- /src/Options.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Options where 4 | 5 | import Prelude 6 | import qualified Turtle as Tu 7 | 8 | data Options = Options 9 | { optDebug :: Bool 10 | , optVerbose :: Bool 11 | , optInteractive :: Bool 12 | } 13 | deriving (Eq, Show) 14 | 15 | parser :: Tu.Parser Options 16 | parser = 17 | Options <$> 18 | Tu.switch "debug" 'd' "Print debug information to stderr" <*> 19 | Tu.switch "verbose" 'v' "Print verbose information to stdout" <*> 20 | Tu.switch "interactive" 'i' "Handle found items interactively" 21 | 22 | parseOpts :: Tu.Shell Options 23 | parseOpts = Tu.options "Reddup: Keep your computer tidy" parser 24 | -------------------------------------------------------------------------------- /src/Reddup.hs: -------------------------------------------------------------------------------- 1 | module Reddup where 2 | 3 | import qualified Config as C 4 | import qualified Options as O 5 | import Control.Monad.Reader 6 | import qualified Turtle as Tu 7 | import qualified Data.Text.IO as TIO 8 | import qualified Data.Text as T 9 | 10 | data ReddupD = 11 | ReddupD 12 | { reddupConfig :: C.ProcessedConfig 13 | , reddupOptions :: O.Options 14 | } deriving (Eq, Show) 15 | 16 | type Reddup = ReaderT ReddupD Tu.Shell 17 | 18 | debug' :: O.Options -> T.Text -> Tu.Shell () 19 | debug' opts txt = 20 | if O.optDebug opts then 21 | Tu.liftIO $ TIO.putStrLn txt 22 | else 23 | return () 24 | 25 | debug :: T.Text -> Reddup () 26 | debug txt = do 27 | reddup <- ask 28 | let opts = reddupOptions reddup 29 | lift $ debug' opts txt 30 | 31 | verbose :: T.Text -> Reddup () 32 | verbose txt = do 33 | reddup <- ask 34 | let opts = reddupOptions reddup 35 | lift $ verbose' opts txt 36 | 37 | verbose' :: O.Options -> T.Text -> Tu.Shell () 38 | verbose' opts txt = do 39 | if O.optDebug opts || O.optVerbose opts then 40 | Tu.liftIO $ TIO.putStrLn txt 41 | else 42 | return () 43 | 44 | isInteractive :: Reddup Bool 45 | isInteractive = do 46 | reddup <- ask 47 | let opts = reddupOptions reddup 48 | lift $ return $ O.optInteractive opts 49 | -------------------------------------------------------------------------------- /src/ShellUtil.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module ShellUtil where 4 | 5 | import Prelude hiding (FilePath) 6 | import qualified Turtle as Tu 7 | import Data.Text 8 | import qualified System.Process as SP 9 | import qualified Control.Foldl as CF 10 | 11 | expandGlob :: Text -> Tu.Shell Tu.Line 12 | expandGlob glob = 13 | let 14 | script = "for f in " <> glob <> "; do echo $f; done" 15 | in 16 | Tu.inshell script Tu.empty 17 | 18 | firstShell :: Tu.Shell a -> Tu.Shell (Maybe a) 19 | firstShell shell = 20 | Tu.fold shell CF.head 21 | 22 | expandOne :: Text -> Tu.Shell (Maybe Tu.Line) 23 | expandOne glob = 24 | firstShell $ expandGlob glob 25 | 26 | type EnvVars = [(String, String)] 27 | 28 | mergeWithExistingEnv :: EnvVars -> IO EnvVars 29 | mergeWithExistingEnv adtlVars = do 30 | let unpack' kv = (unpack $ fst kv, unpack $ snd kv) 31 | e <- Tu.env 32 | return ((unpack' <$> e) ++ adtlVars) 33 | 34 | openInteractiveShell :: EnvVars -> IO () 35 | openInteractiveShell adtlVars = do 36 | let handler _ _ _ p = SP.waitForProcess p 37 | envVars <- mergeWithExistingEnv adtlVars 38 | let cmd = (SP.shell "bash") { 39 | SP.delegate_ctlc = True, 40 | SP.env = Just envVars } 41 | _ <- SP.withCreateProcess cmd handler 42 | return () 43 | 44 | shellCmdWithEnv :: Text -> EnvVars -> IO () 45 | shellCmdWithEnv cmd adtlVars = do 46 | let handler _ _ _ p = SP.waitForProcess p 47 | envVars <- mergeWithExistingEnv adtlVars 48 | 49 | let cmd' = (SP.shell (unpack cmd)) { 50 | SP.delegate_ctlc = True, 51 | SP.env = Just envVars } 52 | _ <- SP.withCreateProcess cmd' handler 53 | return () 54 | -------------------------------------------------------------------------------- /src/Trackable.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Trackable where 4 | 5 | import Prelude hiding (FilePath, concat) 6 | import qualified Turtle as Tu 7 | import qualified ShellUtil 8 | import qualified Config as C 9 | import qualified Handler as H 10 | import qualified Handler.Git as HG 11 | import qualified Reddup as R 12 | import Trackable.Data 13 | import Trackable.Util 14 | import Control.Monad.Reader 15 | 16 | handleTrackable :: Trackable -> R.Reddup () 17 | handleTrackable trackable = do 18 | case trackable of 19 | (GitRepo grTrack) -> 20 | HG.gitHandler' grTrack 21 | (InboxDir idTrack) -> 22 | processInboxTrackable idTrack >>= H.handleInbox 23 | 24 | processInboxTrackable :: InboxDirTrackable -> R.Reddup NHFile 25 | processInboxTrackable idt@(InboxDirTrackable dir _locSpec)= do 26 | dir' <- lift $ pathToTextOrError dir 27 | R.verbose $ "checking " <> dir' 28 | lift $ Tu.cd dir 29 | let files = lift $ Tu.ls dir 30 | files >>= (lift . return . NHFile idt) 31 | 32 | configToTrackables :: R.Reddup Trackable 33 | configToTrackables = do 34 | reddup <- ask 35 | location <- lift $ Tu.select $ C.locations $ C.rawConfig $ R.reddupConfig reddup 36 | lift $ locationSpecToTrackable location 37 | 38 | locationSpecToTrackable :: C.LocationSpec -> Tu.Shell Trackable 39 | locationSpecToTrackable ls = do 40 | let expand location = 41 | (Tu.fromText . Tu.lineToText) <$> (ShellUtil.expandGlob location) 42 | case ls of 43 | C.GitLoc (C.GitLocation location _) -> do 44 | path' <- (expand location) 45 | return $ GitRepo $ GitRepoTrackable path' ls 46 | C.InboxLoc (C.InboxLocation location _) -> do 47 | path' <- (expand location) 48 | return $ InboxDir $ InboxDirTrackable path' ls 49 | -------------------------------------------------------------------------------- /src/Trackable/Data.hs: -------------------------------------------------------------------------------- 1 | module Trackable.Data where 2 | 3 | import qualified Turtle as Tu 4 | import qualified GitParse as GP 5 | import Prelude hiding (FilePath) 6 | import qualified Config as C 7 | 8 | type GitRepoPath = Tu.FilePath 9 | type InboxPath = Tu.FilePath 10 | type FilePath = Tu.FilePath 11 | 12 | data Trackable 13 | = GitRepo GitRepoTrackable 14 | | InboxDir InboxDirTrackable 15 | deriving (Show, Eq) 16 | 17 | data GitRepoTrackable 18 | = GitRepoTrackable GitRepoPath C.LocationSpec 19 | deriving (Show, Eq) 20 | 21 | data InboxDirTrackable 22 | = InboxDirTrackable InboxPath C.LocationSpec 23 | deriving (Show, Eq) 24 | 25 | data NHGit 26 | = NHGit GitRepoTrackable NHGitItem 27 | deriving (Show, Eq) 28 | 29 | data NHFile 30 | = NHFile InboxDirTrackable FilePath 31 | deriving (Show, Eq) 32 | 33 | data NHGitItem 34 | = NHStatus GP.GitStatus 35 | | NHUnpushedBranch GP.GitBranch 36 | | NHNotGitRepo 37 | deriving (Show, Eq) 38 | -------------------------------------------------------------------------------- /src/Trackable/Util.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE ExistentialQuantification #-} 3 | 4 | module Trackable.Util where 5 | 6 | import qualified Turtle as Tu 7 | import qualified Data.Text as T 8 | import Control.Exception.Base 9 | import Control.Monad.Catch 10 | 11 | 12 | data NoStringConversion = NoStringConversion T.Text 13 | deriving (Show) 14 | 15 | instance Exception NoStringConversion 16 | 17 | pathToTextOrError :: Tu.FilePath -> Tu.Shell T.Text 18 | pathToTextOrError path = 19 | case (Tu.toText path) of 20 | Left l -> 21 | throwM $ NoStringConversion l 22 | Right r -> pure r 23 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # resolver: ghcjs-0.1.0_ghc-7.10.2 15 | # resolver: 16 | # name: custom-snapshot 17 | # location: "./custom-snapshot.yaml" 18 | resolver: lts-16.6 19 | 20 | # User packages to be built. 21 | # Various formats can be used as shown in the example below. 22 | # 23 | # packages: 24 | # - some-directory 25 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 26 | # - location: 27 | # git: https://github.com/commercialhaskell/stack.git 28 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 29 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 30 | # extra-dep: true 31 | # subdirs: 32 | # - auto-update 33 | # - wai 34 | # 35 | # A package marked 'extra-dep: true' will only be built if demanded by a 36 | # non-dependency (i.e. a user package), and its test suites and benchmarks 37 | # will not be run. This is useful for tweaking upstream packages. 38 | packages: 39 | - . 40 | # Dependency packages to be pulled from upstream that are not in the resolver 41 | # (e.g., acme-missiles-0.3) 42 | # extra-deps: [] 43 | 44 | # Override default flag values for local packages and extra-deps 45 | # flags: {} 46 | 47 | # Extra package databases containing global packages 48 | # extra-package-dbs: [] 49 | 50 | # Control whether we use the GHC we find on the path 51 | # system-ghc: true 52 | # 53 | # Require a specific version of stack, using version ranges 54 | # require-stack-version: -any # Default 55 | # require-stack-version: ">=1.6" 56 | # 57 | # Override the architecture used by stack, especially useful on Windows 58 | # arch: i386 59 | # arch: x86_64 60 | # 61 | # Extra directories used by stack for building 62 | # extra-include-dirs: [/path/to/dir] 63 | # extra-lib-dirs: [/path/to/dir] 64 | # 65 | # Allow a newer minor version of GHC than the snapshot specifies 66 | # compiler-check: newer-minor 67 | 68 | ghc-options: 69 | "$locals": -Wall -Werror -Wwarn=missing-local-signatures 70 | 71 | nix: 72 | packages: 73 | - zlib 74 | -------------------------------------------------------------------------------- /stack.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: [] 7 | snapshots: 8 | - completed: 9 | size: 531718 10 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/16/6.yaml 11 | sha256: 230a7266fc11f76222bd3bb68e9503ed11d553060a752f164bff6753ed03e271 12 | original: lts-16.6 13 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | main :: IO () 2 | main = putStrLn "Test suite not yet implemented" 3 | --------------------------------------------------------------------------------