├── .gitignore ├── .travis.yml ├── ChangeLog.md ├── LICENSE ├── README.md ├── Setup.hs ├── jbi.cabal ├── lib └── System │ ├── JBI.hs │ └── JBI │ ├── Commands.hs │ ├── Commands │ ├── BuildTool.hs │ ├── Cabal.hs │ ├── Nix.hs │ ├── Stack.hs │ └── Tool.hs │ ├── Config.hs │ ├── Environment.hs │ └── Tagged.hs └── src └── Main.hs /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-* 3 | cabal-dev 4 | *.o 5 | *.hi 6 | *.chi 7 | *.chs.h 8 | *.dyn_o 9 | *.dyn_hi 10 | .hpc 11 | .hsenv 12 | .cabal-sandbox/ 13 | cabal.sandbox.config 14 | *.prof 15 | *.aux 16 | *.hp 17 | *.eventlog 18 | .stack-work/ 19 | cabal.project.local 20 | .HTF/ 21 | /shell.nix 22 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # This file has been generated -- see https://github.com/hvr/multi-ghc-travis 2 | language: c 3 | sudo: false 4 | 5 | cache: 6 | directories: 7 | - $HOME/.cabsnap 8 | - $HOME/.cabal/packages 9 | 10 | before_cache: 11 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log 12 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.tar 13 | 14 | matrix: 15 | include: 16 | - env: CABALVER=1.22 GHCVER=7.10.2 17 | compiler: ": #GHC 7.10.2" 18 | addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.2], sources: [hvr-ghc]}} 19 | - env: CABALVER=1.24 GHCVER=8.0.2 20 | compiler: ": #GHC 8.0.2" 21 | addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.2], sources: [hvr-ghc]}} 22 | - env: CABALVER=2.0 GHCVER=8.2.2 23 | compiler: ": #GHC 8.2.2" 24 | addons: {apt: {packages: [cabal-install-2.0,ghc-8.2.2], sources: [hvr-ghc]}} 25 | - env: CABALVER=head GHCVER=head 26 | compiler: ": #GHC head" 27 | addons: {apt: {packages: [cabal-install-head,ghc-head], sources: [hvr-ghc]}} 28 | 29 | allow_failures: 30 | - env: CABALVER=head GHCVER=head 31 | 32 | before_install: 33 | - unset CC 34 | - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH 35 | 36 | install: 37 | - cabal --version 38 | - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]" 39 | - if [ -f $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz ]; 40 | then 41 | zcat $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz > 42 | $HOME/.cabal/packages/hackage.haskell.org/00-index.tar; 43 | fi 44 | - travis_retry cabal update -v 45 | - sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config 46 | - cabal install --only-dependencies --enable-tests --enable-benchmarks --dry -v > installplan.txt 47 | - sed -i -e '1,/^Resolving /d' installplan.txt; cat installplan.txt 48 | 49 | # check whether current requested install-plan matches cached package-db snapshot 50 | - if diff -u $HOME/.cabsnap/installplan.txt installplan.txt; 51 | then 52 | echo "cabal build-cache HIT"; 53 | rm -rfv .ghc; 54 | cp -a $HOME/.cabsnap/ghc $HOME/.ghc; 55 | cp -a $HOME/.cabsnap/lib $HOME/.cabsnap/share $HOME/.cabsnap/bin $HOME/.cabal/; 56 | else 57 | echo "cabal build-cache MISS"; 58 | rm -rf $HOME/.cabsnap; 59 | mkdir -p $HOME/.ghc $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin; 60 | cabal install --only-dependencies --enable-tests --enable-benchmarks; 61 | fi 62 | 63 | # snapshot package-db on cache miss 64 | - if [ ! -d $HOME/.cabsnap ]; 65 | then 66 | echo "snapshotting package-db to build-cache"; 67 | mkdir $HOME/.cabsnap; 68 | cp -a $HOME/.ghc $HOME/.cabsnap/ghc; 69 | cp -a $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin installplan.txt $HOME/.cabsnap/; 70 | fi 71 | 72 | # Here starts the actual work to be performed for the package under test; 73 | # any command which exits with a non-zero exit code causes the build to fail. 74 | script: 75 | - if [ -f configure.ac ]; then autoreconf -i; fi 76 | - cabal configure --enable-tests --enable-benchmarks -v2 # -v2 provides useful information for debugging 77 | - cabal build # this builds all libraries and executables (including tests/benchmarks) 78 | - cabal test 79 | - cabal check 80 | - cabal haddock # tests that documentation can be generated 81 | - cabal sdist # tests that a source-distribution can be generated 82 | 83 | # Check that the resulting source distribution can be built & installed. 84 | # If there are no other `.tar.gz` files in `dist`, this can be even simpler: 85 | # `cabal install --force-reinstalls dist/*-*.tar.gz` 86 | - SRC_TGZ=$(cabal info . | awk '{print $2;exit}').tar.gz && 87 | (cd dist && cabal install --force-reinstalls "$SRC_TGZ") 88 | 89 | # EOF 90 | -------------------------------------------------------------------------------- /ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Revision history for jbi 2 | 3 | ## 0.2.0.0 -- 2018-02-07 4 | 5 | * Add a `--version` (and `-V`) flag to the executable. 6 | 7 | * `jbi repl` now takes an optional `--repl-opts` which is passed 8 | through to the underlying REPL (e.g. `ghci`). 9 | 10 | * No longer supply `-ferror-spans` by default. 11 | 12 | * A `--debug` argument prints out all commands run. 13 | 14 | This results in _many_ API changes; as a sample: 15 | 16 | * `GlobalEnv` has been renamed to `ToolEnv` 17 | * A `Config` type is now provided for run-time configuration. 18 | This is now taken by most of the running commands. 19 | * `Env` wraps the above two types and is an argument to most 20 | `BuildTool` commands. 21 | 22 | * Try and support benchmarking with `cabal+nix` where possible. 23 | 24 | API change: the `NixSupport` type now contains information about 25 | `nix-instantiate`. 26 | 27 | * Better support for getting targets from stack. 28 | 29 | * If a build tool needs the version to check validity it has to 30 | explicitly obtain it. 31 | 32 | API Changes: 33 | 34 | * Change in `canUseCommand` in `BuildTool` class 35 | * Change in `command` field in `Valid` data structure 36 | * Change in `canUseMode` in `CabalMode` class 37 | * Addition of `needsMinCabal` to `CabalMode` class 38 | 39 | * Other small tweaks to reduce the overhead of using _jbi_ over the 40 | build tool itself (parallel validity checking, etc.). 41 | 42 | ## 0.1.0.0 -- 2017-09-05 43 | 44 | * First version. Released on an semi-suspecting world. 45 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2017 Ivan Lazar Miljenovic 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included 12 | in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Just Build It, and hack on! 2 | =========================== 3 | 4 | [![Hackage](https://img.shields.io/hackage/v/jbi.svg)](https://hackage.haskell.org/package/jbi) [![Build Status](https://travis-ci.org/ivan-m/jbi.svg)](https://travis-ci.org/ivan-m/jbi) 5 | 6 | > A "do what I mean" abstraction for Haskell build tools. 7 | 8 | Motivation 9 | ---------- 10 | 11 | You've decided to work on an existing Haskell project. The repository 12 | has been forked, you've cloned it to your computer, and you're about 13 | to start work. What's the first thing you need to do? 14 | 15 | 1) Replace all copyright notices with your own name. 16 | 17 | 2) Swap all tabs and spaces. 18 | 19 | 3) Convert all the code to Literate Haskell because it's such a pain 20 | to write your long prosaic comments whilst remembering to preface 21 | every line with `-- `. 22 | 23 | Actually, unless you're someone with a religious obsession of using 24 | what you prefer no matter what project you're working on or who you're 25 | collaborating with, the first task you generally need to do is: 26 | 27 | 4) Work out which build tool is being used in the project. 28 | 29 | After all, especially as we tend to put in more and more 30 | metadata/hints into our different build tool files rather than just 31 | using `runhaskell Setup.hs `, it's more convenient and friendlier 32 | to work with a project the same way everyone else (especially the 33 | maintainer!) does. 34 | 35 | But this means you need to mentally switch gears and try and remember 36 | the quirks of each individual tool's command line configuration (how 37 | do I launch a REPL again?). Your editing environment may need to be 38 | configured so as to use the correct tool, whatever keyboard shortcuts 39 | you use to run tests needs to change, etc. 40 | 41 | Wouldn't it be nice if there was a simple way your development 42 | environment (including your muscle memory!) could stay the same and 43 | let some common interface handle the changing (without falling into 44 | the trap of trying to [replace everything](https://xkcd.com/927/))? 45 | 46 | Enter _jbi_ 47 | ----------- 48 | 49 | _jbi_ - short for "Just Build It" - is aimed at providing a common 50 | interface between the various Haskell build tools. You should be able 51 | to enter any directory containing a Haskell project and just run `jbi` 52 | and it will successfully determine the best build tool to use, 53 | download dependencies and build the project. 54 | 55 | Currently, _jbi_ knows of the following Haskell build tools: 56 | 57 | * `stack` (with automatic [Nix] support) 58 | 59 | * `cabal-install` with [Nix] support (using `cabal2nix` and `nix-shell`) 60 | 61 | * `cabal-install` using sandboxes 62 | 63 | [Nix]: https://nixos.org/nix/ 64 | 65 | Note that nothing within _jbi_ is inherently Haskell-oriented; it can 66 | be extended to any build tool for any language which has similar 67 | concepts for build tooling. 68 | 69 | How _jbi_ works 70 | --------------- 71 | 72 | To determine which build tool to works, _jbi_ takes into account three 73 | things: 74 | 75 | 1. The order in which the tools are available to be checked in 76 | (currently the same as in the list above). 77 | 78 | 2. Whether a build tool is able to be used (i.e. the tool is installed 79 | and an appropriate project can be found). 80 | 81 | 3. Whether it is already being used. 82 | 83 | Preference is given to tools already in evidence of being used. As an 84 | example, consider the following scenario: 85 | 86 | ``` 87 | myProjectDir/ $ ls 88 | cabal.sandbox.config LICENSE myProject.cabal src/ stack.yaml 89 | ``` 90 | 91 | If both `cabal-install` and `stack` are available, then - despite the 92 | presence of a `stack.yaml` - the presence of a sandbox configuration 93 | indicates that a preference has been made for using them. 94 | 95 | ### Features 96 | 97 | * Automatically install dependencies for and enable test-suites and 98 | benchmarks. 99 | 100 | * Attempt to re-configure (including installing dependencies) if 101 | builds fail (which `stack` already provides) 102 | 103 | * The equivalent of `cabal run` for `stack`. 104 | 105 | * Print out a list of targets (equivalent of `stack ide targets`, for 106 | which `cabal-install` does not have an analogue). 107 | 108 | * Detailed debugging information about tool availability. 109 | 110 | * Work within any sub-directory of a project (no need to make sure 111 | you're running from the root directory!). 112 | 113 | ### Caveats 114 | 115 | _jbi_ will not: 116 | 117 | * Generate a `stack.yaml` for you. This is an explicit opt-in of 118 | wanting to use `stack`, and furthermore isn't possible to determine 119 | whether you want it just for the current package or if it's part of 120 | a larger multi-package project. 121 | 122 | * Install the result of the build for you. _jbi_ is purely for 123 | developmental purposes. 124 | 125 | * Allow you to not build the test suite or benchmarks (unless you 126 | specifically build a specific target). 127 | 128 | * Allow you to have flexible builds, pass through extra command-line 129 | options, etc. It is opinionated in how it does things to cover the 130 | common cases. 131 | 132 | Furthermore: 133 | 134 | * I have only recently started using [Nix] (both with Stack and 135 | cabal-install) and as such may not have it quite right (it seems to 136 | work with me though). 137 | 138 | Fortuitously Anticipated Queries 139 | -------------------------------- 140 | 141 | ### Why isn't my build tool of choice being used? 142 | 143 | Run `jbi info details` to find the information being used to choose 144 | the build tool. The chosen build tool will have: 145 | 146 | * `"installation"` non-null. 147 | * `"usable": true` 148 | * A non-null `"project"` 149 | 150 | Preference is given to: 151 | 152 | * Build tools with `"artifactsPresent": true` 153 | * Higher up in the list. 154 | 155 | ### What are these artifacts? 156 | 157 | "Artifacts" is the term used by _jbi_ to denote the build-tool 158 | specific files/directories found within the project that indicate it 159 | is being worked upon. 160 | 161 | These are: 162 | 163 | _stack_ 164 | ~ `.stack-work/` 165 | _cabal+nix_ 166 | ~ `shell.nix` or `default.nix` 167 | _cabal+sandbox_ 168 | ~ `cabal.sandbox.config` (note that the sandbox itself may be in a 169 | different directory) 170 | 171 | `jbi prepare` will generate these; `jbi clean` will remove them (with 172 | any other files/directories likely to have been produced as part of 173 | the build process). Typically you will never need to explicitly run 174 | `jbi prepare`. 175 | 176 | ### Stack doesn't seem to be using Nix 177 | 178 | For [Nix] support to work, you need to [configure your 179 | `stack.yaml`](https://docs.haskellstack.org/en/stable/nix_integration/). 180 | 181 | ### Why can't I use Stack with shell.nix? 182 | 183 | For a project with no `.stack-work/`, _jbi_ takes the presence of a 184 | `shell.nix` file to indicate that the project is using _cabal+nix_, 185 | irregardless as to whether a `stack.yaml` file is present. 186 | 187 | There are two ways you can work around this: 188 | 189 | 1. Explicitly create a `.stack-work/` directory; as _stack_ has a higher 190 | priority, _jbi_ will then pick it over _cabal+nix_. Note, however, 191 | you may also need to explicitly run `stack setup` if using a 192 | non-system GHC. 193 | 194 | 2. Use a different filename other than `shell.nix` (remember to 195 | specify the filename properly in the `shell-file` section!). 196 | 197 | The latter is preferred as it will allow more of _jbi_'s automatic 198 | features to work (e.g. calling `stack setup`). 199 | 200 | ### How can I re-generate my shell.nix after updating my .cabal file? 201 | 202 | **For _cabal+nix_.** 203 | 204 | Run `jbi prepare`. This is likely the only scenario you will ever 205 | need to explicitly run this command in. 206 | 207 | ### Why don't I have benchmarking support with _cabal+nix_? 208 | 209 | Benchmarking using _cabal+nix_ requires support from `nixpkgs`. This 210 | is currently present in the `unstable` branch but is not yet present 211 | in a release (but should hopefully be found in `18.03`). 212 | 213 | You can verify whether your version of `nixpkgs` supports benchmarking 214 | Haskell code with: 215 | 216 | ```bash 217 | nix-instantiate --eval --expr 'with import {}; haskell.lib ? doBenchmark' 218 | ``` 219 | 220 | Note that _jbi_ currently doesn't support specifying which channel you 221 | are using and defaults to `nixpkgs`. If you are using `unstable` you 222 | can try to manually configure by editing the generated `shell.nix` and 223 | replacing `` with `` (or whatever you have called 224 | that channel) and running: 225 | 226 | ```bash 227 | nix-shell --arg doBenchmark true \ 228 | --run 'cabal configure --enable-tests --enable-benchmarks' 229 | ``` 230 | 231 | ### How do I add a new build tool? 232 | 233 | Pull requests are welcome. 234 | 235 | To add a new tool, you need to create an instance of the `BuildTool` 236 | class from `System.JBI.Commands.BuildTool`, and then insert your new 237 | tool into an appropriate place in `defaultTools` in `System.JBI`. 238 | 239 | ### What about languages other than Haskell? 240 | 241 | If, for some reason, you wish to use a language other than Haskell and 242 | would like to use _jbi_ with it, you're more than welcome to send me a 243 | pull request. 244 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /jbi.cabal: -------------------------------------------------------------------------------- 1 | name: jbi 2 | version: 0.2.0.0 3 | synopsis: Just Build It - a "do what I mean" abstraction for Haskell build tools 4 | description: 5 | If you work with multiple Haskell projects, it can be annoying have to 6 | change gears mentally as to which set of tooling you have to work with 7 | for each one (configuring your editor, or even just the command-line). 8 | . 9 | @jbi@ aims to provide a common interface to the various Haskell build 10 | tools available and automatically determine which one you should use, 11 | so you can get back to hacking on your code, rather than on your 12 | environment. 13 | license: MIT 14 | license-file: LICENSE 15 | author: Ivan Lazar Miljenovic 16 | maintainer: Ivan.Miljenovic@gmail.com 17 | copyright: Ivan Lazar Miljenovic 18 | category: Development 19 | build-type: Simple 20 | extra-source-files: ChangeLog.md, README.md 21 | cabal-version: >=1.10 22 | tested-with: GHC == 7.10.2, GHC == 8.0.2, GHC == 8.2.2, GHC == 8.3.* 23 | 24 | source-repository head 25 | type: git 26 | location: https://github.com/ivan-m/jbi.git 27 | 28 | library 29 | exposed-modules: System.JBI 30 | , System.JBI.Commands 31 | , System.JBI.Commands.BuildTool 32 | , System.JBI.Commands.Cabal 33 | , System.JBI.Commands.Nix 34 | , System.JBI.Commands.Stack 35 | , System.JBI.Commands.Tool 36 | , System.JBI.Config 37 | , System.JBI.Environment 38 | , System.JBI.Tagged 39 | 40 | build-depends: base >=4.8 && <4.13 41 | , aeson >= 0.11.1.0 && < 1.3 42 | , Cabal >= 1.22.0.0 && < 2.1 43 | , directory >= 1.2.5.0 44 | , filepath >= 1.4.0.0 && < 1.5 45 | , monad-parallel == 0.7.* 46 | , process >= 1.4.3.0 && < 1.7 47 | , tagged == 0.8.* 48 | hs-source-dirs: lib 49 | default-language: Haskell2010 50 | ghc-options: -Wall 51 | 52 | executable jbi 53 | main-is: Main.hs 54 | 55 | other-modules: Paths_jbi 56 | 57 | build-depends: jbi 58 | , base 59 | , aeson-pretty >= 0.7.2 && < 0.9 60 | , optparse-applicative >= 0.13.0.0 && < 0.15 61 | , text == 1.* 62 | 63 | hs-source-dirs: src 64 | default-language: Haskell2010 65 | ghc-options: -Wall -threaded 66 | -------------------------------------------------------------------------------- /lib/System/JBI.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass, DeriveGeneric #-} 2 | 3 | {- | 4 | Module : System.JBI 5 | Description : Just Build It 6 | Copyright : (c) Ivan Lazar Miljenovic 7 | License : MIT 8 | Maintainer : Ivan.Miljenovic@gmail.com 9 | 10 | 11 | 12 | -} 13 | module System.JBI 14 | ( WrappedTool 15 | , Valid 16 | , defaultTools 17 | , withTool 18 | , chooseTool 19 | , toolName 20 | , infoProjectDir 21 | -- * System state\/environment 22 | , Env(..) 23 | , getEnvironment 24 | , ToolEnv(..) 25 | , toolEnv 26 | -- ** Runtime configuration 27 | , Config(..) 28 | , defaultConfig 29 | -- * Information\/Diagnostics 30 | , Information (..) 31 | , getInformation 32 | -- * Commands 33 | , prepare 34 | , targets 35 | , build 36 | , repl 37 | , clean 38 | , test 39 | , bench 40 | , exec 41 | , run 42 | , update 43 | ) where 44 | 45 | import System.JBI.Commands 46 | import System.JBI.Commands.BuildTool (ToolInformation) 47 | import System.JBI.Commands.Cabal 48 | import System.JBI.Commands.Stack 49 | import System.JBI.Config 50 | import System.JBI.Environment 51 | 52 | import Control.Applicative ((<|>)) 53 | import Data.Aeson (ToJSON) 54 | import Data.List (find) 55 | import Data.Maybe (catMaybes, listToMaybe) 56 | import Data.Proxy (Proxy(..)) 57 | import GHC.Generics (Generic) 58 | 59 | import qualified Control.Monad.Parallel as P 60 | 61 | -------------------------------------------------------------------------------- 62 | 63 | defaultTools :: [WrappedTool Proxy] 64 | defaultTools = [ Wrapped (Proxy :: Proxy Stack) 65 | , Wrapped (Proxy :: Proxy (Cabal Nix)) 66 | , Wrapped (Proxy :: Proxy (Cabal Sandbox)) 67 | ] 68 | 69 | withTool :: Config -> IO res 70 | -> (Env -> WrappedTool Valid -> IO res) 71 | -> [WrappedTool proxy] -> IO res 72 | withTool cfg onFailure f tools = do 73 | env <- getEnvironment cfg 74 | mtool <- chooseTool env tools 75 | maybe onFailure (f env) mtool 76 | 77 | chooseTool :: Env -> [WrappedTool proxy] -> IO (Maybe (WrappedTool Valid)) 78 | chooseTool env tools = do 79 | valid <- catMaybes <$> P.mapM (checkValidity env) tools 80 | return (find alreadyUsed valid <|> listToMaybe valid) 81 | 82 | data Information = Information 83 | { environment :: !ToolEnv 84 | , toolDetails :: ![WrappedTool ToolInformation] 85 | } deriving (Show, Generic, ToJSON) 86 | 87 | getInformation :: Config -> [WrappedTool proxy] -> IO Information 88 | getInformation cfg tools = do 89 | tenv <- toolEnv cfg 90 | Information tenv <$> mapMer (toolInformation (Env cfg tenv)) tools 91 | where 92 | -- When debugging, output of tool commands get mangled in parallel 93 | mapMer | debugMode cfg = mapM 94 | | otherwise = P.mapM 95 | 96 | getEnvironment :: Config -> IO Env 97 | getEnvironment cfg = Env cfg <$> toolEnv cfg 98 | -------------------------------------------------------------------------------- /lib/System/JBI/Commands.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances, GADTs, OverloadedStrings, RankNTypes, 2 | StandaloneDeriving #-} 3 | 4 | {- | 5 | Module : System.JBI.Commands 6 | Description : Running a specific build tool 7 | Copyright : (c) Ivan Lazar Miljenovic 8 | License : MIT 9 | Maintainer : Ivan.Miljenovic@gmail.com 10 | 11 | 12 | 13 | -} 14 | module System.JBI.Commands 15 | ( WrappedTool (..) 16 | , Valid 17 | , toolName 18 | , toolInformation 19 | , checkValidity 20 | , alreadyUsed 21 | , infoProjectDir 22 | -- * Commands 23 | , prepare 24 | , targets 25 | , build 26 | , repl 27 | , clean 28 | , test 29 | , bench 30 | , exec 31 | , run 32 | , update 33 | ) where 34 | 35 | import System.JBI.Commands.BuildTool 36 | import System.JBI.Commands.Tool 37 | import System.JBI.Environment 38 | import System.JBI.Tagged 39 | 40 | import Control.Monad (forM) 41 | import Data.Aeson (ToJSON(toJSON)) 42 | import Data.Function (on) 43 | import Data.Proxy (Proxy(..)) 44 | import System.Directory (withCurrentDirectory) 45 | import System.Exit (ExitCode(ExitSuccess), die) 46 | 47 | -------------------------------------------------------------------------------- 48 | 49 | data WrappedTool proxy where 50 | Wrapped :: (NamedTool bt) => proxy bt -> WrappedTool proxy 51 | 52 | -- | Not made polymorphic as there might be extra data contained 53 | -- within. 54 | instance Eq (WrappedTool Proxy) where 55 | (==) = (==) `on` toolName 56 | 57 | -- | Not really a valid instance as it doesn't produce Haskell code. 58 | instance Show (WrappedTool Proxy) where 59 | show = toolName 60 | 61 | deriving instance Show (WrappedTool ToolInformation) 62 | deriving instance Show (WrappedTool Valid) 63 | 64 | instance ToJSON (WrappedTool ToolInformation) where 65 | toJSON = withWrapped toJSON 66 | 67 | withWrapped :: (forall bt. (NamedTool bt) => proxy bt -> res) 68 | -> WrappedTool proxy -> res 69 | withWrapped f (Wrapped bt) = f bt 70 | 71 | toolName :: WrappedTool proxy -> String 72 | toolName = withWrapped prettyName 73 | 74 | toolInformation :: Env -> WrappedTool proxy -> IO (WrappedTool ToolInformation) 75 | toolInformation env (Wrapped pr) = Wrapped <$> commandToolInformation env pr 76 | 77 | -------------------------------------------------------------------------------- 78 | 79 | data Valid bt = Valid 80 | { command :: !(Tagged bt CommandPath) 81 | -- ^ @since 0.2.0.0 82 | , projectDir :: !(Tagged bt ProjectRoot) 83 | , hasArtifacts :: !Bool 84 | -- ^ Only to be used with 'ensurePrepared', 'prepare', 'unprepared'. 85 | } deriving (Eq, Ord, Show, Read) 86 | 87 | alreadyUsed :: WrappedTool Valid -> Bool 88 | alreadyUsed = withWrapped hasArtifacts 89 | 90 | infoProjectDir :: WrappedTool Valid -> ProjectRoot 91 | infoProjectDir = withWrapped (stripTag . projectDir) 92 | 93 | -- This is pretty ugly; one way to clean it up would be to use MaybeT. 94 | checkValidity :: Env -> WrappedTool proxy -> IO (Maybe (WrappedTool Valid)) 95 | checkValidity env (Wrapped p) = fmap Wrapped <$> check p 96 | where 97 | check :: (BuildTool bt) => proxy' bt -> IO (Maybe (Valid bt)) 98 | check _ = do 99 | mcp <- commandPath 100 | case mcp of 101 | Nothing -> return Nothing 102 | Just cp -> do 103 | usbl <- canUseCommand env cp 104 | if not usbl 105 | then return Nothing 106 | else do mroot <- commandProjectRoot cp 107 | forM mroot $ \root -> 108 | Valid cp root <$> hasBuildArtifacts root 109 | 110 | runInProject :: (forall bt. (BuildTool bt) => Tagged bt CommandPath -> IO res) 111 | -> WrappedTool Valid -> IO res 112 | runInProject f (Wrapped val) = withCurrentDirectory (stripTag (projectDir val)) 113 | (f (command val)) 114 | 115 | prepareWrapped :: Env -> WrappedTool Valid -> IO (WrappedTool Valid) 116 | prepareWrapped env wt@(Wrapped val) = do 117 | ec <- runInProject (commandPrepare env) wt 118 | case ec of 119 | ExitSuccess -> do 120 | hasArt <- canUseCommand env (command val) 121 | if hasArt 122 | then return (Wrapped (val { hasArtifacts = True })) 123 | else die "Preparation failed" 124 | _ -> die "Could not prepare" 125 | 126 | runPrepared :: (forall bt. (BuildTool bt) => Env -> Tagged bt CommandPath -> IO res) 127 | -> Env -> WrappedTool Valid -> IO res 128 | runPrepared f env wv = do 129 | wv' <- if not (alreadyUsed wv) 130 | then prepareWrapped env wv 131 | else return wv 132 | runInProject (f env) wv' 133 | 134 | -------------------------------------------------------------------------------- 135 | -- This mimics the actual command-level portion of BuildTool 136 | 137 | prepare :: Env -> WrappedTool Valid -> IO ExitCode 138 | prepare env wv = prepareWrapped env wv >> return ExitSuccess 139 | -- Explicitly prepare. 140 | 141 | targets :: Env -> WrappedTool Valid -> IO [ProjectTarget] 142 | targets = runPrepared ((fmap stripTags .) . commandTargets . envConfig) 143 | 144 | build :: Maybe ProjectTarget -> Env -> WrappedTool Valid -> IO ExitCode 145 | build targ = runPrepared (\env cp -> commandBuild env cp (tagInner (tag targ))) 146 | 147 | repl :: Args -> Maybe ProjectTarget -> Env -> WrappedTool Valid -> IO ExitCode 148 | repl rargs targ = runPrepared (\env cp -> commandRepl env cp (Tagged rargs) (tagInner (tag targ))) 149 | 150 | clean :: Env -> WrappedTool Valid -> IO ExitCode 151 | clean = runPrepared commandClean 152 | 153 | test :: Env -> WrappedTool Valid -> IO ExitCode 154 | test = runPrepared commandTest 155 | 156 | bench :: Env -> WrappedTool Valid -> IO ExitCode 157 | bench = runPrepared commandBench 158 | 159 | exec :: String -> Args -> Env -> WrappedTool Valid -> IO ExitCode 160 | exec cmd args = runPrepared (\env cp -> commandExec env cp cmd args) 161 | 162 | run :: ProjectTarget -> Args -> Env -> WrappedTool Valid -> IO ExitCode 163 | run targ args = runPrepared (\env cp -> commandRun env cp (tag targ) args) 164 | 165 | update :: Env -> WrappedTool Valid -> IO ExitCode 166 | update = runPrepared commandUpdate 167 | -------------------------------------------------------------------------------- /lib/System/JBI/Commands/BuildTool.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass, DeriveGeneric, FlexibleContexts, 2 | MultiParamTypeClasses #-} 3 | 4 | {- | 5 | Module : System.JBI.Commands.Common 6 | Description : How to handle build tools 7 | Copyright : (c) Ivan Lazar Miljenovic 8 | License : MIT 9 | Maintainer : Ivan.Miljenovic@gmail.com 10 | 11 | 12 | 13 | -} 14 | module System.JBI.Commands.BuildTool where 15 | 16 | import System.JBI.Commands.Tool 17 | import System.JBI.Environment 18 | import System.JBI.Tagged 19 | 20 | import Control.Applicative (liftA2) 21 | import Control.Exception (SomeException(SomeException), handle) 22 | import Control.Monad (filterM, forM) 23 | import Data.Aeson (ToJSON(toJSON)) 24 | import Data.List (span) 25 | import Data.Maybe (isJust) 26 | import Data.String (IsString(..)) 27 | import GHC.Generics (Generic) 28 | import System.Directory (doesFileExist, getCurrentDirectory, listDirectory) 29 | import System.Exit (ExitCode) 30 | import System.FilePath (dropTrailingPathSeparator, isDrive, takeDirectory, 31 | ()) 32 | 33 | -------------------------------------------------------------------------------- 34 | 35 | class (Tool bt) => BuildTool bt where 36 | 37 | -- | Make sure there's nothing in the environment preventing us from 38 | -- using this tool. 39 | -- 40 | -- For example, a minimum version, need another tool installed, etc. 41 | -- 42 | -- @since 0.2.0.0 43 | canUseCommand :: Env -> Tagged bt CommandPath -> IO Bool 44 | canUseCommand _ _ = return True 45 | 46 | -- | Try and determine the root directory for this project. 47 | commandProjectRoot :: Tagged bt CommandPath -> IO (Maybe (Tagged bt ProjectRoot)) 48 | 49 | hasBuildArtifacts :: Tagged bt ProjectRoot -> IO Bool 50 | 51 | -- | Ensure's that 'hasBuildArtifacts' is 'True' afterwards; 52 | -- i.e. forces this build tool. 53 | -- 54 | -- The intent for this is \"No build tool is currently being used 55 | -- (i.e. 'hasBuildArtifacts' is 'False' for all) so start using 56 | -- the one chosen.\" This will not do the equivalent of @stack 57 | -- init@ and create project configuration. 58 | -- 59 | -- Some manual fiddling is allowed after this. 60 | -- 61 | -- Assumes 'canUseBuildTool'. Should be run within 'ProjectRoot'. 62 | commandPrepare :: Env -> Tagged bt CommandPath -> IO ExitCode 63 | 64 | -- | Assumes 'canUseBuildTool'. Should be run within 'ProjectRoot'. 65 | commandTargets :: Config -> Tagged bt CommandPath -> IO [Tagged bt ProjectTarget] 66 | 67 | -- | Assumes 'canUseBuildTool'. Should be run within 'ProjectRoot'. 68 | commandBuild :: Env -> Tagged bt CommandPath -> Maybe (Tagged bt ProjectTarget) 69 | -> IO ExitCode 70 | 71 | -- | Launch a @ghci@ session within the current project. 72 | -- 73 | -- Takes a list of interpreter arguments. 74 | -- 75 | -- Assumes 'canUseBuildTool'. Should be run within 'ProjectRoot'. 76 | commandRepl :: Env -> Tagged bt CommandPath -> Tagged bt Args 77 | -> Maybe (Tagged bt ProjectTarget) -> IO ExitCode 78 | 79 | -- | Remove /all/ build artifacts of using this build tool (that is, 80 | -- afterwards 'hasBuildArtifacts' should return 'False'). 81 | -- 82 | -- Assumes 'canUseBuildTool'. Should be run within 'ProjectRoot'. 83 | commandClean :: Env -> Tagged bt CommandPath -> IO ExitCode 84 | 85 | -- | Assumes 'canUseBuildTool'. Should be run within 'ProjectRoot'. 86 | commandTest :: Env -> Tagged bt CommandPath -> IO ExitCode 87 | 88 | -- | Assumes 'canUseBuildTool'. Should be run within 'ProjectRoot'. 89 | commandBench :: Env -> Tagged bt CommandPath -> IO ExitCode 90 | 91 | -- | Run an external command within this environment. 92 | -- 93 | -- Assumes 'canUseBuildTool'. Should be run within 'ProjectRoot'. 94 | commandExec :: Env -> Tagged bt CommandPath -> String -> Args -> IO ExitCode 95 | 96 | -- | Run an executable component within this environment (building 97 | -- it first if required). 98 | -- 99 | -- Assumes 'canUseBuildTool'. Should be run within 'ProjectRoot'. 100 | commandRun :: Env -> Tagged bt CommandPath -> Tagged bt ProjectTarget 101 | -> Args -> IO ExitCode 102 | 103 | -- | Update index of available packages. 104 | commandUpdate :: Env -> Tagged bt CommandPath -> IO ExitCode 105 | 106 | -- | This class exists because of: 107 | -- 108 | -- a) Distinguish the different Cabal variants 109 | -- 110 | -- b) Be able to use a wrapper GADT that takes a @proxy bt@ and can 111 | -- be an instance of 'BuildTool' but not this. 112 | class (BuildTool bt) => NamedTool bt where 113 | prettyName :: proxy bt -> String 114 | prettyName = nameOfCommand . proxy commandName 115 | 116 | data ToolInformation bt = ToolInformation 117 | { tool :: !String 118 | , information :: !(Maybe (BuildUsage bt)) 119 | } deriving (Eq, Show, Read, Generic, ToJSON) 120 | 121 | commandToolInformation :: (NamedTool bt) => Env -> proxy bt 122 | -> IO (ToolInformation bt) 123 | commandToolInformation env pr = 124 | ToolInformation (prettyName pr) <$> commandBuildUsage env 125 | 126 | data BuildUsage bt = BuildUsage 127 | { installation :: !(Installed bt) 128 | , usable :: !Bool 129 | , project :: !(Maybe (BuildProject bt)) 130 | } deriving (Eq, Show, Read, Generic, ToJSON) 131 | 132 | data BuildProject bt = BuildProject 133 | { projectRoot :: !(Tagged bt ProjectRoot) 134 | , artifactsPresent :: !Bool 135 | } deriving (Eq, Show, Read, Generic, ToJSON) 136 | 137 | -- | A 'Nothing' indicates that this tool cannot be used for this 138 | -- project (i.e. needs configuration). 139 | commandBuildUsage :: (BuildTool bt) => Env 140 | -> IO (Maybe (BuildUsage bt)) 141 | commandBuildUsage env = do 142 | mInst <- commandInformation (envConfig env) 143 | forM mInst $ \inst -> 144 | BuildUsage inst <$> canUseCommand env (path inst) 145 | <*> commandBuildProject (path inst) 146 | 147 | 148 | commandBuildProject :: (BuildTool bt) => Tagged bt CommandPath 149 | -> IO (Maybe (BuildProject bt)) 150 | commandBuildProject cmd = do 151 | mroot <- commandProjectRoot cmd 152 | forM mroot $ \root -> 153 | BuildProject root <$> hasBuildArtifacts root 154 | 155 | canUseBuildTool :: Maybe (BuildUsage bt) -> Bool 156 | canUseBuildTool = maybe False (liftA2 (&&) usable (isJust . project)) 157 | 158 | -------------------------------------------------------------------------------- 159 | 160 | newtype ProjectRoot = ProjectRoot { rootPath :: FilePath } 161 | deriving (Eq, Ord, Show, Read) 162 | 163 | instance IsString ProjectRoot where 164 | fromString = ProjectRoot 165 | 166 | instance ToJSON ProjectRoot where 167 | toJSON = toJSON . rootPath 168 | 169 | -- | TODO: determine if this is a library, executable, test or benchmark component. 170 | newtype ProjectTarget = ProjectTarget { projectTarget :: String } 171 | deriving (Eq, Ord, Show, Read) 172 | 173 | instance IsString ProjectTarget where 174 | fromString = ProjectTarget 175 | 176 | componentName :: Tagged bt ProjectTarget -> String 177 | componentName = safeLast . splitOn ':' . stripTag 178 | 179 | safeLast :: [[a]] -> [a] 180 | safeLast [] = [] 181 | safeLast ass = last ass 182 | 183 | splitOn :: (Eq a) => a -> [a] -> [[a]] 184 | splitOn sep = go 185 | where 186 | go [] = [] 187 | go as = case span (/= sep) as of 188 | (seg, []) -> seg : [] 189 | (seg, _:as') -> seg : go as' 190 | 191 | -------------------------------------------------------------------------------- 192 | 193 | -- | If an exception occurs, return 'Nothing' 194 | tryIO :: IO (Maybe a) -> IO (Maybe a) 195 | tryIO = handle (\SomeException{} -> return Nothing) 196 | 197 | -- | Recurse up until you find a directory containing a file that 198 | -- matches the predicate, returning that directory. 199 | recurseUpFindFile :: (FilePath -> Bool) -> IO (Maybe FilePath) 200 | recurseUpFindFile p = tryIO $ go . dropTrailingPathSeparator =<< getCurrentDirectory 201 | where 202 | go dir = do cntns <- listDirectory dir 203 | files <- filterM (doesFileExist . (dir )) cntns 204 | if any p files 205 | then return (Just dir) 206 | -- We do the base case check here so we can 207 | -- actually check the top level directory. 208 | else if isDrive dir 209 | then return Nothing 210 | else go (takeDirectory dir) 211 | -------------------------------------------------------------------------------- /lib/System/JBI/Commands/Cabal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP, OverloadedStrings #-} 2 | 3 | {- | 4 | Module : System.JBI.Commands.Cabal 5 | Description : cabal-install support 6 | Copyright : (c) Ivan Lazar Miljenovic 7 | License : MIT 8 | Maintainer : Ivan.Miljenovic@gmail.com 9 | 10 | 11 | 12 | -} 13 | module System.JBI.Commands.Cabal 14 | ( Cabal 15 | , CabalMode 16 | , Sandbox 17 | , Nix 18 | ) where 19 | 20 | import System.JBI.Commands.BuildTool 21 | import System.JBI.Commands.Nix 22 | import System.JBI.Commands.Tool 23 | import System.JBI.Environment 24 | import System.JBI.Tagged 25 | 26 | import Control.Applicative (liftA2, (<*>)) 27 | import Control.Monad (filterM) 28 | import Data.Bool (bool) 29 | import Data.Maybe (isJust, maybeToList) 30 | import Data.Proxy (Proxy(Proxy)) 31 | import Data.Version (Version, makeVersion) 32 | import System.Directory (doesFileExist, getCurrentDirectory, listDirectory, 33 | removeFile) 34 | import System.Exit (ExitCode, die, exitSuccess) 35 | import System.FilePath (takeExtension, ()) 36 | import System.IO.Error (ioError, isDoesNotExistError, tryIOError) 37 | 38 | import qualified Distribution.Package as CPkg 39 | import Distribution.PackageDescription (GenericPackageDescription, 40 | condBenchmarks, 41 | condExecutables, 42 | condLibrary, 43 | condTestSuites) 44 | import qualified Distribution.PackageDescription.Parse as CParse 45 | import Distribution.Verbosity (silent) 46 | 47 | #if MIN_VERSION_Cabal (2,0,0) 48 | import Distribution.Types.UnqualComponentName (UnqualComponentName, 49 | unUnqualComponentName) 50 | #endif 51 | 52 | -------------------------------------------------------------------------------- 53 | 54 | data Cabal mode 55 | 56 | instance Tool (Cabal mode) where 57 | commandName = "cabal" 58 | 59 | instance (CabalMode mode) => BuildTool (Cabal mode) where 60 | canUseCommand = canUseMode 61 | 62 | commandProjectRoot = cabalProjectRoot 63 | 64 | hasBuildArtifacts = hasModeArtifacts 65 | 66 | commandPrepare = cabalPrepare 67 | 68 | commandTargets = cabalTargets 69 | 70 | commandBuild env cmd = cabalTry env cmd . cabalBuild env cmd 71 | 72 | commandRepl env cmd rargs = cabalTry env cmd . cabalRepl env cmd rargs 73 | 74 | commandClean = cabalClean 75 | 76 | commandTest = liftA2 (<*>) cabalTry cabalTest 77 | 78 | commandBench = liftA2 (<*>) cabalTry cabalBench 79 | 80 | commandExec = cabalExec 81 | 82 | commandRun env cmd = (cabalTry env cmd .) . cabalRun env cmd 83 | 84 | commandUpdate = cabalUpdate 85 | 86 | cabalTry :: (CabalMode mode) => Env -> Tagged (Cabal mode) CommandPath 87 | -> IO ExitCode -> IO ExitCode 88 | cabalTry env cmd = tryCommand "Command failed, trying to re-configure" 89 | (cabalConfigure env cmd) 90 | 91 | instance (CabalMode mode) => NamedTool (Cabal mode) where 92 | prettyName p = "cabal+" ++ modeName (getMode p) 93 | 94 | getMode :: proxy (Cabal mode) -> Proxy mode 95 | getMode _ = Proxy 96 | 97 | class CabalMode mode where 98 | modeName :: proxy mode -> String 99 | 100 | -- | Optional minimal version of @cabal@ required. Used to provide 101 | -- default instance of @canUseMode@. 102 | -- 103 | -- @since 0.2.0.0 104 | needsMinCabal :: Maybe (Tagged (Cabal mode) Version) 105 | needsMinCabal = Nothing 106 | 107 | -- | @since 0.2.0.0 108 | canUseMode :: Env -> Tagged (Cabal mode) CommandPath -> IO Bool 109 | canUseMode env cp = case needsMinCabal of 110 | Nothing -> return hasGHC 111 | Just mv -> maybe hasGHC (mv <=) 112 | <$> commandVersion (envConfig env) cp 113 | where 114 | hasGHC = isJust (ghc (envTools env)) 115 | 116 | cabalProjectRoot :: Tagged (Cabal mode) CommandPath 117 | -> IO (Maybe (Tagged (Cabal mode) ProjectRoot)) 118 | cabalProjectRoot = withTaggedF go 119 | where 120 | -- Type signature needed to make withTaggedF happy, though we 121 | -- don't actually use the command itself for this. 122 | go :: FilePath -> IO (Maybe FilePath) 123 | go _ = recurseUpFindFile isCabalFile 124 | 125 | hasModeArtifacts :: Tagged (Cabal mode) ProjectRoot -> IO Bool 126 | 127 | cabalPrepare :: Env -> Tagged (Cabal mode) CommandPath -> IO ExitCode 128 | 129 | cabalTargets :: Config -> Tagged (Cabal mode) CommandPath 130 | -> IO [Tagged (Cabal mode) ProjectTarget] 131 | cabalTargets _ = withTaggedF go 132 | where 133 | -- Make withTaggedF happy 134 | go :: FilePath -> IO [String] 135 | go _ = cabalFileComponents 136 | 137 | -- | This is an additional function than found in 'BuildTool'. May 138 | -- include installing dependencies. 139 | cabalConfigure :: Env -> Tagged (Cabal mode) CommandPath -> IO ExitCode 140 | 141 | cabalBuild :: Env -> Tagged (Cabal mode) CommandPath 142 | -> Maybe (Tagged (Cabal mode) ProjectTarget) -> IO ExitCode 143 | cabalBuild = commandArgTarget "build" 144 | 145 | cabalRepl :: Env -> Tagged (Cabal mode) CommandPath 146 | -> Tagged (Cabal mode) Args 147 | -> Maybe (Tagged (Cabal mode) ProjectTarget) 148 | -> IO ExitCode 149 | cabalRepl env cmd rargs = commandArgsTarget ("repl" : ghcArgs) env cmd 150 | where 151 | ghcArgs = ["--ghc-options", unwords (stripTag rargs :: Args)] 152 | 153 | cabalClean :: Env -> Tagged (Cabal mode) CommandPath -> IO ExitCode 154 | 155 | cabalTest :: Env -> Tagged (Cabal mode) CommandPath -> IO ExitCode 156 | cabalTest = commandArg "test" 157 | 158 | cabalBench :: Env -> Tagged (Cabal mode) CommandPath -> IO ExitCode 159 | cabalBench = commandArg "bench" 160 | 161 | cabalExec :: Env -> Tagged (Cabal mode) CommandPath -> String -> Args -> IO ExitCode 162 | cabalExec env cmd prog progArgs = commandArgs args env cmd 163 | where 164 | args = "exec" : prog : "--" : progArgs 165 | 166 | cabalRun :: Env -> Tagged (Cabal mode) CommandPath -> Tagged (Cabal mode) ProjectTarget 167 | -> Args -> IO ExitCode 168 | cabalRun env cmd prog progArgs = commandArgs args env cmd 169 | where 170 | args = "run" : componentName (stripTag prog) : "--" : progArgs 171 | 172 | cabalUpdate :: Env -> Tagged (Cabal mode) CommandPath -> IO ExitCode 173 | cabalUpdate = commandArg "update" 174 | 175 | -------------------------------------------------------------------------------- 176 | 177 | data Sandbox 178 | 179 | instance CabalMode Sandbox where 180 | modeName _ = "sandbox" 181 | 182 | needsMinCabal = Just (tag (makeVersion [1,18])) 183 | 184 | hasModeArtifacts pr = doesFileExist (stripTag pr "cabal.sandbox.config") 185 | 186 | cabalPrepare = commandArgs ["sandbox", "init"] 187 | 188 | cabalConfigure env cmd = tryConfigure 189 | where 190 | install = commandArgs ["install", "--only-dependencies" 191 | , "--enable-tests", "--enable-benchmarks"] 192 | env cmd 193 | 194 | tryInstall = tryCommand "Installation failed; updating index." 195 | (cabalUpdate env cmd) 196 | install 197 | 198 | tryConfigure = tryCommand "Configuring failed; checking dependencies" 199 | tryInstall 200 | configure 201 | 202 | configure = commandArgs ["configure", "--enable-tests", "--enable-benchmarks"] 203 | env cmd 204 | 205 | -- Note: we don't treat "dist" as part of the tool artifacts, but it 206 | -- doesn't make sense without the sandbox so remove it as well. 207 | cabalClean env cmd = commandArg "clean" env cmd 208 | .&&. commandArgs ["sandbox", "delete"] env cmd 209 | 210 | -------------------------------------------------------------------------------- 211 | 212 | data Nix 213 | 214 | instance CabalMode Nix where 215 | modeName _ = "nix" 216 | 217 | -- We don't test for nix-instantiate here, as it's just used if it 218 | -- can be used. 219 | canUseMode env _ = return (has nixShell && has cabal2Nix) 220 | where 221 | has :: (NixSupport -> Maybe (Installed a)) -> Bool 222 | has f = isJust (f (nix (envTools env))) 223 | 224 | hasModeArtifacts pr = or <$> mapM (doesFileExist . (stripTag pr )) 225 | ["shell.nix", "default.nix"] 226 | 227 | -- Note that commandPrepare is meant to be run within ProjectRoot 228 | cabalPrepare env _ = case path <$> cabal2Nix (nix (envTools env)) of 229 | Nothing -> die "cabal2Nix required" 230 | Just c2n -> tryRunToFile (envConfig env) "shell.nix" c2n ["--shell", "."] 231 | 232 | -- It is tempting to want to run cabal2nix again here just in case, 233 | -- but people might have customised variants (different 234 | -- haskellPackages set, etc.). 235 | -- 236 | -- Instead, people need to run @jbi prepare@ if the .cabal file 237 | -- changes. 238 | cabalConfigure env _ = case path <$> nixShell nixEnv of 239 | Nothing -> die "nix-shell required" 240 | Just ns -> do 241 | -- We now evaluate canBench twice, which isn't ideal. 242 | -- 243 | -- Should also warn if it's False. 244 | args <- extraArgs 245 | cArgs <- cabalArgs 246 | tryRunErr 247 | "Configuration failed; you may need to manually enable 'withBenchmarkDepends' or 'doBenchmark' in your shell.nix file." 248 | (tryRun cfg ns (args ++ ["--run", cArgs])) 249 | where 250 | extraArgs = bool [] ["--arg", "doBenchmark", "true"] <$> canBench 251 | 252 | nixEnv = nix (envTools env) 253 | cfg = envConfig env 254 | 255 | canBench = 256 | case path <$> nixInstantiate nixEnv of 257 | Nothing -> return False 258 | Just ni -> do 259 | res <- tryRunLine cfg (stripTag ni) ["--eval", "--expr", "with import {}; haskell.lib ? doBenchmark"] 260 | return $ case res of 261 | Just "true" -> maybe False (>= c2nBenchSupport) (cabal2Nix nixEnv >>= version) 262 | _ -> False 263 | 264 | c2nBenchSupport :: Tagged Cabal2Nix Version 265 | c2nBenchSupport = tag (makeVersion [2,6]) 266 | 267 | cabalArgs = unwords . (["cabal", "configure", "--enable-tests"] ++) . bnchArgs <$> canBench 268 | where 269 | bnchArgs canB 270 | | canB = ["--enable-benchmarks"] 271 | | otherwise = [] 272 | 273 | cabalClean env cmd = commandArg "clean" env cmd 274 | .&&. rmFile "shell.nix" 275 | .&&. rmFile "default.nix" 276 | where 277 | rmFile file = do 278 | rmStatus <- tryIOError (removeFile file) 279 | case rmStatus of 280 | -- We're guessing as to which file is the one being used 281 | -- here, so an error because a file doesn't exist is OK; 282 | -- anything else is serious and should be re-thrown. 283 | Left err | not (isDoesNotExistError err) -> ioError err 284 | _ -> exitSuccess 285 | 286 | -------------------------------------------------------------------------------- 287 | 288 | isCabalFile :: FilePath -> Bool 289 | isCabalFile = (== ".cabal") . takeExtension 290 | 291 | -------------------------------------------------------------------------------- 292 | -- The Cabal library likes to really keep changing things... 293 | 294 | cabalFileComponents :: IO [String] 295 | cabalFileComponents = do 296 | dir <- getCurrentDirectory 297 | cntns <- map (dir ) <$> listDirectory dir 298 | files <- filterM doesFileExist cntns 299 | let cabalFiles = filter isCabalFile files 300 | case cabalFiles of 301 | [] -> return [] 302 | (c:_) -> getComponents <$> parseCabalFile c 303 | 304 | parseCabalFile :: FilePath -> IO GenericPackageDescription 305 | parseCabalFile = 306 | #if MIN_VERSION_Cabal(2,0,0) 307 | CParse.readGenericPackageDescription 308 | #else 309 | CParse.readPackageDescription 310 | #endif 311 | silent 312 | 313 | type ComponentName = 314 | #if MIN_VERSION_Cabal (2,0,0) 315 | UnqualComponentName 316 | #else 317 | String 318 | #endif 319 | 320 | rawComponentName :: ComponentName -> String 321 | rawComponentName = 322 | #if MIN_VERSION_Cabal (2,0,0) 323 | unUnqualComponentName 324 | #else 325 | id 326 | #endif 327 | 328 | packageName :: GenericPackageDescription -> String 329 | packageName = 330 | #if MIN_VERSION_Cabal (2,0,0) 331 | CPkg.unPackageName 332 | #else 333 | (\(CPkg.PackageName nm) -> nm) 334 | #endif 335 | . CPkg.packageName 336 | 337 | getComponents :: GenericPackageDescription -> [String] 338 | getComponents gpd = concat 339 | [ getLib 340 | , getType condExecutables "exe" 341 | , getType condTestSuites "test" 342 | , getType condBenchmarks "bench" 343 | ] 344 | where 345 | pkgName = packageName gpd 346 | 347 | getLib 348 | | isJust (condLibrary gpd) = ["lib:" ++ pkgName] 349 | | otherwise = [] 350 | 351 | getType f typ = map (\cmp -> typ ++ ':' : rawComponentName (fst cmp)) (f gpd) 352 | 353 | -------------------------------------------------------------------------------- 354 | 355 | commandArgsTarget :: Args -> Env -> Tagged (Cabal mode) CommandPath 356 | -> Maybe (Tagged (Cabal mode) ProjectTarget) -> IO ExitCode 357 | commandArgsTarget args env cmd mt = commandArgs args' env cmd 358 | where 359 | args' = args ++ maybeToList (fmap stripTag mt) 360 | 361 | commandArgTarget :: String -> Env -> Tagged (Cabal mode) CommandPath 362 | -> Maybe (Tagged (Cabal mode) ProjectTarget) -> IO ExitCode 363 | commandArgTarget = commandArgsTarget . (:[]) 364 | 365 | commandArg :: String -> Env -> Tagged (Cabal mode) CommandPath 366 | -> IO ExitCode 367 | commandArg arg = commandArgs [arg] 368 | 369 | commandArgs :: Args -> Env -> Tagged (Cabal mode) CommandPath 370 | -> IO ExitCode 371 | commandArgs args env cmd = tryRun (envConfig env) cmd args 372 | -------------------------------------------------------------------------------- /lib/System/JBI/Commands/Nix.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass, DeriveGeneric, OverloadedStrings #-} 2 | 3 | {- | 4 | Module : System.JBI.Commands.Nix 5 | Description : Nix tooling support 6 | Copyright : (c) Ivan Lazar Miljenovic 7 | License : MIT 8 | Maintainer : Ivan.Miljenovic@gmail.com 9 | 10 | 11 | 12 | -} 13 | module System.JBI.Commands.Nix where 14 | 15 | import System.JBI.Commands.Tool 16 | import System.JBI.Config (Config) 17 | import System.JBI.Tagged 18 | 19 | import Data.Aeson (ToJSON) 20 | import Data.Char (isSpace) 21 | import GHC.Generics (Generic) 22 | 23 | -------------------------------------------------------------------------------- 24 | 25 | data NixSupport = NixSupport 26 | { nixShell :: !(Maybe (Installed NixShell)) 27 | , cabal2Nix :: !(Maybe (Installed Cabal2Nix)) 28 | , nixInstantiate :: !(Maybe (Installed NixInstantiate)) 29 | } deriving (Eq, Ord, Show, Read, Generic, ToJSON) 30 | 31 | findNixSupport :: Config -> IO NixSupport 32 | findNixSupport cfg = NixSupport <$> commandInformation cfg 33 | <*> commandInformation cfg 34 | <*> commandInformation cfg 35 | 36 | data NixShell 37 | 38 | instance Tool NixShell where 39 | commandName = "nix-shell" 40 | 41 | data Cabal2Nix 42 | 43 | instance Tool Cabal2Nix where 44 | commandName = "cabal2nix" 45 | 46 | commandVersion = withTaggedF . tryFindVersionBy getVer 47 | where 48 | -- There's a digit in the command name, so the naive approach 49 | -- doesn't work. 50 | getVer = takeVersion . drop 1 . dropWhile (not . isSpace) 51 | 52 | data NixInstantiate 53 | 54 | instance Tool NixInstantiate where 55 | commandName = "nix-instantiate" 56 | -------------------------------------------------------------------------------- /lib/System/JBI/Commands/Stack.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {- | 3 | Module : System.JBI.Commands.Stack 4 | Description : Stack commands 5 | Copyright : (c) Ivan Lazar Miljenovic 6 | License : MIT 7 | Maintainer : Ivan.Miljenovic@gmail.com 8 | 9 | 10 | 11 | -} 12 | module System.JBI.Commands.Stack (Stack) where 13 | 14 | import System.JBI.Commands.BuildTool 15 | import System.JBI.Commands.Nix (nixShell) 16 | import System.JBI.Commands.Tool 17 | import System.JBI.Environment 18 | import System.JBI.Tagged 19 | 20 | import Control.Applicative (liftA2) 21 | import Data.Char (isSpace) 22 | import Data.Maybe (isJust, maybeToList) 23 | import System.Directory (doesDirectoryExist) 24 | import System.Exit (ExitCode) 25 | import System.FilePath (()) 26 | 27 | -------------------------------------------------------------------------------- 28 | 29 | data Stack 30 | 31 | instance Tool Stack where 32 | commandName = "stack" 33 | 34 | instance BuildTool Stack where 35 | 36 | commandProjectRoot = withTaggedF go 37 | where 38 | go :: FilePath -> IO (Maybe FilePath) 39 | go _ = recurseUpFindFile (== stackYaml) 40 | 41 | hasBuildArtifacts dir = doesDirectoryExist (stripTag dir ".stack-work") 42 | 43 | commandPrepare env cmd = commandArg "setup" env cmd 44 | .&&. commandArgs ["build", "--dry-run"] env cmd 45 | 46 | commandTargets cfg = withTaggedF go 47 | where 48 | go cmd = maybe [] validTargets <$> tryRunOutput cfg cmd ["ide", "targets"] 49 | 50 | validTargets = filter isTarget . lines 51 | 52 | isTarget = liftA2 (&&) (not . null) (all (not . isSpace)) 53 | 54 | commandBuild = commandArgsTarget ["build", "--test", "--no-run-tests", "--bench", "--no-run-benchmarks"] 55 | 56 | commandRepl env cmd rargs = commandArgsTarget stackArgs env cmd 57 | where 58 | stackArgs = [ "ghci" 59 | , "--ghci-options" 60 | , ghcArgs 61 | , "--test" 62 | , "--bench" 63 | , "--no-load" 64 | ] 65 | 66 | ghcArgs = unwords (stripTag rargs :: Args) 67 | 68 | commandClean = commandArgs ["clean", "--full"] 69 | 70 | commandTest = commandArg "test" 71 | 72 | commandBench = commandArg "bench" 73 | 74 | commandExec env cmd prog progArgs = commandArgs args env cmd 75 | where 76 | args = "exec" : prog : "--" : progArgs 77 | 78 | -- Stack doesn't have a "run" equivalent; see under \"component\" 79 | -- here: 80 | -- https://docs.haskellstack.org/en/stable/build_command/#target-syntax 81 | commandRun env cmd prog progArgs = 82 | commandBuild env cmd (Just prog) 83 | .&&. commandExec env cmd (componentName prog) progArgs 84 | 85 | commandUpdate = commandArg "update" 86 | 87 | instance NamedTool Stack 88 | 89 | stackYaml :: String 90 | stackYaml = "stack.yaml" 91 | 92 | commandArgsTarget :: Args -> Env -> Tagged Stack CommandPath 93 | -> Maybe (Tagged Stack ProjectTarget) -> IO ExitCode 94 | commandArgsTarget args env cmd mt = commandArgs args' env cmd 95 | where 96 | args' = args ++ maybeToList (fmap stripTag mt) 97 | 98 | commandArg :: String -> Env -> Tagged Stack CommandPath 99 | -> IO ExitCode 100 | commandArg arg = commandArgs [arg] 101 | 102 | commandArgs :: Args -> Env -> Tagged Stack CommandPath 103 | -> IO ExitCode 104 | commandArgs args env cmd = tryRun (envConfig env) cmd args' 105 | where 106 | hasNix = isJust (nixShell (nix (envTools env))) 107 | 108 | -- Take advantage of the fact that we're running in the same 109 | -- directory as the stack.yaml file so that stack doesn't have to 110 | -- bother looking for it. 111 | args' = addNix (["--stack-yaml", stackYaml] ++ args) 112 | 113 | addNix 114 | | hasNix = ("--nix":) 115 | | otherwise = id 116 | -------------------------------------------------------------------------------- /lib/System/JBI/Commands/Tool.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass, DeriveGeneric, OverloadedStrings #-} 2 | 3 | {- | 4 | Module : System.JBI.Commands.Tool 5 | Description : Common tooling commands 6 | Copyright : (c) Ivan Lazar Miljenovic 7 | License : MIT 8 | Maintainer : Ivan.Miljenovic@gmail.com 9 | 10 | 11 | 12 | -} 13 | module System.JBI.Commands.Tool where 14 | 15 | import System.JBI.Config 16 | import System.JBI.Tagged 17 | 18 | import Control.Applicative (liftA2) 19 | import Control.Monad (when) 20 | import Data.Aeson (ToJSON(toJSON)) 21 | import Data.Char (isDigit) 22 | import Data.Maybe (listToMaybe) 23 | import Data.String (IsString(..)) 24 | import Data.Version (Version, parseVersion) 25 | import GHC.Generics (Generic) 26 | import System.Directory (findExecutable) 27 | import System.Exit (ExitCode(ExitSuccess)) 28 | import System.IO (IOMode(WriteMode), hPutStrLn, stderr, 29 | withFile) 30 | import System.Process (CreateProcess(..), 31 | StdStream(Inherit, UseHandle), proc, 32 | readProcessWithExitCode, 33 | showCommandForUser, waitForProcess, 34 | withCreateProcess) 35 | import Text.ParserCombinators.ReadP (eof, readP_to_S) 36 | 37 | -------------------------------------------------------------------------------- 38 | 39 | class Tool t where 40 | commandName :: Tagged t CommandName 41 | 42 | commandVersion :: Config -> Tagged t CommandPath -> IO (Maybe (Tagged t Version)) 43 | commandVersion = withTaggedF . tryFindVersion 44 | 45 | commandPath :: (Tool t) => IO (Maybe (Tagged t CommandPath)) 46 | commandPath = withTaggedF findExecutable commandName 47 | 48 | commandInformation :: (Tool t) => Config -> IO (Maybe (Installed t)) 49 | commandInformation cfg = commandPath >>= mapM getVersion 50 | where 51 | getVersion :: (Tool t') => Tagged t' CommandPath -> IO (Installed t') 52 | getVersion tcp = Installed tcp <$> commandVersion cfg tcp 53 | 54 | data GHC 55 | 56 | instance Tool GHC where 57 | commandName = "ghc" 58 | 59 | -------------------------------------------------------------------------------- 60 | 61 | newtype CommandName = CommandName { nameOfCommand :: String } 62 | deriving (Eq, Ord, Show, Read) 63 | 64 | instance IsString CommandName where 65 | fromString = CommandName 66 | 67 | newtype CommandPath = CommandPath { pathToCommand :: FilePath } 68 | deriving (Eq, Ord, Show, Read) 69 | 70 | instance ToJSON CommandPath where 71 | toJSON = toJSON . pathToCommand 72 | 73 | instance IsString CommandPath where 74 | fromString = CommandPath 75 | 76 | data Installed t = Installed 77 | { path :: !(Tagged t CommandPath) 78 | , version :: !(Maybe (Tagged t Version)) 79 | -- ^ Try and determine the version. Only a factor in 80 | -- case any features are version-specific. 81 | } deriving (Eq, Ord, Show, Read, Generic, ToJSON) 82 | 83 | -------------------------------------------------------------------------------- 84 | 85 | -- | Attempt to find the version of the provided command, by assuming 86 | -- it's contained in the first line of the output of @command 87 | -- --version@. 88 | tryFindVersion :: Config -> FilePath -> IO (Maybe Version) 89 | tryFindVersion = tryFindVersionBy findVersion 90 | where 91 | findVersion str = takeVersion (dropWhile (not . isDigit) str) 92 | 93 | -- | If we're at the start of a Version, take all of it. 94 | takeVersion :: String -> String 95 | takeVersion = takeWhile (liftA2 (||) isDigit (=='.')) 96 | 97 | tryFindVersionBy :: (String -> String) -> Config -> FilePath -> IO (Maybe Version) 98 | tryFindVersionBy findVersion cfg cmd = 99 | fmap (>>= parseVer) (tryRunOutput cfg cmd ["--version"]) 100 | where 101 | parseVer ver = case readP_to_S (parseVersion <* eof) (findVersion ver) of 102 | [(v,"")] -> Just v 103 | _ -> Nothing 104 | 105 | type Args = [String] 106 | 107 | -- | Only return the stdout if the process was successful and had no stderr. 108 | tryRunOutput :: Config -> FilePath -> Args -> IO (Maybe String) 109 | tryRunOutput cfg cmd args = do 110 | printDebug cfg cmd args 111 | res <- readProcessWithExitCode cmd args "" 112 | return $ case res of 113 | (ExitSuccess, out, "" ) -> Just out 114 | -- Some tools (e.g. Stack) put output to stderr 115 | (ExitSuccess, "", err) -> Just err 116 | _ -> Nothing 117 | 118 | -- | As with 'tryRunOutput' but only return the first line (if any). 119 | tryRunLine :: Config -> FilePath -> Args -> IO (Maybe String) 120 | tryRunLine cfg cmd = fmap (>>= listToMaybe . lines) . tryRunOutput cfg cmd 121 | 122 | -- | Returns success of call. 123 | tryRun :: Config -> Tagged t CommandPath -> Args -> IO ExitCode 124 | tryRun cfg cmd args = do 125 | printDebug cfg cmd' args 126 | withCreateProcess cp $ \_ _ _ ph -> 127 | waitForProcess ph 128 | where 129 | cmd' = stripTag cmd 130 | 131 | cp = (proc cmd' args) { std_in = Inherit 132 | , std_out = Inherit 133 | , std_err = Inherit 134 | } 135 | 136 | -- | Print the error message if it isn't successful. 137 | tryRunErr :: String -> IO ExitCode -> IO ExitCode 138 | tryRunErr msg act = do 139 | res <- act 140 | if res == ExitSuccess 141 | then return res 142 | else res <$ hPutStrLn stderr msg 143 | 144 | tryRunToFile :: Config -> FilePath -> Tagged t CommandPath -> Args -> IO ExitCode 145 | tryRunToFile cfg file cmd args = do 146 | printDebug cfg cmd' args 147 | withFile file WriteMode $ \h -> 148 | withCreateProcess (cp h) $ \_ _ _ ph -> 149 | waitForProcess ph 150 | where 151 | cmd' = stripTag cmd 152 | 153 | cp h = (proc cmd' args) { std_in = Inherit 154 | , std_out = UseHandle h 155 | , std_err = Inherit 156 | } 157 | 158 | printDebug :: Config -> FilePath -> Args -> IO () 159 | printDebug cfg cmd args = 160 | when (debugMode cfg) (hPutStrLn stderr (makeBox ("Running: " ++ cmdStr))) 161 | where 162 | cmdStr = showCommandForUser cmd args 163 | 164 | (.&&.) :: (Monad m) => m ExitCode -> m ExitCode -> m ExitCode 165 | m1 .&&. m2 = do ec1 <- m1 166 | case ec1 of 167 | ExitSuccess -> m2 168 | _ -> return ec1 169 | 170 | infixr 3 .&&. 171 | 172 | (.||.) :: (Monad m) => m ExitCode -> m ExitCode -> m ExitCode 173 | m1 .||. m2 = do ec1 <- m1 174 | case ec1 of 175 | ExitSuccess -> return ec1 176 | _ -> m2 177 | 178 | infixr 2 .||. 179 | 180 | tryCommand :: String -> IO ExitCode -> IO ExitCode -> IO ExitCode 181 | tryCommand msg tryWith run = run .||. tryAgain 182 | where 183 | tryAgain = do 184 | putStrLn (makeBox msg) 185 | tryWith .&&. run 186 | 187 | makeBox :: String -> String 188 | makeBox msg = unlines [ border 189 | , "* " ++ msg ++ " *" 190 | , border 191 | ] 192 | where 193 | msgLen = length msg 194 | boxLen = msgLen + 4 -- asterisk + space on either side 195 | 196 | border = replicate boxLen '*' 197 | 198 | allSuccess :: (Monad m, Foldable t) => t (m ExitCode) -> m ExitCode 199 | allSuccess = foldr (.&&.) (return ExitSuccess) 200 | 201 | -- | Monad version of 'all', aborts the computation at the first @False@ value 202 | allM :: Monad m => (a -> m Bool) -> [a] -> m Bool 203 | allM _ [] = return True 204 | allM f (b:bs) = f b >>= (\bv -> if bv then allM f bs else return False) 205 | -------------------------------------------------------------------------------- /lib/System/JBI/Config.hs: -------------------------------------------------------------------------------- 1 | {- | 2 | Module : System.JBI.Config 3 | Description : Run-time configuration settings 4 | Copyright : (c) Ivan Lazar Miljenovic 5 | License : MIT 6 | Maintainer : Ivan.Miljenovic@gmail.com 7 | 8 | 9 | 10 | -} 11 | module System.JBI.Config where 12 | 13 | -------------------------------------------------------------------------------- 14 | 15 | newtype Config = Config 16 | { debugMode :: Bool 17 | } deriving (Eq, Show, Read) 18 | 19 | defaultConfig :: Config 20 | defaultConfig = Config 21 | { debugMode = False 22 | } 23 | -------------------------------------------------------------------------------- /lib/System/JBI/Environment.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass, DeriveGeneric #-} 2 | 3 | {- | 4 | Module : System.JBI.Environment 5 | Description : Build tool agnostic environment 6 | Copyright : (c) Ivan Lazar Miljenovic 7 | License : MIT 8 | Maintainer : Ivan.Miljenovic@gmail.com 9 | 10 | This is used by build tools to help them determine how they should 11 | run (as opposed to configuration environment which is their actual 12 | working directories, etc.). 13 | 14 | -} 15 | module System.JBI.Environment 16 | ( Env(..) 17 | , Config(..) 18 | , ToolEnv(..) 19 | , toolEnv 20 | ) where 21 | 22 | import System.JBI.Commands.Nix 23 | import System.JBI.Commands.Tool 24 | import System.JBI.Config 25 | 26 | import Data.Aeson (ToJSON) 27 | import GHC.Generics (Generic) 28 | 29 | -------------------------------------------------------------------------------- 30 | 31 | data Env = Env 32 | { envConfig :: !Config 33 | , envTools :: !ToolEnv 34 | } deriving (Eq, Show, Read) 35 | 36 | -------------------------------------------------------------------------------- 37 | 38 | data ToolEnv = ToolEnv 39 | { nix :: NixSupport 40 | , ghc :: Maybe (Installed GHC) 41 | } deriving (Eq, Show, Read, Generic, ToJSON) 42 | 43 | toolEnv :: Config -> IO ToolEnv 44 | toolEnv cfg = ToolEnv <$> findNixSupport cfg <*> commandInformation cfg 45 | -------------------------------------------------------------------------------- /lib/System/JBI/Tagged.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DefaultSignatures, FlexibleContexts, KindSignatures, 2 | MultiParamTypeClasses #-} 3 | 4 | {- | 5 | Module : System.JBI.Commands.Tagged 6 | Description : Support for the Tagged type 7 | Copyright : (c) Ivan Lazar Miljenovic 8 | License : MIT 9 | Maintainer : Ivan.Miljenovic@gmail.com 10 | 11 | 12 | 13 | -} 14 | module System.JBI.Tagged 15 | ( WithTagged (..) 16 | , stripTag 17 | , stripTags 18 | , tag 19 | -- * Re-export 20 | , Tagged (..) 21 | , proxy 22 | ) where 23 | 24 | import Data.Coerce (Coercible, coerce) 25 | import Data.Tagged 26 | 27 | -------------------------------------------------------------------------------- 28 | 29 | class WithTagged (g :: * -> *) where 30 | 31 | -- | Strip off type safety, run the function, put type safety back on. 32 | withTaggedF :: (Coercible a a', Coercible b b', Functor f) 33 | => (a' -> f (g b')) -> Tagged t a -> f (g (Tagged t b)) 34 | default withTaggedF :: ( Coercible a a', Coercible b b', Functor f 35 | , Coercible (g b') (g (Tagged t b)) 36 | , Coercible (g (Tagged t b)) (g b')) 37 | => (a' -> f (g b')) -> Tagged t a -> f (g (Tagged t b)) 38 | withTaggedF f = fmap coerce . f . coerce 39 | 40 | tagInner :: Tagged t (g a) -> g (Tagged t a) 41 | default tagInner :: ( Coercible (Tagged t (g a)) (g (Tagged t a)) 42 | , Coercible (g (Tagged t a)) (g a)) 43 | => Tagged t (g a) -> g (Tagged t a) 44 | tagInner = coerce 45 | 46 | tagOuter :: g (Tagged t a) -> Tagged t (g a) 47 | default tagOuter :: (Coercible (g (Tagged t a)) (Tagged t (g a))) 48 | => g (Tagged t a) -> Tagged t (g a) 49 | tagOuter = coerce 50 | 51 | instance WithTagged Maybe 52 | instance WithTagged [] 53 | 54 | -- | Remove the tag along with (potentially) any newtype wrappers 55 | -- added on. 56 | stripTag :: (Coercible a a') => Tagged t a -> a' 57 | stripTag = coerce 58 | 59 | stripTags :: (Coercible a a') => [Tagged t a] -> [a'] 60 | stripTags = coerce 61 | 62 | -- | Put the appropriate tag on. 63 | tag :: (Coercible a a') => a -> Tagged t a' 64 | tag = coerce 65 | -------------------------------------------------------------------------------- /src/Main.hs: -------------------------------------------------------------------------------- 1 | {- | 2 | Module : Main 3 | Description : Just Build It! 4 | Copyright : (c) Ivan Lazar Miljenovic 5 | License : MIT 6 | Maintainer : Ivan.Miljenovic@gmail.com 7 | 8 | 9 | 10 | -} 11 | module Main where 12 | 13 | import Paths_jbi (version) 14 | import System.JBI 15 | import System.JBI.Commands.BuildTool (ProjectTarget(..), rootPath) 16 | import System.JBI.Commands.Tool (Args) 17 | 18 | import Control.Applicative (many, optional, (<*>), (<|>)) 19 | import Data.Aeson.Encode.Pretty (encodePrettyToTextBuilder) 20 | import Data.List (intercalate) 21 | import Data.Monoid (mconcat, (<>)) 22 | import Data.Text.Lazy (unpack) 23 | import Data.Text.Lazy.Builder (toLazyText) 24 | import Data.Version (showVersion) 25 | import Options.Applicative (Parser, ParserInfo, argument, command, 26 | eitherReader, execParser, flag', footer, 27 | fullDesc, header, help, helper, hsubparser, 28 | info, long, metavar, option, progDesc, short, 29 | str, strArgument, switch) 30 | import System.Exit (ExitCode(ExitSuccess), die, exitWith) 31 | 32 | import Text.ParserCombinators.ReadP (ReadP, char, eof, get, munch1, readP_to_S, 33 | satisfy, skipSpaces) 34 | 35 | -------------------------------------------------------------------------------- 36 | 37 | main :: IO () 38 | main = execParser parser >>= runAction defaultTools 39 | 40 | data Action = Action 41 | { actConfig :: !Config 42 | , actCommand :: !Command 43 | } deriving (Eq, Show, Read) 44 | 45 | -------------------------------------------------------------------------------- 46 | 47 | data Command = Prepare 48 | | Targets 49 | | Build (Maybe ProjectTarget) 50 | | REPL Args (Maybe ProjectTarget) 51 | | Clean 52 | | Test 53 | | Bench 54 | | Exec String Args 55 | | Run ProjectTarget Args 56 | | Update 57 | | Info InfoType 58 | | Version 59 | deriving (Eq, Show, Read) 60 | 61 | data InfoType = AvailableTools 62 | | ChosenTool 63 | | ProjectDir 64 | | Detailed 65 | deriving (Eq, Show, Read) 66 | 67 | parser :: ParserInfo Action 68 | parser = info (helper <*> prs) $ 69 | header versionInfo 70 | <> fullDesc 71 | <> footer "No arguments is equivalent to running `build`" 72 | where 73 | prs = Action <$> parseConfig <*> parseCommand 74 | 75 | versionInfo :: String 76 | versionInfo = "jbi " ++ showVersion version ++ " - Just Build It and Hack On!" 77 | 78 | parseConfig :: Parser Config 79 | parseConfig = Config <$> parseDebug 80 | where 81 | parseDebug = switch ( long "debug" 82 | <> help "Print debugging information whilst running." 83 | ) 84 | 85 | parseCommand :: Parser Command 86 | parseCommand = (hsubparser . mconcat $ 87 | [ command "prepare" (info (pure Prepare) 88 | (progDesc "Initialise the tool; usually not needed, \ 89 | \but will (re-)generate the `shell.nix` for `cabal+nix`.")) 90 | , command "targets" (info (pure Targets) 91 | (progDesc "Print available targets")) 92 | , command "build" (info (Build <$> optional parseTarget) 93 | (progDesc "Build the project (optionally a specified target).")) 94 | , command "repl" (info (REPL <$> parseReplArgs <*> optional parseTarget) 95 | (progDesc "Start a REPL. Passing in a target is optional, but \ 96 | \highly recommended when multiple targets are available.")) 97 | , command "clean" (info (pure Clean) 98 | (progDesc "Remove all build artifacts.")) 99 | , command "test" (info (pure Test) 100 | (progDesc "Run test suite(s).")) 101 | , command "bench" (info (pure Bench) 102 | (progDesc "Run benchmark(s).")) 103 | , command "exec" (info (Exec <$> parseExecutable <*> parseArgs) 104 | (progDesc "Run the specified executable within the build environment.")) 105 | , command "run" (info (Run <$> parseTarget <*> parseArgs) 106 | (progDesc "Run the specified executable target within the build environment.")) 107 | , command "update" (info (pure Update) 108 | (progDesc "Update the package index (usually not needed).")) 109 | , command "info" (info (Info <$> parseInfo) 110 | (progDesc "Build tool information; useful for debugging.")) 111 | ]) 112 | <|> flag' Version (long "version" <> short 'V') 113 | <|> pure (Build Nothing) 114 | 115 | parseTarget :: Parser ProjectTarget 116 | parseTarget = argument (ProjectTarget <$> str) ( metavar "TARGET" 117 | <> help "Project target (see the `targets` command)" 118 | ) 119 | 120 | parseExecutable :: Parser String 121 | parseExecutable = strArgument ( metavar "COMMAND" 122 | <> help "A command/executable" 123 | ) 124 | 125 | parseArgs :: Parser Args 126 | parseArgs = many (strArgument ( metavar "ARG" 127 | <> help "Optional arguments to pass through to the command" 128 | )) 129 | 130 | parseReplArgs :: Parser Args 131 | parseReplArgs = concat <$> many (option readArgs ( long "repl-opts" 132 | <> metavar "ARGS" 133 | <> help "Optional arguments to pass through to the REPL." 134 | )) 135 | where 136 | readArgs = eitherReader $ \inp -> 137 | case readP_to_S parseSubArgs inp of 138 | [(args,"")] -> Right args 139 | [] -> Left "No ARGS parseable" 140 | _ -> Left "Ambiguous parse of ARGS" 141 | 142 | -- Based upon Data.Attoparsec.Args.argsParser from stack 143 | -- 144 | -- Using ReadP to avoid bringing in a parsing library for this one 145 | -- small task. 146 | parseSubArgs :: ReadP Args 147 | parseSubArgs = many (skipSpaces *> (quoted <|> unquoted) <* skipSpaces) 148 | <* (eof <|> fail "Unterminated string") 149 | where 150 | -- munch1 is greedier than (many1 . satisfy) 151 | unquoted = munch1 (not . flip elem ['"', ' ']) 152 | quoted = char '"' *> string <* char '"' 153 | string = many (escaped <|> nonquote) 154 | escaped = char '\\' *> get 155 | nonquote = satisfy (/='"') 156 | 157 | parseInfo :: Parser InfoType 158 | parseInfo = hsubparser . mconcat $ 159 | [ command "tools" (info (pure AvailableTools) 160 | (progDesc "Print all known build tools.")) 161 | , command "chosen" (info (pure ChosenTool) 162 | (progDesc "Print the build tool chosen.")) 163 | , command "project" (info (pure ProjectDir) 164 | (progDesc "Path to the project directory.")) 165 | , command "details" (info (pure Detailed) 166 | (progDesc "Print detailed information about build tools.")) 167 | ] 168 | 169 | -------------------------------------------------------------------------------- 170 | 171 | runAction :: [WrappedTool proxy] -> Action -> IO () 172 | runAction tools act = do 173 | ec <- case actCommand act of 174 | Prepare -> tooled prepare 175 | Build mt -> tooled (build mt) 176 | REPL args mt -> tooled (repl args mt) 177 | Clean -> tooled clean 178 | Test -> tooled test 179 | Bench -> tooled bench 180 | Exec exe args -> tooled (exec exe args) 181 | Run exe args -> tooled (run exe args) 182 | Update -> tooled update 183 | Targets -> printSuccess printTargets 184 | Info it -> printSuccess (printInfo it) 185 | Version -> putStrLn versionInfo >> returnSuccess 186 | exitWith ec 187 | where 188 | tooled :: (Env -> WrappedTool Valid -> IO a) -> IO a 189 | tooled f = withTool cfg toolFail f tools 190 | 191 | toolFail :: IO a 192 | toolFail = die "No possible tool found." 193 | 194 | returnSuccess = return ExitSuccess 195 | 196 | printSuccess ma = do out <- ma 197 | putStrLn out 198 | returnSuccess 199 | 200 | printTargets = tooled ((fmap (multiLine . map projectTarget) .) . targets) 201 | 202 | withChosen f = do env <- getEnvironment cfg 203 | mTool <- chooseTool env tools 204 | maybe toolFail (return . f) mTool 205 | 206 | jsonStr = unpack . toLazyText . encodePrettyToTextBuilder 207 | 208 | printInfo AvailableTools = return . multiLine . map toolName $ tools 209 | printInfo ChosenTool = withChosen toolName 210 | printInfo ProjectDir = withChosen (rootPath . infoProjectDir) 211 | printInfo Detailed = jsonStr <$> getInformation cfg tools 212 | 213 | cfg = actConfig act 214 | 215 | -- Unlike unlines, this doesn't add a trailing newline. 216 | multiLine :: [String] -> String 217 | multiLine = intercalate "\n" 218 | --------------------------------------------------------------------------------