├── .gitignore ├── ChangeLog.md ├── LICENSE ├── README.md ├── Setup.hs ├── data └── default-iridium.yaml ├── iridium.cabal ├── iridium.yaml ├── src-main └── Main.hs ├── src └── Development │ ├── Iridium.hs │ └── Iridium │ ├── CheckState.hs │ ├── Checks.hs │ ├── Config.hs │ ├── ExternalProgWrappers.hs │ ├── Hackage.hs │ ├── Repo │ └── Git.hs │ ├── Types.hs │ ├── UI │ ├── Console.hs │ └── Prompt.hs │ └── Utils.hs └── stack.yaml /.gitignore: -------------------------------------------------------------------------------- 1 | *.glade~ 2 | *.prof 3 | *.aux 4 | *.eventlog 5 | *.hp 6 | *.ps 7 | /*.pdf 8 | dist 9 | dist-newstyle 10 | .cabal-sandbox/ 11 | .stack-work/ 12 | cabal.sandbox.config 13 | cabal.project.local* 14 | .ghc.environment.* 15 | **/*.gui~ 16 | \#*.gui\# 17 | -------------------------------------------------------------------------------- /ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Revision history for iridium 2 | 3 | ## 0.1.5.8 -- 2018-10-02 4 | 5 | * Add support for -Wcompat 6 | * Reduce dependency footprint by using json endpoint of hackage interface 7 | 8 | ## 0.1.5.7 -- 2017-08-01 9 | 10 | * Adapt for cabal-2.0 - Note that this is a breaking change; uploading with 11 | cabal-1.* will not work with this version. 12 | 13 | ## 0.1.5.6 -- 2016-09-28 14 | 15 | * Only internal changes (support ghc-8, fix support for ghc-7.8; 16 | adapt/switch to turtle-1.3.0) 17 | 18 | ## 0.1.5.5 -- 2016-09-28 19 | 20 | * Slight improvements around the handling of testing against multiple 21 | compiler versions 22 | 23 | ## 0.1.5.4 -- 2016-05-21 24 | 25 | * Fix git branch parsing issue 26 | 27 | ## 0.1.5.3 -- 2016-04-22 28 | 29 | * Include `cabal update` invocation by default 30 | * Add warning for missing remote version 31 | 32 | ## 0.1.5.2 -- 2016-03-11 33 | 34 | * Improve stackage upper-bound check error output 35 | 36 | ## 0.1.5.1 -- 2016-03-11 37 | 38 | * Fix iridium package pvp compliance (lower bounds) 39 | * First hackage release 40 | 41 | ## 0.1.5.0 -- 2016-03-11 42 | 43 | * Add package-sdist check 44 | 45 | * Prepare non-static default config 46 | 47 | ## 0.1.4.0 -- 2016-02-22 48 | 49 | * Fix various bugs 50 | 51 | * Make various changes to the default iridium.yaml 52 | 53 | * Fix/Expand basic git functionality; it includes: 54 | * Displaying current branch 55 | * Tagging the current commit 56 | * Pushing tag and branch to remote 57 | 58 | ## 0.1.4.0 -- 2016-02-18 59 | 60 | * Start integrating some git-specific functionality 61 | 62 | ## 0.1.2.0 -- 2016-02-17 63 | 64 | * First release, experimental. 65 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2016, Lennart Spitzner 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 Lennart Spitzner 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 | # iridium 2 | 3 | [![Build Status](https://secure.travis-ci.org/lspitzner/iridium.svg)](http://travis-ci.org/lspitzner/iridium) 4 | [![Hackage](https://img.shields.io/hackage/v/iridium.svg)](https://hackage.haskell.org/package/iridium) 5 | 6 | # Introduction 7 | 8 | iridium is a fancy wrapper around `cabal upload`. It aims to automate 9 | several typical steps when releasing a new package version to hackage. 10 | 11 | Iridium does all testing locally, in contrast to e.g. github's travis. 12 | This makes it easier to keep your published history free of commits that 13 | fail any tests (without squashing or separate branches). 14 | 15 | Steps currently include: 16 | 17 | - Compilation and running tests using multiple compiler versions. 18 | (the different compilers must already be installed.) 19 | 20 | - Checking that the changelog mentions the latest version. 21 | 22 | - Checking that the upper bounds of dependencies 23 | are up-to-date by making use of stackage snapshots. 24 | 25 | - Uploading of both the package itself and the documentation. 26 | 27 | The output on errors is certainly not optimal; for example the stackage 28 | upper bound checking will print a typical, hard-to-consume cabal error 29 | message. iridium's focus is on notifying _if_ something is wrong. 30 | 31 | # Usage 32 | 33 | Install iridium, run iridium in the directory containing the cabal package. 34 | It won't do anything without confirmation. 35 | 36 | ~~~~ 37 | $ iridium 38 | Checking compilation with different compiler versions 39 | Checking with compiler ghc-7.8.4: clear. 40 | Checking upper bounds using stackage: clear. 41 | Checking documentation: clear. 42 | Checking basic compilation: clear. 43 | Checking that all dependencies have a lower bound: clear. 44 | Checking that all dependencies have an upper bound: clear. 45 | Checking package validity: clear. 46 | Testing the source distribution package: clear. 47 | Testing if the changelog mentions the latest version: clear. 48 | Comparing local version to hackage version: clear. 49 | [git] 50 | Testing for uncommitted changes: clear. 51 | Summary: 52 | Package: iridium 53 | Version: 0.1.5.1 54 | Warning count: 0 55 | Error count: 0 56 | Not -Wall clean: [] 57 | [git] 58 | Branch: master 59 | Actions: Tag the current commit with "0.1.5.1" 60 | Push current branch and tag to upstream repo 61 | Upload package 62 | Upload documentation 63 | > Continue [y]es [n]o? > y 64 | Performing upload.. 65 | Building source dist for iridium-0.1.2.0... 66 | Preprocessing library iridium-0.1.2.0... 67 | Preprocessing executable 'iridium' for iridium-0.1.2.0... 68 | Source tarball created: dist/iridium-0.1.2.0.tar.gz 69 | Hackage password: 70 | Uploading dist/iridium-0.1.2.0.tar.gz... 71 | Ok 72 | Upload successful. 73 | Performing doc upload.. 74 | [.. some haddock spam ..] 75 | Documentation tarball created: dist/iridium-0.1.2.0-docs.tar.gz 76 | Hackage password: 77 | Uploading documentation dist/iridium-0.1.2.0-docs.tar.gz... 78 | Ok 79 | Documentation upload successful. 80 | $ 81 | ~~~~ 82 | 83 | # Configuration 84 | 85 | An `iridium.yaml` file will be created on first invocation. 86 | 87 | # Tests 88 | 89 | | Test | Description | 90 | | --- | --- | 91 | | hlint | `forM_ hs-source-dirs $ \dir -> (\dir -> call "hlint " ++ dir)` | 92 | | testsuites | run `cabal test` when compiling. | 93 | | upper-bounds-stackage | Check that upper bounds are up-to-date by using a stackage cabal.config. This is not the best way, because not all packages are on stackage, but it is better than nothing. | 94 | | lower-bounds-exist | Check that all dependencies have a lower bound. | 95 | | upper-bounds-exist | Check that all dependencies have an upper bound. (You _do_ want to conform with the PVP, right?) | 96 | | documentation | Check that haddocks can be created without problems (calling `cabal haddock`). | 97 | | changelog | Check if the changelog mentions (contains) the latest version. | 98 | | package-sdist | Check that all necessary stuff is contained in the source distribution by installing the packaged package. | 99 | | compiler-versions | Compile and run tests for several compiler versions (other than the default compiler on $PATH). | 100 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /data/default-iridium.yaml: -------------------------------------------------------------------------------- 1 | # see https://github.com/lspitzner/iridium 2 | # 3 | # note that you can add a user-global .iridium.yaml 4 | # into $HOME, containing e.g. 5 | # 6 | # --- 7 | # setup: 8 | # compiler-paths: 9 | # ghc-7.10.3: /opt/ghc-7.10.3/bin/ghc 10 | # ghc-7.8.4: /opt/ghc-7.8.4/bin/ghc 11 | # 12 | # default-compiler: ghc-7.10.3 13 | # 14 | # hackage: 15 | # username: user 16 | # ... 17 | 18 | --- 19 | setup: 20 | buildtool-help: | 21 | cannot be changed; stack is not supported (yet). 22 | buildtool: cabal 23 | 24 | cabal-command-help: | 25 | "cabal-command: cabal" 26 | hlint-command-help: | 27 | "hlint-command: $HOME/.cabal/bin/hlint" 28 | 29 | remote-server-help: ! 'This currently only checks that uploads happen to that remote, 30 | it does not change the remote if a different one is configured. 31 | (because that would require modifying `.cabal/config`,)' 32 | remote-server: http://hackage.haskell.org 33 | 34 | run-cabal-update: True 35 | run-cabal-update-help: ! 'Execute cabal update before performing any checks. 36 | Useful when running the stackage upper bounds check, which may erroneously 37 | report errors if your cabal package index is not up to date.' 38 | 39 | process: 40 | dry-run-help: | 41 | only run all checks/tests, omit any side-effects/uploading 42 | dry-run: False 43 | 44 | display-help: True 45 | 46 | upload-docs-help: | 47 | build docs locally and upload them instead of trusting the 48 | docs builder which gets broken every two months. 49 | implies the documentation check. 50 | upload-docs: True 51 | 52 | print-summary: True 53 | 54 | confirmation-help: | 55 | confirm-always always ask for confirmation. 56 | confirm-on-warning don't ask for confirmation if everything is clear. 57 | confirm-on-error only ask for confirmation if there are errors. 58 | confirmation: confirm-always 59 | 60 | checks: 61 | hlint: 62 | enabled: False 63 | testsuites: 64 | enabled: True 65 | compiler-warnings: 66 | enabled: True 67 | enable-compat: True 68 | 69 | # whitelist: [only, these, tests] # not supported yet 70 | # blacklist: [omit, these, tests] # not supported yet 71 | 72 | package-sdist-help: | 73 | Check that the created source distribution package will 74 | actually work (for other users). This can for example 75 | be not the case when you fail to mention specific files 76 | in your package description. 77 | package-sdist: 78 | enabled: True 79 | 80 | upper-bounds-stackage-help: | 81 | if you are completely unlucky, this might _overwrite_ 82 | an existing cabal.config. if you press ctrl-c in exactly 83 | the right moment or something. 84 | upper-bounds-stackage: 85 | enabled-help: | 86 | for existing upper bounds 87 | enabled: False 88 | use-nightly: False 89 | # blacklist: [omit, check, for, these, packages] # not supported yet 90 | lower-bounds-exist: 91 | enabled: True 92 | upper-bounds-exist: 93 | enabled: True 94 | changelog: 95 | enabled: True 96 | location: ChangeLog.md 97 | compiler-versions: 98 | enabled: False 99 | compilers-help: | 100 | for this to work, cabal will need the paths to the actual 101 | compilers to be configured; see the note about the user-global 102 | config above. 103 | compilers: 104 | - compiler: ghc 105 | version: 7.0.4 106 | - compiler: ghc 107 | version: 7.2.2 108 | - compiler: ghc 109 | version: 7.4.2 110 | - compiler: ghc 111 | version: 7.6.3 112 | - compiler: ghc 113 | version: 7.8.4 114 | - compiler: ghc 115 | version: 7.10.3 116 | documentation: 117 | enabled: True 118 | 119 | repository: 120 | type-help: | 121 | none | git 122 | type: none 123 | git: 124 | display-current-branch: True 125 | release-tag: 126 | enabled: True 127 | content: "$VERSION" 128 | # params: [] # NOT YET SUPPORTED ! 129 | push-remote-help: | 130 | push the current branch (and the tag, if configured) to 131 | a remote repo. 132 | push-remote: 133 | enabled: True 134 | remote-name-help: | 135 | the "remote" configured in git to push the release/tag to. 136 | remote-name: "origin" 137 | ... 138 | -------------------------------------------------------------------------------- /iridium.cabal: -------------------------------------------------------------------------------- 1 | name: iridium 2 | version: 0.1.5.8 3 | synopsis: Automated Local Cabal Package Testing and Uploading 4 | license: BSD3 5 | license-file: LICENSE 6 | author: Lennart Spitzner 7 | maintainer: Lennart Spitzner 8 | copyright: Copyright (C) 2016 Lennart Spitzner 9 | Homepage: https://github.com/lspitzner/iridium 10 | Bug-reports: https://github.com/lspitzner/iridium/issues 11 | category: Development 12 | build-type: Simple 13 | cabal-version: >=1.10 14 | 15 | description: { 16 | This executable aims to automate several typical steps when 17 | uploading a new package version to hackage. 18 | . 19 | Steps currently include: 20 | . 21 | * Compilation and running tests using multiple compiler versions. 22 | . 23 | * Checking that the changelog mentions the latest version. 24 | . 25 | * Checking that the upper bounds of dependencies 26 | are up-to-date by making use of stackage snapshots. 27 | . 28 | * [git] Pushing and tagging the version to the commit. 29 | . 30 | * Uploading of both the package itself and the documentation. 31 | . 32 | The program is configurable using a per-project .yaml file. 33 | . 34 | See the README. 35 | } 36 | 37 | 38 | 39 | data-dir: { 40 | data 41 | } 42 | data-files: { 43 | default-iridium.yaml 44 | } 45 | 46 | extra-source-files: { 47 | README.md 48 | ChangeLog.md 49 | } 50 | 51 | source-repository head { 52 | type: git 53 | location: https://github.com/lspitzner/iridium.git 54 | } 55 | 56 | library { 57 | exposed-modules: { 58 | Development.Iridium.Types 59 | Development.Iridium.Utils 60 | Development.Iridium.ExternalProgWrappers 61 | Development.Iridium.UI.Console 62 | Development.Iridium.UI.Prompt 63 | Development.Iridium.Repo.Git 64 | Development.Iridium.Config 65 | Development.Iridium.Hackage 66 | Development.Iridium.CheckState 67 | Development.Iridium.Checks 68 | Development.Iridium 69 | Paths_iridium 70 | } 71 | -- other-modules: 72 | -- other-extensions: 73 | build-depends: 74 | { base >=4.8 && <4.11 75 | , lifted-base >=0.2.3.6 && <0.3 76 | , yaml >=0.8.16 && <0.9 77 | , turtle >=1.3.0 && <1.4 78 | , text >=1.2.2.0 && <1.3 79 | , containers >=0.5.5.1 && <0.6 80 | , transformers >=0.3.0.0 && <0.6 81 | , system-filepath >=0.4.13.4 && <0.5 82 | , unordered-containers >=0.2.5.1 && <0.3 83 | , multistate >=0.7.0.0 && <0.8 84 | , Cabal >=1.22.5.0 && <1.25 85 | , aeson >=1.4 && <1.5 86 | , network-uri >=2.6 && <2.7 87 | , HTTP >=4000.3 && <4000.4 88 | , foldl >=1.1.5 && <1.3 89 | , bytestring >=0.10.4.0 && <0.11 90 | , tagged >=0.8.3 && <0.9 91 | , extra >=1.4.3 && <1.7 92 | , process >=1.2.3.0 && <1.5 93 | , vector >=0.11.0.0 && <0.13 94 | , ansi-terminal >=0.6.2.3 && <0.7 95 | , transformers-base >=0.4.4 && <0.5 96 | , monad-control >=1.0.0.5 && <1.1 97 | , split >=0.2.3 && <0.3 98 | } 99 | hs-source-dirs: { 100 | src 101 | } 102 | default-language: { 103 | Haskell2010 104 | } 105 | ghc-options: { 106 | -Wall 107 | -j 108 | -fno-warn-unused-imports 109 | -fno-warn-orphans 110 | } 111 | default-extensions: { 112 | FlexibleContexts 113 | FlexibleInstances 114 | ScopedTypeVariables 115 | MonadComprehensions 116 | } 117 | } 118 | 119 | executable iridium { 120 | main-is: { 121 | Main.hs 122 | } 123 | other-modules: { 124 | Paths_iridium 125 | } 126 | build-depends: 127 | { iridium 128 | , base >=4.7 && <4.11 129 | , yaml >=0.8.16 && <0.9 130 | , transformers >=0.3.0.0 && <0.6 131 | , unordered-containers >=0.2.5.1 && <0.3 132 | , multistate >=0.7.0.0 && <0.8 133 | , extra >=1.4.3 && <1.7 134 | , text >=1.2.2.0 && <1.3 135 | } 136 | hs-source-dirs: { 137 | src-main 138 | } 139 | default-language: { 140 | Haskell2010 141 | } 142 | ghc-options: { 143 | -Wall 144 | -j 145 | -fno-warn-unused-imports 146 | -fno-warn-orphans 147 | } 148 | default-extensions: { 149 | FlexibleContexts 150 | FlexibleInstances 151 | ScopedTypeVariables 152 | MonadComprehensions 153 | } 154 | } 155 | -------------------------------------------------------------------------------- /iridium.yaml: -------------------------------------------------------------------------------- 1 | --- 2 | setup: 3 | buildtool: cabal # cabal | stack 4 | 5 | # This currently only checks that uploads happen to that remote, 6 | # it does not change the remote if a different one is configured. 7 | # (because that would require modifying `.cabal/config`,) 8 | # remote-server: http://127.0.0.1:8080 9 | remote-server: http://hackage.haskell.org 10 | 11 | process: 12 | dry-run: False # only run all checks/tests, omit any side-effects/uploading 13 | 14 | display-help: True 15 | 16 | # build docs locally and upload them instead of trusting the 17 | # docs builder which gets broken every two months. 18 | # implies the documentation check. 19 | upload-docs: True 20 | 21 | print-summary: True 22 | 23 | # confirm-always always ask for confirmation. 24 | # confirm-on-warning don't ask for confirmation if everything is clear. 25 | # confirm-on-error only ask for confirmation if there are errors. 26 | confirmation: confirm-always 27 | 28 | run-cabal-update: True 29 | 30 | checks: 31 | hlint: 32 | enabled: False 33 | testsuites: 34 | enabled: False 35 | compiler-warnings: 36 | enabled: True 37 | enable-compat: True 38 | # whitelist: [only, these, tests] 39 | # blacklist: [omit, these, tests] 40 | package-sdist: 41 | enabled: True 42 | upper-bounds-stackage: 43 | # for existing upper bounds 44 | enabled: True 45 | use-nightly: False 46 | # blacklist: [omit, check, for, these, packages] 47 | lower-bounds-exist: 48 | enabled: True 49 | upper-bounds-exist: 50 | enabled: True 51 | changelog: 52 | enabled: True 53 | location: ChangeLog.md 54 | compiler-versions: 55 | enabled: True 56 | compilers: 57 | - compiler: ghc 58 | version: 7.10.3 59 | - compiler: ghc 60 | version: 8.0.2 61 | - compiler: ghc 62 | version: 8.2.2 63 | documentation: 64 | enabled: True 65 | 66 | repository: 67 | type: git # none | git 68 | git: 69 | display-current-branch: True 70 | release-tag: # NOT YET SUPPORTED ! 71 | enabled: True 72 | content: "$VERSION" 73 | push-remote: # NOT YET SUPPORTED ! 74 | # push the current branch (and the tag, if configured) to 75 | # a remote repo. 76 | enabled: True 77 | # the "remote" configured in git to push the release/tag to. 78 | remote-name: "lspitzner" 79 | ... 80 | -------------------------------------------------------------------------------- /src-main/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PatternGuards #-} 2 | {-# LANGUAGE ViewPatterns #-} 3 | 4 | module Main 5 | ( main 6 | ) 7 | where 8 | 9 | 10 | 11 | import Control.Monad.Trans.Maybe 12 | import Control.Monad.Trans.MultiRWS 13 | import Data.HList.HList 14 | import Control.Monad.IO.Class 15 | 16 | import Control.Monad 17 | 18 | import qualified System.Environment 19 | import qualified System.Console.GetOpt as GetOpt 20 | import Data.Version ( showVersion ) 21 | import qualified Data.Yaml as Yaml 22 | import qualified Data.HashMap.Strict as HM 23 | import qualified Data.Text as Text 24 | 25 | import Development.Iridium 26 | import Development.Iridium.Config 27 | import Development.Iridium.UI.Console 28 | import Development.Iridium.Types 29 | 30 | import Paths_iridium 31 | 32 | import Control.Exception 33 | import Data.Functor 34 | 35 | 36 | 37 | data Option 38 | = OptionHelp 39 | | OptionVersion 40 | | OptionVerbose 41 | | OptionDryRun 42 | deriving (Eq) 43 | 44 | optDescrs :: [GetOpt.OptDescr Option] 45 | optDescrs = 46 | [ GetOpt.Option "h" ["help"] (GetOpt.NoArg OptionHelp ) "print help and exit" 47 | , GetOpt.Option "" ["version"] (GetOpt.NoArg OptionVersion) "print version and exit" 48 | , GetOpt.Option "v" ["verbose"] (GetOpt.NoArg OptionVerbose) "control verbosity. Can be used multiple times, -vvvv is max." 49 | , GetOpt.Option "" ["dry-run"] (GetOpt.NoArg OptionDryRun) "stop before firing any rockets." 50 | ] 51 | 52 | 53 | main :: IO () 54 | main = do 55 | args <- System.Environment.getArgs 56 | let (opts, others, errs) = GetOpt.getOpt GetOpt.Permute optDescrs args 57 | let catcher f = (f $> ()) `catch` \e -> putStrLn "" >> print (e :: ErrorCall) 58 | _ <- 59 | catcher $ runMaybeT $ runMultiRWSTNil_ $ withMultiState initialLogState $ do 60 | let printHelp = do 61 | liftIO $ putStrLn $ GetOpt.usageInfo initNote optDescrs 62 | mzero 63 | printVersion = do 64 | liftIO 65 | $ putStrLn 66 | $ "iridium version " 67 | ++ showVersion version 68 | ++ ", (c) 2016 Lennart Spitzner" 69 | mzero 70 | when (not $ null errs) printHelp 71 | when (not $ null others) printHelp 72 | when (OptionHelp `elem` opts) printHelp 73 | when (OptionVersion `elem` opts) printVersion 74 | let verbosity = length $ filter (==OptionVerbose) $ opts 75 | let levels = 76 | [ LogLevelSilent 77 | , LogLevelPrint 78 | , LogLevelDebug 79 | , LogLevelTrace 80 | , LogLevelWarn 81 | , LogLevelError 82 | , LogLevelThread 83 | ] 84 | ++ [ LogLevelInfo | verbosity > 0 ] 85 | ++ [ LogLevelInfoVerbose | verbosity > 1 ] 86 | ++ [ LogLevelInfoVerboser | verbosity > 2 ] 87 | ++ [ LogLevelInfoSpam | verbosity > 3 ] 88 | setLogMask levels 89 | let argConfig = if OptionDryRun `elem` opts 90 | then 91 | Yaml.Object 92 | $ HM.singleton (Text.pack "process") 93 | $ Yaml.Object 94 | $ HM.singleton (Text.pack "dry-run") 95 | $ Yaml.Bool 96 | $ True 97 | else Yaml.Object $ HM.empty 98 | iridiumMain argConfig 99 | return () 100 | -------------------------------------------------------------------------------- /src/Development/Iridium.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | 4 | module Development.Iridium 5 | ( iridiumMain 6 | , initNote 7 | , retrieveInfos 8 | , runChecks 9 | , displaySummary 10 | , askGlobalConfirmation 11 | ) 12 | where 13 | 14 | 15 | 16 | import qualified Data.Text as Text 17 | import qualified Turtle as Turtle 18 | import qualified Control.Foldl as Foldl 19 | 20 | import Data.Text ( Text ) 21 | import Control.Monad.Trans.Maybe 22 | import Control.Monad.Trans.Class 23 | import Control.Monad.IO.Class 24 | import Control.Monad 25 | import Text.Read ( readMaybe ) 26 | import Control.Monad.Extra ( whenM, unlessM ) 27 | import Control.Monad.Trans.MultiRWS 28 | import Control.Monad.Trans.Control 29 | import Data.Proxy 30 | import Data.Tagged 31 | import Data.List 32 | import Data.HList.HList 33 | import Data.Maybe 34 | 35 | import Data.HList.ContainsType 36 | 37 | import Data.Version ( showVersion, parseVersion ) 38 | import Filesystem.Path.CurrentOS hiding ( null ) 39 | import System.Exit 40 | import Text.ParserCombinators.ReadP 41 | import qualified Distribution.PackageDescription as PackageDescription 42 | import Distribution.PackageDescription.Parse 43 | import qualified Distribution.Package as Package 44 | 45 | import Development.Iridium.Types 46 | import Development.Iridium.Utils 47 | import Development.Iridium.UI.Console 48 | import Development.Iridium.Hackage 49 | import Development.Iridium.Config 50 | import Development.Iridium.UI.Prompt 51 | import Development.Iridium.CheckState 52 | import qualified Development.Iridium.Checks as Checks 53 | import qualified Development.Iridium.Repo.Git as Git 54 | import Development.Iridium.ExternalProgWrappers 55 | 56 | 57 | 58 | initNote :: String 59 | initNote 60 | = "iridium - automated cabal package uploading utility" 61 | 62 | retrieveInfos 63 | :: ( MonadIO m 64 | , MonadPlus m 65 | , MonadMultiState LogState m 66 | , MonadMultiReader Config m 67 | ) 68 | => m Infos 69 | retrieveInfos = do 70 | cabalInvoc <- configReadStringWithDefaultM "cabal" ["setup", "cabal-command"] 71 | cabalVersion <- getExternalProgramVersion cabalInvoc 72 | when (cabalVersion < [1,22,8]) $ do 73 | pushLog LogLevelError "This program requires cabal version 1.22.8 or later. aborting." 74 | mzero 75 | whenM (configIsEnabledM ["checks", "hlint"]) $ do 76 | hlint <- configReadStringWithDefaultM "hlint" ["setup", "hlint-command"] 77 | _ <- getExternalProgramVersion hlint 78 | return () 79 | cwd <- Turtle.pwd 80 | packageDesc <- do 81 | packageFile <- do 82 | allFiles <- Turtle.fold (Turtle.ls cwd) Foldl.list 83 | let cabalFiles = 84 | filter (\p -> Turtle.extension p == Just (Text.pack "cabal")) 85 | allFiles 86 | case cabalFiles of 87 | [f] -> return f 88 | [] -> do 89 | pushLog LogLevelError "Error: Found no cabal package!" 90 | mzero 91 | _ -> do 92 | pushLog LogLevelError "Error: Found more than one cabal package file!" 93 | mzero 94 | pushLog LogLevelInfo $ "Reading cabal package description " ++ encodeString packageFile 95 | content <- Turtle.linesToText `liftM` Turtle.fold (Turtle.input packageFile) Foldl.list 96 | -- pushLog LogLevelDebug $ Text.unpack content 97 | let parseResult = parsePackageDescription $ Text.unpack content 98 | case parseResult of 99 | ParseFailed e -> do 100 | pushLog LogLevelError $ "Error parsing cabal package file: " ++ show e 101 | mzero 102 | ParseOk _ x -> do 103 | -- pushLog LogLevelDebug $ show $ packageDescription x 104 | return x 105 | let pkgName = (\(Package.PackageName n) -> n) 106 | $ Package.pkgName 107 | $ PackageDescription.package 108 | $ PackageDescription.packageDescription 109 | $ packageDesc 110 | urlStr <- configReadStringM ["setup", "remote-server"] 111 | latestVersionM <- retrieveLatestVersion urlStr pkgName 112 | pushLog LogLevelInfoVerbose $ "remote version: " ++ show (liftM showVersion latestVersionM) 113 | configDecideStringM ["repository", "type"] 114 | [ (,) "none" $ do 115 | repoInfo :: NoRepo <- repo_retrieveInfo 116 | return $ Infos cwd packageDesc latestVersionM repoInfo 117 | , (,) "git" $ do 118 | repoInfo :: Git.GitImpl <- repo_retrieveInfo 119 | return $ Infos cwd packageDesc latestVersionM repoInfo 120 | ] 121 | 122 | 123 | runChecks 124 | :: ( MonadIO m0 125 | , MonadPlus m0 126 | , ContainsType LogState s 127 | , ContainsType CheckState s 128 | , ContainsType Config r 129 | , ContainsType Infos r 130 | ) 131 | => MultiRWST r w s m0 () 132 | runChecks = do 133 | whenM (configIsEnabledM ["checks", "compiler-versions"]) $ Checks.compileVersions 134 | whenM (configIsEnabledM ["checks", "upper-bounds-stackage"]) $ Checks.upperBoundsStackage 135 | whenM (configIsEnabledM ["checks", "documentation"]) $ Checks.documentation 136 | -- we do this last so that we return in an "everything is compiled" state, 137 | -- if possible. 138 | unlessM (configIsEnabledM ["checks", "compiler-versions"]) $ Checks.compile 139 | whenM (configIsEnabledM ["checks", "hlint"]) Checks.hlint 140 | whenM (configIsEnabledM ["checks", "lower-bounds-exist"]) $ Checks.lowerBounds 141 | whenM (configIsEnabledM ["checks", "upper-bounds-exist"]) $ Checks.upperBounds 142 | whenM (return True) Checks.packageCheck 143 | whenM (configIsEnabledM ["checks", "package-sdist"]) $ Checks.packageSDist 144 | whenM (configIsEnabledM ["checks", "changelog"]) $ Checks.changelog 145 | whenM (return True) Checks.remoteVersion 146 | whenM (return True) repoRunChecks 147 | 148 | displaySummary 149 | :: ( MonadIO m 150 | , MonadMultiState LogState m 151 | , MonadMultiState CheckState m 152 | , MonadMultiReader Config m 153 | , MonadMultiReader Infos m 154 | ) 155 | => m () 156 | displaySummary = do 157 | pushLog LogLevelPrint "Summary:" 158 | withIndentation $ do 159 | Package.PackageName pNameStr <- askPackageName 160 | pushLog LogLevelPrint $ "Package: " ++ pNameStr 161 | pVersion <- askPackageVersion 162 | pushLog LogLevelPrint $ "Version: " ++ showVersion pVersion 163 | latestVersionM <- liftM _i_remote_version mAsk 164 | case latestVersionM of 165 | Nothing -> return () 166 | Just v -> 167 | pushLog LogLevelPrint $ "Latest hackage version: " ++ showVersion v 168 | -- TODO: This should not be printed unless we verify that 169 | -- the information is correct by looking at the .cabal config. 170 | -- remoteServer <- configReadStringM ["setup", "remote-server"] 171 | -- pushLog LogLevelPrint $ "Remote location: " ++ remoteServer 172 | do 173 | CheckState _ errC warnC walls <- mGet 174 | pushLog LogLevelPrint $ "Warning count: " ++ show warnC 175 | pushLog LogLevelPrint $ "Error count: " ++ show errC 176 | let wallStr = if null walls then "[]" else intercalate ", " (reverse walls) 177 | pushLog LogLevelPrint $ "Not -Wall clean: " ++ wallStr 178 | do 179 | repoDisplaySummary 180 | uploadEnabled <- configIsTrueM ["process", "upload-docs"] 181 | repoActions <- repoActionSummary 182 | let actions = repoActions 183 | ++ ["Upload package"] 184 | ++ ["Upload documentation" | uploadEnabled] 185 | pushLog LogLevelPrint "" 186 | pushLog LogLevelPrint $ "Actions: " ++ intercalate 187 | "\n " actions 188 | return () 189 | 190 | askGlobalConfirmation 191 | :: ( MonadIO m 192 | , MonadPlus m 193 | ) 194 | => Bool 195 | -> m () 196 | askGlobalConfirmation existErrors = do 197 | if existErrors 198 | then promptSpecific "There are errors; write \"override\" to (try) continue anyways " "override" 199 | else promptYesOrNo "Continue [y]es [n]o? " 200 | 201 | iridiumMain 202 | :: Config 203 | -> MultiRWST '[] '[] '[LogState] (MaybeT IO) () 204 | iridiumMain argConfig = do 205 | fileConfig <- parseConfigs 206 | let mergedConfig = mergeConfigs argConfig fileConfig 207 | withMultiReader mergedConfig $ do 208 | infos <- retrieveInfos 209 | withMultiReader infos $ withMultiStateA initCheckState $ do 210 | runCabalUpdate <- fromMaybe True `liftM` configIsTrueMaybeM ["setup", "run-cabal-update"] 211 | when runCabalUpdate $ do 212 | runCommandSuccessCabal ["update"] 213 | runChecks 214 | displaySetting <- configIsTrueM ["process", "print-summary"] 215 | existWarnings <- liftM ((/=0) . _check_warningCount) mGet 216 | existErrors <- liftM ((/=0) . _check_errorCount ) mGet 217 | when displaySetting displaySummary 218 | whenM (not `liftM` configIsTrueM ["process", "dry-run"]) $ do 219 | pushLog LogLevelPrint "" 220 | configDecideStringM ["process", "confirmation"] 221 | [ ("confirm-always" , when (True ) $ askGlobalConfirmation existErrors) 222 | , ("confirm-on-warning", when (existWarnings || existErrors) $ askGlobalConfirmation existErrors) 223 | , ("confirm-on-error" , when ( existErrors) $ askGlobalConfirmation existErrors) 224 | ] 225 | repoPerformAction 226 | uploadPackage 227 | whenM (configIsTrueM ["process", "upload-docs"]) uploadDocs 228 | -------------------------------------------------------------------------------- /src/Development/Iridium/CheckState.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | {-# LANGUAGE ExistentialQuantification #-} 5 | 6 | module Development.Iridium.CheckState 7 | ( initCheckState 8 | , withStack 9 | , logStack 10 | , incWarningCounter 11 | , incErrorCounter 12 | , addNotWallClean 13 | , replaceStackTop 14 | ) 15 | where 16 | 17 | 18 | import Prelude hiding ( FilePath ) 19 | 20 | import qualified Data.Text as Text 21 | import qualified Turtle as Turtle 22 | import qualified Control.Foldl as Foldl 23 | 24 | import qualified Data.Yaml as Yaml 25 | import Control.Monad.Trans.MultiRWS 26 | import Control.Monad.Trans.Maybe 27 | import Control.Monad.Trans.Class 28 | import Control.Monad.IO.Class 29 | import Distribution.PackageDescription 30 | import Distribution.Package 31 | import Data.Version ( Version(..) ) 32 | import Data.Proxy 33 | import Data.Tagged 34 | import Control.Applicative 35 | import Control.Monad 36 | import Data.Functor 37 | import Data.List 38 | 39 | -- well, no Turtle, apparently. 40 | -- no way to retrieve stdout, stderr and exitcode. 41 | -- the most generic case, not supported? psshhh. 42 | import System.Process hiding ( cwd ) 43 | 44 | import Data.Maybe ( maybeToList ) 45 | 46 | import qualified Filesystem.Path.CurrentOS as Path 47 | 48 | import Development.Iridium.Types 49 | import Development.Iridium.UI.Console 50 | import Development.Iridium.UI.Prompt 51 | 52 | 53 | 54 | initCheckState :: CheckState 55 | initCheckState = CheckState [] 0 0 [] 56 | 57 | withStack 58 | :: ( MonadIO m 59 | , MonadMultiState LogState m 60 | , MonadMultiState CheckState m 61 | ) 62 | => String 63 | -> m a 64 | -> m a 65 | withStack s m = do 66 | s1 <- mGet 67 | let newStack = s : _check_stack s1 68 | mSet $ s1 { _check_stack = newStack } 69 | id $ withoutIndentation 70 | $ writeCurLine 71 | $ take 76 72 | $ intercalate ": " 73 | $ reverse 74 | $ fmap (take 20) 75 | $ newStack 76 | r <- m 77 | s2 <- mGet 78 | mSet $ s2 { _check_stack = _check_stack s1 } 79 | return r 80 | 81 | replaceStackTop 82 | :: ( MonadIO m 83 | , MonadMultiState LogState m 84 | , MonadMultiState CheckState m 85 | ) 86 | => String 87 | -> m () 88 | replaceStackTop s = do 89 | s1 <- mGet 90 | let newStack = s : drop 1 (_check_stack s1) 91 | mSet s1 { _check_stack = newStack } 92 | id $ withoutIndentation 93 | $ writeCurLine 94 | $ take 76 95 | $ intercalate ": " 96 | $ reverse 97 | $ fmap (take 20) 98 | $ newStack 99 | 100 | logStack 101 | :: ( MonadIO m 102 | , MonadMultiState CheckState m 103 | , MonadMultiState LogState m 104 | ) 105 | => m () 106 | logStack = do 107 | s1 <- mGet 108 | let line = "(" 109 | ++ intercalate ": " (reverse $ _check_stack s1) 110 | ++ ")" 111 | pushLog LogLevelPrint line 112 | 113 | incWarningCounter 114 | :: ( MonadMultiState CheckState m ) 115 | => m () 116 | incWarningCounter = do 117 | s <- mGet 118 | mSet $ s { _check_warningCount = _check_warningCount s + 1 } 119 | 120 | incErrorCounter 121 | :: ( MonadMultiState CheckState m ) 122 | => m () 123 | incErrorCounter = do 124 | s <- mGet 125 | mSet $ s { _check_errorCount = _check_errorCount s + 1 } 126 | 127 | addNotWallClean 128 | :: ( MonadMultiState CheckState m ) 129 | => String 130 | -> m () 131 | addNotWallClean compStr = do 132 | s <- mGet 133 | mSet $ s { _check_notWallClean = compStr : _check_notWallClean s } 134 | -------------------------------------------------------------------------------- /src/Development/Iridium/Checks.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | 3 | module Development.Iridium.Checks 4 | ( packageCheck 5 | , hlint 6 | , changelog 7 | , lowerBounds 8 | , upperBounds 9 | , remoteVersion 10 | , compile 11 | , documentation 12 | , compileVersions 13 | , upperBoundsStackage 14 | , packageSDist 15 | ) 16 | where 17 | 18 | 19 | 20 | import qualified Data.Text as Text 21 | import qualified Data.Text.IO as Text.IO 22 | import qualified Turtle as Turtle 23 | import qualified Control.Foldl as Foldl 24 | import qualified Network.HTTP as HTTP 25 | import qualified Data.ByteString as ByteString 26 | import qualified Data.ByteString.Lazy as ByteStringL 27 | 28 | import Control.Exception.Lifted 29 | import Control.Monad 30 | import Control.Monad.IO.Class 31 | import Control.Monad.Trans.Class 32 | import Control.Monad.Trans.Control 33 | import Control.Monad.Trans.Maybe 34 | import Control.Monad.Trans.MultiRWS 35 | 36 | import Data.Text ( Text ) 37 | import Data.Text.Encoding 38 | import Distribution.PackageDescription 39 | import Data.Maybe ( maybeToList, fromMaybe ) 40 | import Data.ByteString ( ByteString ) 41 | import qualified Data.ByteString as ByteString 42 | import Filesystem.Path.CurrentOS hiding ( null ) 43 | import Data.List ( isPrefixOf ) 44 | 45 | import qualified Distribution.Package 46 | import Distribution.Version 47 | 48 | -- no way to retrieve stdout, stderr and exitcode with turtle. 49 | -- the most generic case, not supported? psshhh. 50 | import System.Process hiding ( cwd ) 51 | import Data.List ( nub ) 52 | import Data.Version ( showVersion ) 53 | 54 | import Development.Iridium.CheckState 55 | import Development.Iridium.Config 56 | import Development.Iridium.Types 57 | import Development.Iridium.UI.Console 58 | import Development.Iridium.UI.Prompt 59 | import Development.Iridium.Utils 60 | import Development.Iridium.ExternalProgWrappers 61 | 62 | 63 | 64 | 65 | packageCheck 66 | :: ( MonadIO m 67 | , MonadMultiReader Config m 68 | , MonadMultiState LogState m 69 | , MonadMultiState CheckState m 70 | ) 71 | => m () 72 | packageCheck = do 73 | buildtool <- configReadStringM ["setup", "buildtool"] 74 | case buildtool of 75 | "cabal" -> boolToError $ runCheck "Checking package validity" $ do 76 | mzeroToFalse $ 77 | runCommandSuccessCabal ["check"] 78 | "cabal-new" -> boolToError $ runCheck "Checking package validity" $ do 79 | mzeroToFalse $ 80 | runCommandSuccessCabal ["check"] 81 | "stack" -> do 82 | -- stack has no "check". 83 | -- and no "upload --dry-run either." 84 | pushLog LogLevelWarn "stack has no `check` command!" 85 | pushLog LogLevelWarn "package validity could not be determined." 86 | return () 87 | _ -> error "bad config setup.buildtool" 88 | 89 | hlint 90 | :: ( MonadIO m 91 | , MonadMultiReader Config m 92 | , MonadMultiReader Infos m 93 | , MonadMultiState LogState m 94 | , MonadMultiState CheckState m 95 | ) 96 | => m () 97 | hlint = boolToWarning 98 | $ runCheck "Running hlint on hsSourceDirs" 99 | $ do 100 | buildInfos <- askAllBuildInfo 101 | -- pushLog LogLevelDebug $ show buildInfos 102 | let sourceDirs = nub $ buildInfos >>= hsSourceDirs 103 | pushLog LogLevelInfoVerboser $ "hsSourceDirs: " ++ show sourceDirs 104 | liftM and $ sourceDirs `forM` \path -> do 105 | mzeroToFalse $ 106 | runCommandSuccessHLint [path] 107 | 108 | changelog 109 | :: ( MonadIO m 110 | , MonadMultiState LogState m 111 | , MonadMultiState CheckState m 112 | , MonadMultiReader Infos m 113 | , MonadMultiReader Config m 114 | ) 115 | => m () 116 | changelog = boolToWarning 117 | $ runCheck "Testing if the changelog mentions the latest version" 118 | $ do 119 | pathRaw <- configReadStringM ["checks", "changelog", "location"] 120 | cwd <- liftM _i_cwd mAsk 121 | let path = cwd decodeString pathRaw 122 | exists <- Turtle.testfile path 123 | if (not exists) 124 | then do 125 | pushLog LogLevelPrint $ "changelog file (" ++ show path ++ ") does not exist!" 126 | return False 127 | else do 128 | changelogContentLines <- Turtle.fold (Turtle.input path) Foldl.list 129 | currentVersionStr <- liftM showVersion askPackageVersion 130 | if any (Text.pack currentVersionStr `Text.isInfixOf`) 131 | (Turtle.lineToText `fmap` changelogContentLines) 132 | then return True 133 | else do 134 | pushLog LogLevelError $ "changelog does not contain " ++ currentVersionStr 135 | return False 136 | 137 | lowerBounds 138 | :: ( MonadIO m 139 | , MonadMultiState LogState m 140 | , MonadMultiState CheckState m 141 | , MonadMultiReader Infos m 142 | ) 143 | => m () 144 | lowerBounds = boolToWarning 145 | $ runCheck "Checking that all dependencies have a lower bound" 146 | $ do 147 | buildInfos <- askAllBuildInfo 148 | pName <- askPackageName 149 | let missingBounds 150 | = [ name 151 | | info <- buildInfos 152 | , Distribution.Package.Dependency name range <- targetBuildDepends info 153 | , name /= pName -- ignore dependencies on the package's library 154 | , let intervals = asVersionIntervals range 155 | , let badLowerBound = LowerBound (Version [0] []) InclusiveBound 156 | , case intervals of 157 | [] -> True 158 | xs | any (\(lwr, _) -> lwr == badLowerBound) xs -> True 159 | _ -> False 160 | ] 161 | if null missingBounds 162 | then return True 163 | else do 164 | pushLog LogLevelError $ "Found dependencies without a lower bound:" 165 | missingBounds `forM_` \(Distribution.Package.PackageName n) -> 166 | pushLog LogLevelError $ " " ++ n 167 | return False 168 | 169 | upperBounds 170 | :: ( MonadIO m 171 | , MonadMultiState LogState m 172 | , MonadMultiState CheckState m 173 | , MonadMultiReader Infos m 174 | ) 175 | => m () 176 | upperBounds = boolToWarning 177 | $ runCheck "Checking that all dependencies have an upper bound" 178 | $ do 179 | buildInfos <- askAllBuildInfo 180 | pName <- askPackageName 181 | let missingBounds 182 | = [ name 183 | | info <- buildInfos 184 | , Distribution.Package.Dependency name range <- targetBuildDepends info 185 | , name /= pName -- ignore dependencies on the package's library 186 | , let intervals = asVersionIntervals range 187 | , case intervals of 188 | [] -> True 189 | xs | any (\(_, upr) -> upr == NoUpperBound) xs -> True 190 | _ -> False 191 | ] 192 | if null missingBounds 193 | then return True 194 | else do 195 | pushLog LogLevelError $ "Found dependencies without an upper bound:" 196 | missingBounds `forM_` \(Distribution.Package.PackageName n) -> 197 | pushLog LogLevelError $ " " ++ n 198 | return False 199 | 200 | remoteVersion 201 | :: ( MonadIO m 202 | , MonadMultiState LogState m 203 | , MonadMultiState CheckState m 204 | , MonadMultiReader Infos m 205 | ) 206 | => m () 207 | remoteVersion = boolToError 208 | $ runCheck "Comparing local version to hackage version" 209 | $ do 210 | infos <- mAsk 211 | localVersion <- askPackageVersion 212 | -- pushLog LogLevelDebug $ show $ _i_remote_version infos 213 | case _i_remote_version infos of 214 | Nothing -> do 215 | pushLog LogLevelWarn $ "no remote version detected. This is harmless if the package is not on hackage yet." 216 | return True 217 | Just remoteVers -> 218 | if localVersion == remoteVers 219 | then do 220 | pushLog LogLevelError $ "This package version (" ++ showVersion localVersion ++ ") is already on hackage; needs bump?" 221 | return False 222 | else if localVersion < remoteVers 223 | then do 224 | pushLog LogLevelWarn $ "The version on hackage (" 225 | ++ showVersion remoteVers 226 | ++ ") is greater than the local version (" 227 | ++ showVersion localVersion 228 | ++ ")." 229 | return False 230 | else return True 231 | 232 | compile 233 | :: forall m 234 | . ( MonadIO m 235 | , MonadPlus m 236 | , MonadMultiState LogState m 237 | , MonadMultiState CheckState m 238 | , MonadMultiReader Config m 239 | ) 240 | => m () 241 | compile = withStack "basic compilation" $ boolToError $ do 242 | 243 | warningsEnabled <- configIsEnabledM ["checks", "compiler-warnings"] 244 | if warningsEnabled 245 | then fallbackCheck 246 | (do 247 | b <- runCheck "Checking basic compilation" (checks True) 248 | unless b $ do 249 | incWarningCounter 250 | addNotWallClean "" 251 | return b 252 | ) 253 | (do 254 | pushLog LogLevelPrint "Falling back on compilation without warnings." 255 | runCheck "Checking basic compilation -w" (checks False) 256 | ) 257 | else 258 | runCheck "Checking basic compilation" (checks False) 259 | 260 | where 261 | checks :: Bool -> m Bool 262 | checks werror = do 263 | buildtool <- configReadStringM ["setup", "buildtool"] 264 | testsEnabled <- configIsEnabledM ["checks", "testsuites"] 265 | shouldCompat <- do 266 | c <- configIsTrueMaybeM ["checks", "compiler-warnings", "enable-compat"] 267 | pure $ fromMaybe False c 268 | case buildtool of 269 | "cabal" -> 270 | mzeroToFalse $ do 271 | let testsArg = ["--enable-tests" | testsEnabled] 272 | let werrorArg = ["--ghc-options=\"-Werror\"" | werror] 273 | ++ ["--ghc-options=\"-w\"" | not werror] 274 | let wcompatArg = if shouldCompat 275 | then ["--ghc-options=\"-Wcompat\""] 276 | else [] 277 | withDefaultCompiler <- createDefaultCompilerFlag 278 | runCommandSuccessCabal ["clean"] 279 | runCommandSuccessCabal $ ["install"] ++ withDefaultCompiler ++ ["--dep"] ++ testsArg 280 | runCommandSuccessCabal $ ["configure"] ++ withDefaultCompiler ++ testsArg ++ werrorArg ++ wcompatArg 281 | runCommandSuccessCabal ["build"] 282 | when testsEnabled $ 283 | runCommandSuccessCabal ["test"] 284 | return True 285 | "cabal-new" -> 286 | error "compile not supported in cabal-new" 287 | "stack" -> do 288 | pushLog LogLevelError "TODO: stack build" 289 | mzero 290 | _ -> error "strange buildtool" 291 | 292 | documentation 293 | :: ( MonadIO m 294 | , MonadMultiState LogState m 295 | , MonadMultiState CheckState m 296 | , MonadMultiReader Config m 297 | ) 298 | => m () 299 | documentation = boolToError 300 | $ runCheck "Checking documentation" 301 | $ withStack "documentation check" 302 | $ do 303 | buildtool <- configReadStringM ["setup", "buildtool"] 304 | case buildtool of 305 | "cabal" -> 306 | mzeroToFalse $ do 307 | withDefaultCompiler <- createDefaultCompilerFlag 308 | runCommandSuccessCabal $ ["clean"] 309 | runCommandSuccessCabal $ ["install", "--dep"] ++ withDefaultCompiler 310 | runCommandSuccessCabal $ ["configure"] ++ withDefaultCompiler 311 | runCommandSuccessCabal $ ["haddock"] 312 | "cabal-new" -> 313 | error "documentation not supported with cabal-new!" 314 | "stack" -> do 315 | pushLog LogLevelError "TODO: stack build" 316 | return False 317 | _ -> error "strange buildtool" 318 | 319 | compileVersions 320 | :: forall m 321 | . ( MonadIO m 322 | , MonadPlus m 323 | , MonadMultiState LogState m 324 | , MonadMultiState CheckState m 325 | , MonadMultiReader Config m 326 | ) 327 | => m () 328 | compileVersions = withStack "compiler checks" $ do 329 | 330 | buildtool <- configReadStringM ["setup", "buildtool"] 331 | testsEnabled <- configIsEnabledM ["checks", "testsuites"] 332 | warningsEnabled <- configIsEnabledM ["checks", "compiler-warnings"] 333 | 334 | case () of { 335 | () -> do 336 | if testsEnabled 337 | then pushLog LogLevelPrint "Checking compilation and tests with different compiler versions" 338 | else pushLog LogLevelPrint "Checking compilation with different compiler versions" 339 | withIndentation $ do 340 | rawList <- configReadListM ["checks", "compiler-versions", "compilers"] 341 | rawList `forM_` \val -> boolToError $ do 342 | let compilerStr = configReadString ["compiler"] val 343 | ++ "-" 344 | ++ configReadString ["version"] val 345 | let checkBaseName = "Checking with compiler " ++ compilerStr 346 | withStack compilerStr $ if warningsEnabled 347 | then 348 | fallbackCheck 349 | (do 350 | b <- runCheck checkBaseName $ checks compilerStr True 351 | unless b $ do 352 | incWarningCounter 353 | addNotWallClean compilerStr 354 | return b 355 | ) 356 | (do 357 | pushLog LogLevelPrint "Falling back on compilation without warnings." 358 | runCheck (checkBaseName ++ " -w") $ checks compilerStr False 359 | ) 360 | else 361 | runCheck checkBaseName $ checks compilerStr False 362 | 363 | where 364 | checks :: String -> Bool -> m Bool 365 | checks compilerStr werror = case buildtool of 366 | "cabal" -> do 367 | let confList = ["setup", "compiler-paths", compilerStr] 368 | compilerPathMaybe <- configReadStringMaybeM confList 369 | compilerPath <- case compilerPathMaybe of 370 | Nothing -> do 371 | pushLog LogLevelError $ "Expected string in config for " ++ show confList 372 | mzero 373 | Just x -> return x 374 | shouldCompat <- do 375 | c <- configIsTrueMaybeM ["checks", "compiler-warnings", "enable-compat"] 376 | pure $ case c of 377 | Just True -> not $ ("ghc-7" `isPrefixOf` compilerStr) 378 | _ -> False 379 | mzeroToFalse $ do 380 | let testsArg = ["--enable-tests" | testsEnabled] 381 | let werrorArg = ["--ghc-options=\"-Werror\"" | werror] 382 | ++ ["--ghc-options=\"-w\"" | not werror] 383 | let wcompatArg = if shouldCompat 384 | then ["--ghc-options=\"-Wcompat\""] 385 | else [] 386 | runCommandSuccessCabal ["clean"] 387 | runCommandSuccessCabal $ ["install", "--dep", "-w" ++ compilerPath] 388 | ++ testsArg 389 | runCommandSuccessCabal $ ["configure", "-w" ++ compilerPath] 390 | ++ testsArg 391 | ++ werrorArg 392 | ++ wcompatArg 393 | runCommandSuccessCabal ["build"] 394 | when testsEnabled $ 395 | runCommandSuccessCabal ["test"] 396 | "cabal-new" -> do 397 | let confList = ["setup", "compiler-paths", compilerStr] 398 | compilerPathMaybe <- configReadStringMaybeM confList 399 | compilerPath <- case compilerPathMaybe of 400 | Nothing -> do 401 | pushLog LogLevelError $ "Expected string in config for " ++ show confList 402 | mzero 403 | Just x -> return x 404 | mzeroToFalse $ do 405 | let testsArg = ["--enable-tests" | testsEnabled] 406 | Turtle.rmtree (Turtle.fromString "dist-newstyle/cache") 407 | runCommandSuccessCabal $ ["new-build", "--project-file=cabal.project." ++ compilerStr] 408 | ++ testsArg 409 | when testsEnabled $ 410 | runCommandSuccessCabal $ ["new-test", "-w" ++ compilerPath] ++ testsArg 411 | "stack" -> do 412 | pushLog LogLevelError "TODO: stack build" 413 | mzero 414 | _ -> error "strange buildtool" 415 | } 416 | 417 | upperBoundsStackage 418 | :: forall m 419 | . ( MonadIO m 420 | , MonadPlus m 421 | , MonadMultiState LogState m 422 | , MonadMultiState CheckState m 423 | , MonadMultiReader Infos m 424 | , MonadMultiReader Config m 425 | ) 426 | => m () 427 | upperBoundsStackage = withStack "stackage upper bound" $ boolToError $ do 428 | 429 | runCheck "Checking upper bounds using stackage" $ do 430 | buildtool <- configReadStringM ["setup", "buildtool"] 431 | testsEnabled <- configIsEnabledM ["checks", "testsuites"] 432 | case buildtool of 433 | "cabal" -> do 434 | cabalConfigPath <- getLocalFilePath "cabal.config" 435 | cabalConfigBackupPath <- getLocalFilePath "cabal.config.backup" 436 | alreadyExists <- Turtle.testfile cabalConfigPath 437 | -- TODO: make this safe against ctrl-c again. 438 | -- TODO: make sure the backup does not exist yet. (!) 439 | pushLog LogLevelInfo $ "Preparing cabal.config" 440 | when alreadyExists $ do 441 | pushLog LogLevelInfoVerbose $ "Renaming existing cabal.config to cabal.config.backup" 442 | Turtle.mv cabalConfigPath cabalConfigBackupPath 443 | result <- mzeroToFalse $ do 444 | useNightly <- configIsTrueM ["checks", "upper-bounds-stackage", "use-nightly"] 445 | let urlStr = if useNightly 446 | then "http://www.stackage.org/nightly/cabal.config" 447 | else "http://www.stackage.org/lts/cabal.config" 448 | cabalConfigContents <- fetchCabalConfig urlStr 449 | pName <- liftM (Text.pack . (\(Distribution.Package.PackageName n) -> n)) askPackageName 450 | let filteredLines = filter (not . (pName `Text.isInfixOf`)) 451 | $ Text.lines cabalConfigContents 452 | -- pushLog LogLevelDebug $ "Writing n lines to cabal.config: " ++ show (length filteredLines) 453 | liftIO $ Text.IO.writeFile (encodeString cabalConfigPath) (Text.unlines filteredLines) 454 | let testsArg = ["--enable-tests" | testsEnabled] 455 | runCommandSuccessCabal ["clean"] 456 | withDefaultCompiler <- createDefaultCompilerFlag 457 | runCommandSuccessCabal $ ["--no-require-sandbox", "--ignore-sandbox", "install", "--dep", "--global", "--dry-run"] ++ withDefaultCompiler ++ testsArg 458 | pushLog LogLevelInfo $ "Cleanup (cabal.config)" 459 | unless alreadyExists $ Turtle.rm cabalConfigPath 460 | when alreadyExists $ Turtle.mv cabalConfigBackupPath cabalConfigPath 461 | -- let 462 | -- act :: MaybeT m () = do 463 | -- pushLog LogLevelInfo $ "Preparing cabal.config" 464 | -- when alreadyExists $ do 465 | -- pushLog LogLevelInfoVerbose $ "Renaming existing cabal.config to cabal.config.backup" 466 | -- Turtle.mv cabalConfigPath cabalConfigBackupPath 467 | -- useNightly <- configIsTrueM ["checks", "upper-bounds-stackage", "use-nightly"] 468 | -- let urlStr = if useNightly 469 | -- then "http://www.stackage.org/nightly/cabal.config" 470 | -- else "http://www.stackage.org/lts/cabal.config" 471 | -- cabalConfigContents <- fetchCabalConfig urlStr 472 | -- pName <- liftM (Text.pack . (\(Distribution.Package.PackageName n) -> n)) askPackageName 473 | -- let filteredLines = filter (pName `Text.isInfixOf`) 474 | -- $ Text.lines 475 | -- $ decodeUtf8 cabalConfigContents 476 | -- liftIO $ Text.IO.writeFile (encodeString cabalConfigPath) (Text.unlines filteredLines) 477 | -- let testsArg = ["--enable-tests" | testsEnabled] 478 | -- runCommandSuccessCabal ["clean"] 479 | -- runCommandSuccessCabal $ ["install", "--dep"] ++ testsArg 480 | -- fin = do 481 | -- pushLog LogLevelInfo $ "Cleanup (cabal.config)" 482 | -- when alreadyExists $ Turtle.mv cabalConfigBackupPath cabalConfigPath 483 | -- act `finally` fin 484 | return result 485 | "stack" -> do 486 | pushLog LogLevelError "TODO: stack upper bound check" 487 | mzero 488 | _ -> error "strange buildtool" 489 | 490 | where 491 | fetchCabalConfig 492 | :: forall m0 493 | . ( MonadIO m0 494 | , MonadMultiState LogState m0 495 | , MonadPlus m0 496 | ) 497 | => String 498 | -> m0 Text 499 | fetchCabalConfig urlStr = do 500 | pushLog LogLevelInfoVerbose $ "Fetching up-to-date cabal.config from " ++ urlStr 501 | -- TODO: exception handling 502 | e <- liftIO $ HTTP.simpleHTTP (HTTP.getRequest urlStr) 503 | case e of 504 | Left err -> do 505 | pushLog LogLevelError 506 | $ "Error: failed fetching stackage cabal.config! " ++ show err 507 | mzero 508 | Right r -> return $ Text.pack $ HTTP.rspBody r 509 | -- url <- case URI.parseURI urlStr of 510 | -- Nothing -> do 511 | -- pushLog LogLevelError "bad URI" 512 | -- mzero 513 | -- Just u -> return u 514 | -- result <- liftIO $ HTTP.simpleHTTP (HTTP.mkRequest HTTP.GET url) 515 | -- case result of 516 | -- Left _ -> do 517 | -- pushLog LogLevelError "Error: Could not retrieve hackage version" 518 | -- mzero 519 | -- Right x -> do 520 | -- pushLog LogLevelInfoVerboser $ show x 521 | -- let body = HTTP.rspBody x 522 | -- pushLog LogLevelInfoVerbose $ "Retrieved " ++ show (ByteString.length body) ++ " bytes." 523 | -- return $ body 524 | 525 | packageSDist 526 | :: forall m 527 | . ( MonadIO m 528 | , MonadPlus m 529 | , MonadMultiState LogState m 530 | , MonadMultiState CheckState m 531 | , MonadMultiReader Infos m 532 | , MonadMultiReader Config m 533 | ) 534 | => m () 535 | packageSDist = withStack "package sdist" $ boolToError $ do 536 | 537 | runCheck "Testing the source distribution package" $ do 538 | 539 | Distribution.Package.PackageName pName <- askPackageName 540 | currentVersionStr <- liftM showVersion askPackageVersion 541 | 542 | buildtool <- configReadStringM ["setup", "buildtool"] 543 | case buildtool of 544 | "cabal" -> mzeroToFalse $ do 545 | runCommandSuccessCabal ["sdist"] 546 | let sdistName = pName ++ "-" ++ currentVersionStr ++ ".tar.gz" 547 | withDefaultCompiler <- createDefaultCompilerFlag 548 | runCommandSuccessCabal $ ["install", "dist/" ++ sdistName] ++ withDefaultCompiler 549 | "cabal-new" -> error "not supported in cabal-new" 550 | -- mzeroToFalse $ do 551 | -- runCommandSuccessCabal ["sdist"] 552 | -- Turtle.rmtree (Turtle.fromString "dist-newstyle/cache") 553 | -- runCommandSuccessCabal $ ["new-build", "--project-file=cabal.project.disttest"] 554 | "stack" -> do 555 | pushLog LogLevelError "TODO: stack upper bound check" 556 | mzero 557 | _ -> error "strange buildtool" 558 | -------------------------------------------------------------------------------- /src/Development/Iridium/Config.hs: -------------------------------------------------------------------------------- 1 | module Development.Iridium.Config 2 | ( parseConfigs 3 | , configIsTrue 4 | , configIsTrueM 5 | , configIsTrueMaybe 6 | , configIsTrueMaybeM 7 | , configIsEnabled 8 | , configIsEnabledM 9 | , configReadString 10 | , configReadStringM 11 | , configReadStringMaybe 12 | , configReadStringMaybeM 13 | , configReadList 14 | , configReadListM 15 | , configReadStringWithDefaultM 16 | , configDecideStringM 17 | , mergeConfigs 18 | ) 19 | where 20 | 21 | 22 | 23 | import Prelude hiding ( FilePath ) 24 | 25 | import qualified Data.Yaml as Yaml 26 | import qualified Data.Yaml.Pretty as YamlPretty 27 | import qualified Turtle.Prelude as Turtle 28 | import qualified Data.HashMap.Strict as HM 29 | import qualified Data.ByteString.Char8 as BSChar8 30 | import qualified Data.Text as Text 31 | import qualified Data.Vector as DV 32 | import qualified Data.List as List 33 | import qualified Data.ByteString as BS 34 | import qualified Data.Vector 35 | 36 | import Control.Monad.Trans.Maybe 37 | import Control.Monad.IO.Class 38 | import Filesystem.Path.CurrentOS 39 | import Control.Monad.Trans.MultiRWS 40 | import Data.Text ( Text ) 41 | import Control.Monad 42 | import Data.Monoid 43 | import Data.Maybe 44 | import Data.Ord ( comparing ) 45 | 46 | import Development.Iridium.UI.Console 47 | import Development.Iridium.Types 48 | import Paths_iridium 49 | 50 | 51 | 52 | readConfFile 53 | :: ( MonadIO m 54 | , MonadMultiState LogState m 55 | , MonadPlus m 56 | ) 57 | => FilePath 58 | -> m Config 59 | readConfFile path = do 60 | pushLog LogLevelInfoVerbose $ "Reading config file " ++ encodeString path 61 | eitherValue <- liftIO $ Yaml.decodeFileEither $ encodeString path 62 | case eitherValue of 63 | Left e -> do 64 | pushLog LogLevelError $ "Error reading config file " ++ encodeString path 65 | pushLog LogLevelError $ show e 66 | mzero 67 | Right o@Yaml.Object{} -> return o 68 | Right _ -> do 69 | pushLog LogLevelError $ "Error reading config file: expecting YAML object." 70 | pushLog LogLevelError $ "(Parsing was successful but returned something else,\nlike a list. or smth.)" 71 | mzero 72 | 73 | writeConfigToFile :: String -> Config -> IO () 74 | writeConfigToFile path config = 75 | writeFile 76 | path 77 | (headerComment ++ "\n---\n" ++ unlines (go Nothing 0 config) ++ "...\n") 78 | where 79 | headerComment :: String 80 | headerComment = unlines 81 | $ map ("# " ++) 82 | $ [ "see https://github.com/lspitzner/iridium" 83 | , "" 84 | , "note that you can add a user-global .iridium.yaml" 85 | , "into $HOME, containing e.g." 86 | , "" 87 | , "---" 88 | , "setup:" 89 | , " compiler-paths:" 90 | , " ghc-7.10.3: /opt/ghc-7.10.3/bin/ghc" 91 | , " ghc-7.8.4: /opt/ghc-7.8.4/bin/ghc" 92 | , "" 93 | , " hackage:" 94 | , " username: user" 95 | , "..." 96 | , "" 97 | ] 98 | -- The reason for this custom pretty-printing is that encodePretty from 99 | -- the yaml package formats strings horribly, which 100 | -- makes the documentation elements more annoying to parse than they 101 | -- are helpful. 102 | go :: Maybe String -> Int -> Config -> [String] 103 | go firstLine indent (Yaml.Object m) 104 | = maybe id (:) firstLine -- (firstLine:) 105 | $ List.sortBy (comparing fst) (HM.toList m) >>= \(k, v) -> 106 | go (Just $ replicate indent ' ' ++ Text.unpack k ++ ":") (indent+2) v 107 | go firstLine indent (Yaml.Array a) 108 | = maybe id (:) firstLine 109 | $ Data.Vector.toList a >>= \v -> 110 | case go Nothing 0 v of 111 | [] -> [] 112 | (x:xr) -> (replicate indent ' ' ++ "- " ++ x) 113 | : (fmap ((replicate (indent+2) ' ')++) xr) 114 | go firstLine indent (Yaml.String s) 115 | = case (lines $ Text.unpack s, firstLine) of 116 | ([], Just l) -> 117 | [l ++ " \"\""] 118 | ([x], Just l) | '"' `notElem` x -> -- " this editor has highlighting problems.. 119 | [l ++ " " ++ show x] 120 | (xs, Just l) -> 121 | ((l ++ " |"):) 122 | $ fmap ((replicate indent ' ') ++) 123 | $ xs 124 | (xs, Nothing) -> 125 | fmap ((replicate indent ' ') ++) xs 126 | go firstLine indent (Yaml.Number i) 127 | = case firstLine of 128 | Just l -> [l ++ " " ++ show i] 129 | Nothing -> [replicate indent ' ' ++ show i] 130 | go firstLine indent (Yaml.Bool b) 131 | = case firstLine of 132 | Just l -> [l ++ " " ++ show b] 133 | Nothing -> [replicate indent ' ' ++ show b] 134 | go _firstLine _indent Yaml.Null 135 | = error "Null" 136 | 137 | determineConfFromStuff 138 | :: -- ( MonadIO m 139 | -- , MonadMultiState LogState m 140 | -- ) 141 | Monad m 142 | => 143 | m Config 144 | determineConfFromStuff = do 145 | return $ Yaml.Object $ HM.empty -- TODO 146 | 147 | parseConfigs 148 | :: ( MonadIO m 149 | , MonadPlus m 150 | , MonadMultiState LogState m 151 | ) 152 | => m Yaml.Value 153 | parseConfigs = do 154 | pushLog LogLevelInfo "Reading config files.." 155 | 156 | home <- Turtle.home 157 | cwd <- Turtle.pwd 158 | let userConfPath = home decodeString ".iridium.yaml" 159 | let userDefaultConfPath = home decodeString ".iridium-default.yaml" 160 | let localConfPath = cwd decodeString "iridium.yaml" 161 | staticDefaultPath <- liftIO $ getDataFileName "default-iridium.yaml" 162 | userConfExists <- Turtle.testfile $ userConfPath 163 | userDefaultConfExists <- Turtle.testfile $ userDefaultConfPath 164 | localConfExists <- Turtle.testfile $ localConfPath 165 | 166 | userConf <- if userConfExists 167 | then do 168 | pushLog LogLevelInfoVerbose $ "Reading user config file from " 169 | ++ encodeString userConfPath 170 | readConfFile userConfPath 171 | else return $ Yaml.Object $ HM.empty 172 | 173 | localConf <- if localConfExists 174 | then readConfFile localConfPath 175 | else do 176 | userDefaultConf <- if userDefaultConfExists 177 | then do 178 | pushLog LogLevelInfoVerbose $ "Reading user default config from " 179 | ++ encodeString userDefaultConfPath 180 | readConfFile userDefaultConfPath 181 | else return $ Yaml.Object $ HM.empty 182 | calculatedConf <- determineConfFromStuff 183 | staticDefaultConf <- do 184 | pushLog LogLevelInfoVerbose $ "Reading static default config from " 185 | ++ staticDefaultPath 186 | readConfFile (decodeString staticDefaultPath) 187 | 188 | let combinedConfig = mergeConfigs 189 | userDefaultConf -- 1. priority 190 | $ mergeConfigs 191 | calculatedConf -- 2. priority 192 | staticDefaultConf -- 3. priority 193 | 194 | pushLog LogLevelInfo $ "Creating default iridium.yaml." 195 | liftIO $ writeConfigToFile (encodeString localConfPath) combinedConfig 196 | 197 | readConfFile localConfPath 198 | 199 | let final = mergeConfigs localConf userConf 200 | let displayStr = unlines 201 | $ fmap (" " ++) 202 | $ lines 203 | $ BSChar8.unpack 204 | $ YamlPretty.encodePretty YamlPretty.defConfig final 205 | pushLog LogLevelInfoVerboser $ "Parsed config: \n" ++ displayStr 206 | return $ final 207 | 208 | -- left-preferring merge; deep merge for objects/arrays 209 | mergeConfigs :: Yaml.Value -> Yaml.Value -> Yaml.Value 210 | mergeConfigs (Yaml.Object o1) (Yaml.Object o2) = Yaml.Object $ HM.unionWith mergeConfigs o1 o2 211 | mergeConfigs (Yaml.Array a1) (Yaml.Array a2) = Yaml.Array $ a1 <> a2 212 | mergeConfigs Yaml.Null x = x 213 | mergeConfigs x _ = x 214 | 215 | configIsTrueM 216 | :: MonadMultiReader Config m 217 | => [String] 218 | -> m Bool 219 | configIsTrueM ps'' = configIsTrue ps'' `liftM` mAsk 220 | 221 | configIsTrue :: [String] -> Yaml.Value -> Bool 222 | configIsTrue ps'' = go ps'' 223 | where 224 | go :: [String] -> Yaml.Value -> Bool 225 | go [] v = case v of 226 | Yaml.Bool b -> b 227 | _ -> error $ "error in yaml data: expected Bool, got " ++ show v 228 | go (p:pr) v = case v of 229 | Yaml.Object hm -> case HM.lookup (Text.pack p) hm of 230 | Just v' -> go pr v' 231 | Nothing -> error $ "error in yaml data: no find element " ++ show p ++ " when looking for config " ++ show ps'' 232 | _ -> error $ "error in yaml data: expected Object, got " ++ show v 233 | 234 | configIsTrueMaybe :: [String] -> Yaml.Value -> Maybe Bool 235 | configIsTrueMaybe ps'' = go ps'' 236 | where 237 | go :: [String] -> Yaml.Value -> Maybe Bool 238 | go [] v = case v of 239 | Yaml.Bool b -> Just b 240 | _ -> Nothing 241 | go (p:pr) v = case v of 242 | Yaml.Object hm -> case HM.lookup (Text.pack p) hm of 243 | Just v' -> go pr v' 244 | Nothing -> Nothing 245 | _ -> Nothing 246 | 247 | configIsTrueMaybeM 248 | :: MonadMultiReader Config m 249 | => [String] 250 | -> m (Maybe Bool) 251 | configIsTrueMaybeM ps = configIsTrueMaybe ps `liftM` mAsk 252 | 253 | configIsEnabledM 254 | :: MonadMultiReader Config m 255 | => [String] 256 | -> m Bool 257 | configIsEnabledM ps = configIsEnabled ps `liftM` mAsk 258 | 259 | configIsEnabled :: [String] -> Yaml.Value -> Bool 260 | configIsEnabled ps v = fromMaybe False $ configIsTrueMaybe (ps ++ ["enabled"]) v 261 | 262 | configReadStringM 263 | :: MonadMultiReader Config m 264 | => [String] 265 | -> m String 266 | configReadStringM ps'' = configReadString ps'' `liftM` mAsk 267 | 268 | configReadString :: [String] -> Yaml.Value -> String 269 | configReadString ps'' = go ps'' 270 | where 271 | go :: [String] -> Yaml.Value -> String 272 | go [] v = case v of 273 | Yaml.String b -> Text.unpack b 274 | _ -> error $ "error in yaml data: expected String, got " ++ show v 275 | go (p:pr) v = case v of 276 | Yaml.Object hm -> case HM.lookup (Text.pack p) hm of 277 | Just v' -> go pr v' 278 | Nothing -> error $ "error in yaml data: no find element " ++ show p ++ " when looking for config " ++ show ps'' 279 | _ -> error $ "error in yaml data: expected Object, got " ++ show v 280 | 281 | configReadStringMaybeM 282 | :: MonadMultiReader Config m 283 | => [String] 284 | -> m (Maybe String) 285 | configReadStringMaybeM ps'' = configReadStringMaybe ps'' `liftM` mAsk 286 | 287 | configReadStringMaybe :: [String] -> Yaml.Value -> Maybe String 288 | configReadStringMaybe ps'' = go ps'' 289 | where 290 | go :: [String] -> Yaml.Value -> Maybe String 291 | go [] v = case v of 292 | Yaml.String b -> Just $ Text.unpack b 293 | _ -> Nothing 294 | go (p:pr) v = case v of 295 | Yaml.Object hm -> go pr =<< HM.lookup (Text.pack p) hm 296 | _ -> Nothing 297 | 298 | configReadStringWithDefaultM 299 | :: MonadMultiReader Config m 300 | => String 301 | -> [String] 302 | -> m String 303 | configReadStringWithDefaultM def ps = do 304 | liftM (fromMaybe def) $ configReadStringMaybeM ps 305 | 306 | configReadListM 307 | :: MonadMultiReader Config m 308 | => [String] 309 | -> m [Yaml.Value] 310 | configReadListM ps'' = configReadList ps'' `liftM` mAsk 311 | 312 | configReadList :: [String] -> Yaml.Value -> [Yaml.Value] 313 | configReadList ps'' = go ps'' 314 | where 315 | go :: [String] -> Yaml.Value -> [Yaml.Value] 316 | go [] v = case v of 317 | Yaml.Array a -> DV.toList a 318 | _ -> error $ "error in yaml data: expected Array, got " ++ show v 319 | go (p:pr) v = case v of 320 | Yaml.Object hm -> case HM.lookup (Text.pack p) hm of 321 | Just v' -> go pr v' 322 | Nothing -> error $ "error in yaml data: no find element " ++ show p ++ " when looking for config " ++ show ps'' 323 | _ -> error $ "error in yaml data: expected Object, got " ++ show v 324 | 325 | configDecideStringM 326 | :: ( MonadIO m 327 | , MonadPlus m 328 | , MonadMultiReader Config m 329 | , MonadMultiState LogState m 330 | ) 331 | => [String] 332 | -> [(String, m a)] 333 | -> m a 334 | configDecideStringM ps opts = do 335 | str <- configReadStringM ps 336 | case List.lookup str opts of 337 | Nothing -> do 338 | pushLog LogLevelError $ "Error looking up config value " 339 | ++ show ps 340 | ++ "; expecting one of " 341 | ++ show (fmap fst opts) 342 | ++ "." 343 | mzero 344 | Just k -> k 345 | -------------------------------------------------------------------------------- /src/Development/Iridium/ExternalProgWrappers.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | {-# LANGUAGE ExistentialQuantification #-} 5 | 6 | module Development.Iridium.ExternalProgWrappers 7 | ( runCommandSuccess 8 | , runCommandStdOut 9 | , observeCreateProcessWithExitCode 10 | , getExternalProgramVersion 11 | , runCommandSuccessCabal 12 | , runCommandSuccessHLint 13 | ) 14 | where 15 | 16 | 17 | import Prelude hiding ( FilePath ) 18 | 19 | import qualified Data.Text as Text 20 | import qualified Turtle as Turtle 21 | import qualified Control.Foldl as Foldl 22 | import qualified Control.Exception as C 23 | 24 | import qualified Data.Yaml as Yaml 25 | import Control.Monad.Trans.MultiRWS 26 | import Control.Monad.Trans.MultiState as MultiState 27 | import Control.Monad.Trans.Maybe 28 | import Control.Monad.Trans.Class 29 | import Control.Monad.IO.Class 30 | import Distribution.PackageDescription 31 | import Distribution.Package 32 | import Filesystem.Path.CurrentOS hiding ( null ) 33 | import Data.Version ( Version(..) ) 34 | import Data.Proxy 35 | import Data.Tagged 36 | import Control.Applicative 37 | import Control.Monad 38 | import Data.Functor 39 | import Data.List 40 | import System.Exit 41 | import System.IO 42 | import Control.Concurrent.MVar 43 | import Control.Concurrent 44 | import System.IO.Error 45 | import GHC.IO.Exception ( ioException, IOErrorType(..), IOException(..) ) 46 | import Foreign.C 47 | import System.Process.Internals 48 | import Data.IORef 49 | import qualified Data.List.Split as Split 50 | import qualified System.Process as Process 51 | import qualified Data.Char as Char 52 | import Text.Read ( readMaybe ) 53 | import Data.Text ( Text ) 54 | 55 | -- import System.Process hiding ( cwd ) 56 | 57 | import Data.Maybe ( maybeToList ) 58 | 59 | import qualified Filesystem.Path.CurrentOS as Path 60 | 61 | import Development.Iridium.Types 62 | import Development.Iridium.Utils 63 | import Development.Iridium.UI.Console 64 | import Development.Iridium.UI.Prompt 65 | import Development.Iridium.CheckState 66 | import Development.Iridium.Config 67 | 68 | 69 | 70 | -- readShellProcessWithExitCode 71 | -- :: String 72 | -- -> [String] 73 | -- -> IO (ExitCode, String, String) 74 | -- readShellProcessWithExitCode c ps = 75 | -- readCreateProcessWithExitCode 76 | -- (shell $ c ++ " " ++ intercalate " " (fmap show ps)) 77 | -- "" 78 | 79 | runCommandSuccess 80 | :: ( MonadIO m 81 | , MonadPlus m 82 | , MonadMultiState CheckState m 83 | , MonadMultiState LogState m 84 | ) 85 | => String 86 | -> [String] 87 | -> m () 88 | runCommandSuccess c ps = falseToMZero $ do 89 | let infoStr = c ++ " " ++ intercalate " " ps 90 | pushLog LogLevelInfo $ infoStr 91 | withStack infoStr $ do 92 | outListRef <- liftIO $ newIORef [] 93 | exitCode <- withStack "" $ do -- the additional stack elem is for 94 | -- output display stuff. 95 | -- this is evil, because we discard states down there. 96 | -- but .. the alternative is somewhat complex ( to do right ). 97 | s1 :: LogState <- mGet 98 | s2 :: CheckState <- mGet 99 | 100 | let handleLine l = runMultiStateTNil 101 | $ MultiState.withMultiStateA s1 102 | $ MultiState.withMultiStateA s2 103 | $ do 104 | liftIO $ atomicModifyIORef outListRef (\x -> (l:x, ())) 105 | replaceStackTop l 106 | 107 | liftIO $ observeCreateProcessWithExitCode 108 | (Process.shell $ c ++ " " ++ intercalate " " (fmap show ps)) 109 | "" 110 | handleLine 111 | handleLine 112 | 113 | 114 | case exitCode of 115 | ExitSuccess -> do 116 | return True 117 | ExitFailure _ -> do 118 | pushLog LogLevelPrint infoStr 119 | outLines <- liftIO $ readIORef outListRef 120 | reverse outLines `forM_` pushLog LogLevelPrint 121 | logStack 122 | return False 123 | 124 | runCommandSuccessCabal 125 | :: ( MonadIO m 126 | , MonadPlus m 127 | , MonadMultiState CheckState m 128 | , MonadMultiState LogState m 129 | , MonadMultiReader Config m 130 | ) 131 | => [String] 132 | -> m () 133 | runCommandSuccessCabal ps = do 134 | cabalInvoc <- configReadStringWithDefaultM "cabal" ["setup", "cabal-command"] 135 | runCommandSuccess cabalInvoc ps 136 | 137 | runCommandSuccessHLint 138 | :: ( MonadIO m 139 | , MonadPlus m 140 | , MonadMultiState CheckState m 141 | , MonadMultiState LogState m 142 | , MonadMultiReader Config m 143 | ) 144 | => [String] 145 | -> m () 146 | runCommandSuccessHLint ps = do 147 | hlintInvoc <- configReadStringWithDefaultM "hlint" ["setup", "hlint-command"] 148 | runCommandSuccess hlintInvoc ps 149 | 150 | runCommandStdOut 151 | :: (MonadIO m, MonadPlus m, MonadMultiState LogState m) 152 | => String 153 | -> [String] 154 | -> m String 155 | runCommandStdOut c ps = do 156 | let infoStr = c ++ " " ++ intercalate " " ps 157 | (exitCode, stdOut, _stdErr) <- liftIO $ Turtle.procStrictWithErr 158 | (Text.pack c) 159 | (Text.pack `fmap` ps) 160 | Control.Applicative.empty 161 | case exitCode of 162 | ExitFailure _ -> do 163 | pushLog LogLevelError $ "Error running command `" ++ infoStr ++ "`." 164 | mzero 165 | ExitSuccess -> do 166 | return (Text.unpack stdOut) 167 | 168 | getExternalProgramVersion 169 | :: (MonadIO m, MonadPlus m, MonadMultiState LogState m) => String -> m [Int] 170 | getExternalProgramVersion prog = do 171 | let err = do 172 | pushLog LogLevelError 173 | $ "Could not determine version of external program " 174 | ++ prog 175 | mzero 176 | (exitCode, stdOut, _stdErr) <- liftIO $ Turtle.procStrictWithErr 177 | (Text.pack prog) 178 | [Text.pack "--version"] 179 | Control.Applicative.empty 180 | case exitCode of 181 | ExitSuccess -> do 182 | case lines (Text.unpack stdOut) of 183 | (line:_) -> 184 | case 185 | takeWhile (`elem`".0123456789") 186 | $ dropWhile (not . Char.isNumber) line 187 | of 188 | "" -> err 189 | s -> do 190 | pushLog LogLevelInfoVerbose 191 | $ "detected " 192 | ++ prog 193 | ++ " version " 194 | ++ s 195 | case mapM readMaybe $ Split.splitOn "." s of 196 | Just vs -> return vs 197 | Nothing -> err 198 | _ -> err 199 | ExitFailure _ -> err 200 | 201 | observeCreateProcessWithExitCode 202 | :: CreateProcess 203 | -> String -- ^ standard input 204 | -> (String -> IO ()) -- ^ stdout line handler 205 | -> (String -> IO ()) -- ^ stderr line handler 206 | -> IO (ExitCode) -- ^ exitcode 207 | observeCreateProcessWithExitCode cp input stdoutHandler stderrHandler = do 208 | let cp_opts = cp { 209 | std_in = CreatePipe, 210 | std_out = CreatePipe, 211 | std_err = CreatePipe 212 | } 213 | withCreateProcess_ "observeCreateProcessWithExitCode" cp_opts $ 214 | \(Just inh) (Just outh) (Just errh) ph -> do 215 | 216 | let processStream :: Handle -> (String -> IO ()) -> IO () 217 | processStream h f = do 218 | catchIOError (forever $ hGetLine h >>= f) (\e -> unless (isEOFError e) (ioError e)) 219 | 220 | -- fork off threads to start consuming stdout & stderr 221 | withForkWait (processStream outh stdoutHandler) $ \waitOut -> 222 | withForkWait (processStream errh stderrHandler) $ \waitErr -> do 223 | 224 | -- now write any input 225 | unless (null input) $ 226 | ignoreSigPipe $ hPutStr inh input 227 | -- hClose performs implicit hFlush, and thus may trigger a SIGPIPE 228 | ignoreSigPipe $ hClose inh 229 | 230 | -- wait on the output 231 | waitOut 232 | waitErr 233 | 234 | -- hClose outh 235 | -- hClose errh 236 | 237 | -- wait on the process 238 | ex <- Process.waitForProcess ph 239 | 240 | return ex 241 | 242 | -- *********** 243 | -- copied from System.Process, because not exposed.. 244 | withForkWait :: IO () -> (IO () -> IO a) -> IO a 245 | withForkWait async body = do 246 | waitVar <- newEmptyMVar :: IO (MVar (Either C.SomeException ())) 247 | C.mask $ \restore -> do 248 | tid <- forkIO $ C.try (restore async) >>= putMVar waitVar 249 | let wait = takeMVar waitVar >>= either C.throwIO return 250 | restore (body wait) `C.onException` killThread tid 251 | withCreateProcess_ 252 | :: String 253 | -> CreateProcess 254 | -> (Maybe Handle -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a) 255 | -> IO a 256 | withCreateProcess_ fun c action = 257 | C.bracketOnError (createProcess_ fun c) cleanupProcess 258 | (\(m_in, m_out, m_err, ph) -> action m_in m_out m_err ph) 259 | ignoreSigPipe :: IO () -> IO () 260 | ignoreSigPipe = C.handle $ \e -> case e of 261 | IOError { ioe_type = ResourceVanished 262 | , ioe_errno = Just ioe } 263 | | Errno ioe == ePIPE -> return () 264 | _ -> C.throwIO e 265 | 266 | cleanupProcess :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) 267 | -> IO () 268 | cleanupProcess (mb_stdin, mb_stdout, mb_stderr, 269 | ph@(ProcessHandle _ delegating_ctlc)) = do 270 | Process.terminateProcess ph 271 | -- Note, it's important that other threads that might be reading/writing 272 | -- these handles also get killed off, since otherwise they might be holding 273 | -- the handle lock and prevent us from closing, leading to deadlock. 274 | maybe (return ()) (ignoreSigPipe . hClose) mb_stdin 275 | maybe (return ()) hClose mb_stdout 276 | maybe (return ()) hClose mb_stderr 277 | -- terminateProcess does not guarantee that it terminates the process. 278 | -- Indeed on Unix it's SIGTERM, which asks nicely but does not guarantee 279 | -- that it stops. If it doesn't stop, we don't want to hang, so we wait 280 | -- asynchronously using forkIO. 281 | 282 | -- However we want to end the Ctl-C handling synchronously, so we'll do 283 | -- that synchronously, and set delegating_ctlc as False for the 284 | -- waitForProcess (which would otherwise end the Ctl-C delegation itself). 285 | when delegating_ctlc 286 | stopDelegateControlC 287 | _ <- forkIO (Process.waitForProcess (resetCtlcDelegation ph) >> return ()) 288 | return () 289 | where 290 | resetCtlcDelegation (ProcessHandle m _) = ProcessHandle m False 291 | -- *********** 292 | -------------------------------------------------------------------------------- /src/Development/Iridium/Hackage.hs: -------------------------------------------------------------------------------- 1 | module Development.Iridium.Hackage 2 | ( retrieveLatestVersion 3 | , uploadPackage 4 | , uploadDocs 5 | ) 6 | where 7 | 8 | 9 | 10 | import Control.Monad.IO.Class 11 | import Control.Monad.Trans.Maybe 12 | import Control.Monad ( mzero, when ) 13 | import Data.Maybe ( listToMaybe, maybeToList ) 14 | import Control.Monad.Trans.MultiRWS 15 | import Control.Monad 16 | import Control.Exception 17 | import Data.Version 18 | import Distribution.Package ( PackageName(..) ) 19 | import qualified Turtle as Turtle 20 | import System.Exit 21 | 22 | import qualified Network.HTTP as HTTP 23 | import qualified Network.URI as URI 24 | import qualified Data.Text as Text 25 | import qualified Data.Aeson as Aeson 26 | import qualified Data.HashMap.Strict as HM 27 | import qualified Text.ParserCombinators.ReadP as ReadP 28 | import Data.List (find) 29 | 30 | import System.Process hiding ( cwd ) 31 | 32 | import Development.Iridium.UI.Console 33 | import Development.Iridium.Types 34 | import Development.Iridium.Config 35 | import Development.Iridium.Utils 36 | 37 | import qualified Data.ByteString as ByteString 38 | import qualified Data.ByteString.Lazy as ByteStringL 39 | 40 | 41 | 42 | retrieveLatestVersion 43 | :: ( MonadIO m 44 | , MonadMultiState LogState m 45 | , MonadPlus m 46 | ) 47 | => String -> String -> m (Maybe Version) 48 | retrieveLatestVersion remoteUrl pkgName = do 49 | let urlStr :: String = remoteUrl ++ "/package/" ++ pkgName ++ "/preferred" 50 | pushLog LogLevelInfo $ "Looking up latest version from hackage via url " ++ urlStr 51 | 52 | uri <- case URI.parseURI urlStr of 53 | Nothing -> do 54 | pushLog LogLevelError "bad URI" 55 | mzero 56 | Just u -> return u 57 | let request = HTTP.insertHeader HTTP.HdrAccept "application/json" 58 | $ HTTP.mkRequest HTTP.GET uri 59 | 60 | rawHtmlE <- liftIO $ HTTP.simpleHTTP request 61 | let parseError = do 62 | pushLog LogLevelError "Could not decode hackage response." 63 | mzero 64 | case rawHtmlE of 65 | Left{} -> return Nothing 66 | Right r -> case Aeson.decode $ HTTP.rspBody r of 67 | Just m -> case HM.lookup (Text.pack "normal-version") m of 68 | Nothing -> parseError 69 | Just [] -> pure Nothing 70 | Just (vs :: [String]) -> do 71 | let v :: Version = maximum $ parseVersionF <$> vs 72 | pure $ Just v 73 | Nothing -> parseError 74 | where 75 | parseVersionF s = case find (null . snd) $ ReadP.readP_to_S parseVersion s of 76 | Nothing -> error "parseVersionF" 77 | Just (v, _) -> v 78 | 79 | 80 | uploadPackage 81 | :: forall m 82 | . ( MonadIO m 83 | , MonadPlus m 84 | , MonadMultiReader Config m 85 | , MonadMultiReader Infos m 86 | , MonadMultiState LogState m 87 | ) 88 | => m () 89 | uploadPackage = do 90 | buildtool <- configReadStringM ["setup", "buildtool"] 91 | pushLog LogLevelPrint "Performing upload.." 92 | case buildtool of 93 | "cabal" -> do 94 | (PackageName pname) <- askPackageName 95 | pvers <- askPackageVersion 96 | username <- configReadStringMaybeM ["setup", "hackage", "username"] 97 | password <- configReadStringMaybeM ["setup", "hackage", "password"] 98 | 99 | let filePath = "dist/" ++ pname ++ "-" ++ showVersion pvers ++ ".tar.gz" 100 | mzeroIfNonzero $ liftIO $ 101 | runProcess "cabal" ["sdist"] Nothing Nothing Nothing Nothing Nothing 102 | >>= waitForProcess 103 | mzeroIfNonzero $ liftIO $ 104 | runProcess "cabal" 105 | ( [ "upload" 106 | , "--publish" 107 | , filePath 108 | ] 109 | ++ ["-u" ++ u | u <- maybeToList username] 110 | ++ ["-p" ++ p | p <- maybeToList password] 111 | ) 112 | Nothing Nothing Nothing Nothing Nothing 113 | >>= waitForProcess 114 | pushLog LogLevelPrint "Upload successful." 115 | "cabal-new" -> do 116 | (PackageName pname) <- askPackageName 117 | pvers <- askPackageVersion 118 | username <- configReadStringMaybeM ["setup", "hackage", "username"] 119 | password <- configReadStringMaybeM ["setup", "hackage", "password"] 120 | 121 | let filePath = "dist/" ++ pname ++ "-" ++ showVersion pvers ++ ".tar.gz" 122 | mzeroIfNonzero $ liftIO $ 123 | runProcess "cabal" ["sdist"] Nothing Nothing Nothing Nothing Nothing 124 | >>= waitForProcess 125 | mzeroIfNonzero $ liftIO $ 126 | runProcess "cabal" 127 | ( [ "upload" 128 | , "--publish" 129 | , filePath 130 | ] 131 | ++ ["-u" ++ u | u <- maybeToList username] 132 | ++ ["-p" ++ p | p <- maybeToList password] 133 | ) 134 | Nothing Nothing Nothing Nothing Nothing 135 | >>= waitForProcess 136 | pushLog LogLevelPrint "Upload successful." 137 | "stack" -> do 138 | pushLog LogLevelError "TODO: stack upload" 139 | mzero 140 | _ -> mzero 141 | 142 | uploadDocs 143 | :: forall m 144 | . ( MonadIO m 145 | , MonadPlus m 146 | , MonadMultiReader Config m 147 | , MonadMultiState LogState m 148 | ) 149 | => m () 150 | uploadDocs = do 151 | buildtool <- configReadStringM ["setup", "buildtool"] 152 | pushLog LogLevelPrint "Performing doc upload.." 153 | case buildtool of 154 | "cabal" -> do 155 | username <- configReadStringMaybeM ["setup", "hackage", "username"] 156 | password <- configReadStringMaybeM ["setup", "hackage", "password"] 157 | infoVerbEnabled <- isEnabledLogLevel LogLevelInfoVerbose 158 | mzeroIfNonzero $ liftIO $ 159 | runProcess "cabal" 160 | ( [ "upload" 161 | , "--doc" 162 | , "--publish" 163 | ] 164 | ++ ["-u" ++ u | u <- maybeToList username] 165 | ++ ["-p" ++ p | p <- maybeToList password] 166 | ++ ["-v0" | not infoVerbEnabled] 167 | ) 168 | Nothing Nothing Nothing Nothing Nothing 169 | >>= waitForProcess 170 | pushLog LogLevelPrint "Documentation upload successful." 171 | "stack" -> do 172 | pushLog LogLevelError "TODO: stack upload" 173 | mzero 174 | _ -> error "uploadDocs not supported in cabal-new" 175 | -------------------------------------------------------------------------------- /src/Development/Iridium/Repo/Git.hs: -------------------------------------------------------------------------------- 1 | module Development.Iridium.Repo.Git 2 | ( GitImpl 3 | ) 4 | where 5 | 6 | 7 | 8 | import Control.Monad (when, mzero, liftM, MonadPlus) 9 | import Control.Monad.Trans.Maybe 10 | import Control.Monad.Trans.Class 11 | import Control.Monad.IO.Class 12 | import Control.Monad.Trans.MultiRWS 13 | import Control.Monad.Extra ( whenM ) 14 | import Data.List.Extra 15 | import Data.Version 16 | import System.Process hiding ( cwd ) 17 | import Data.Char 18 | import Data.Foldable (forM_) 19 | 20 | import Development.Iridium.Types 21 | import Development.Iridium.Utils 22 | import Development.Iridium.ExternalProgWrappers 23 | import Development.Iridium.UI.Console 24 | import Development.Iridium.Config 25 | import Development.Iridium.CheckState 26 | 27 | 28 | 29 | data GitImpl = GitImpl 30 | { _git_branchName :: String 31 | } 32 | 33 | instance Repo GitImpl where 34 | repo_retrieveInfo = do 35 | branchStringRaw <- runCommandStdOut "git" ["branch"] 36 | let branchNamePred ('*':' ':branchName) = Just branchName 37 | branchNamePred _ = Nothing 38 | case firstJust branchNamePred $ lines branchStringRaw of 39 | Nothing -> do 40 | pushLog LogLevelError "Could not parse current git branch name." 41 | mzero 42 | Just branchName -> 43 | return $ GitImpl $ branchName 44 | repo_runChecks _git = withStack "[git]" $ do 45 | pushLog LogLevelPrint "[git]" 46 | withIndentation $ do 47 | uncommittedChangesCheck 48 | repo_displaySummary git = do 49 | pushLog LogLevelPrint $ "[git]" 50 | withIndentation $ do 51 | whenM (configIsTrueM ["repository", "git", "display-current-branch"]) $ 52 | pushLog LogLevelPrint $ "Branch: " ++ _git_branchName git 53 | repo_ActionSummary _git = do 54 | tagEnabled <- configIsEnabledM ["repository", "git", "release-tag"] 55 | tagAction <- if tagEnabled 56 | then do 57 | tagStr <- askTagString 58 | return $ ["Tag the current commit with \"" ++ tagStr ++ "\""] 59 | else 60 | return [] 61 | pushEnabled <- configIsEnabledM ["repository", "git", "push-remote"] 62 | return $ tagAction 63 | ++ ["Push current branch and tag to upstream repo" | pushEnabled] 64 | repo_performAction git = do 65 | tagEnabled <- configIsEnabledM ["repository", "git", "release-tag"] 66 | tagStringMaybe <- if tagEnabled then liftM Just askTagString else return Nothing 67 | tagStringMaybe `forM_` \tagStr -> do 68 | pushLog LogLevelPrint "[git] Tagging this release." 69 | withIndentation $ do 70 | curOut <- runCommandStdOut "git" ["tag", "-l", tagStr] 71 | pushLog LogLevelDebug curOut 72 | if all isSpace curOut 73 | then do 74 | mzeroIfNonzero $ liftIO $ 75 | runProcess "git" 76 | ( [ "tag" 77 | , tagStr 78 | ] 79 | ) 80 | Nothing Nothing Nothing Nothing Nothing 81 | >>= waitForProcess 82 | pushLog LogLevelPrint $ "Tagged as " ++ tagStr 83 | else pushLog LogLevelPrint "Tag already exists, leaving it as-is." 84 | pushEnabled <- configIsEnabledM ["repository", "git", "push-remote"] 85 | when pushEnabled $ do 86 | pushLog LogLevelPrint "[git] Pushing to remote." 87 | withIndentation $ do 88 | remote <- configReadStringWithDefaultM "origin" ["repository", "git", "push-remote", "remote-name"] 89 | mzeroIfNonzero $ liftIO $ 90 | runProcess "git" 91 | ( [ "push" 92 | , remote 93 | , _git_branchName git 94 | ] ++ maybe [] return tagStringMaybe 95 | ) 96 | Nothing Nothing Nothing Nothing Nothing 97 | >>= waitForProcess 98 | return () 99 | 100 | askTagString 101 | :: ( MonadMultiReader Config m 102 | , MonadMultiReader Infos m 103 | ) 104 | => m String 105 | askTagString = do 106 | tagRawStr <- configReadStringWithDefaultM "$VERSION" ["repository", "git", "release-tag", "content"] 107 | vers <- liftM showVersion askPackageVersion 108 | return $ replace "$VERSION" vers tagRawStr 109 | 110 | 111 | uncommittedChangesCheck 112 | :: ( MonadIO m 113 | , MonadPlus m 114 | , MonadMultiState CheckState m 115 | , MonadMultiState LogState m 116 | ) 117 | => m () 118 | uncommittedChangesCheck = boolToWarning 119 | $ runCheck "Testing for uncommitted changes" 120 | $ withStack "git status -uno" 121 | $ do 122 | changesRaw <- runCommandStdOut "git" ["status", "-uno", "--porcelain"] 123 | let changes = lines changesRaw 124 | if null changes 125 | then 126 | return True 127 | else do 128 | pushLog LogLevelPrint $ "git status reports uncommitted changes:" 129 | withIndentation $ changes `forM_` pushLog LogLevelPrint 130 | return False 131 | -------------------------------------------------------------------------------- /src/Development/Iridium/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | {-# LANGUAGE ExistentialQuantification #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE UndecidableInstances #-} 7 | 8 | module Development.Iridium.Types 9 | ( Infos (..) 10 | , Repo (..) 11 | , NoRepo (..) 12 | , LogLevel (..) 13 | , LogState (..) 14 | , Config 15 | , repoRunChecks 16 | , repoDisplaySummary 17 | , repoActionSummary 18 | , repoPerformAction 19 | , CheckState (..) 20 | ) 21 | where 22 | 23 | 24 | import Prelude hiding ( FilePath ) 25 | 26 | import qualified Data.Yaml as Yaml 27 | import Control.Monad.Trans.MultiRWS 28 | import Control.Monad.Trans.MultiState 29 | import Control.Monad.Trans.Maybe 30 | import Control.Monad.Trans.Class 31 | import Data.HList.HList 32 | import Control.Monad.IO.Class 33 | import Distribution.PackageDescription 34 | import Data.Version ( Version(..) ) 35 | import Data.Proxy 36 | import Data.Tagged 37 | import Control.Applicative 38 | import Control.Monad 39 | import Data.HList.ContainsType 40 | import Control.Monad.Trans.Control 41 | import Control.Monad.Base 42 | 43 | import qualified Filesystem.Path.CurrentOS as Path 44 | 45 | 46 | 47 | data LogLevel = LogLevelSilent 48 | | LogLevelPrint -- like manual output; should never be filtered 49 | | LogLevelDebug 50 | | LogLevelTrace 51 | | LogLevelWarn 52 | | LogLevelError 53 | | LogLevelInfo 54 | | LogLevelInfoVerbose 55 | | LogLevelInfoVerboser 56 | | LogLevelInfoSpam 57 | | LogLevelThread 58 | deriving (Show, Eq) 59 | 60 | data LogState = LogState 61 | { _log_mask :: [LogLevel] 62 | , _log_indent :: Int 63 | , _log_prepared :: Maybe String 64 | , _log_cur :: String 65 | } 66 | 67 | type Config = Yaml.Value 68 | 69 | data Infos = forall repo . Repo repo => Infos 70 | { _i_cwd :: Path.FilePath 71 | , _i_package :: GenericPackageDescription 72 | , _i_remote_version :: Maybe Version 73 | , _i_repo :: repo 74 | } 75 | 76 | data CheckState = CheckState 77 | { _check_stack :: [String] 78 | , _check_errorCount :: Int 79 | , _check_warningCount :: Int 80 | , _check_notWallClean :: [String] 81 | } 82 | 83 | class Repo a where 84 | -- | the action to retrieve/collect all the 85 | -- data relevant for the later steps. 86 | repo_retrieveInfo :: ( MonadIO m 87 | , MonadPlus m 88 | , MonadMultiReader Config m 89 | , MonadMultiState LogState m 90 | ) 91 | => m a 92 | -- | The checks to be run for this repo type 93 | repo_runChecks :: ( MonadIO m 94 | , MonadPlus m 95 | , MonadMultiReader Config m 96 | , MonadMultiState LogState m 97 | , MonadMultiState CheckState m 98 | ) 99 | => a -> m () 100 | -- | Summary of repository-type-specific information 101 | -- to display to the user, e.g. "current branch: .." 102 | repo_displaySummary :: ( MonadIO m 103 | , MonadMultiReader Config m 104 | , MonadMultiState LogState m 105 | ) 106 | => a -> m () 107 | -- | (Configured) (repository-type-specific) actions 108 | -- that will be taken, e.g. "Tag the current commit" 109 | repo_ActionSummary :: ( MonadMultiReader Config m 110 | , MonadMultiReader Infos m 111 | , MonadMultiState LogState m 112 | ) 113 | => a -> m [String] 114 | -- | Perform repository-type-specific real side-effects. 115 | -- This is post-confirmation by the user, but before 116 | -- doing hackage upload. 117 | repo_performAction :: ( MonadIO m 118 | , MonadPlus m 119 | , MonadMultiReader Config m 120 | , MonadMultiReader Infos m 121 | , MonadMultiState LogState m 122 | ) 123 | => a -> m () 124 | 125 | repoRunChecks 126 | :: ( MonadIO m 127 | , MonadPlus m 128 | , MonadMultiReader Infos m 129 | , MonadMultiReader Config m 130 | , MonadMultiState LogState m 131 | , MonadMultiState CheckState m 132 | ) 133 | => m () 134 | repoRunChecks = do 135 | Infos _ _ _ repo <- mAsk 136 | repo_runChecks repo 137 | 138 | repoDisplaySummary 139 | :: ( MonadIO m 140 | , MonadMultiReader Infos m 141 | , MonadMultiReader Config m 142 | , MonadMultiState LogState m 143 | ) 144 | => m () 145 | repoDisplaySummary = do 146 | Infos _ _ _ repo <- mAsk 147 | repo_displaySummary repo 148 | 149 | repoActionSummary 150 | :: ( MonadIO m 151 | , MonadMultiReader Infos m 152 | , MonadMultiReader Config m 153 | , MonadMultiState LogState m 154 | ) 155 | => m [String] 156 | repoActionSummary = do 157 | Infos _ _ _ repo <- mAsk 158 | repo_ActionSummary repo 159 | 160 | repoPerformAction 161 | :: ( MonadIO m 162 | , MonadPlus m 163 | , MonadMultiReader Infos m 164 | , MonadMultiReader Config m 165 | , MonadMultiState LogState m 166 | ) 167 | => m () 168 | repoPerformAction = do 169 | Infos _ _ _ repo <- mAsk 170 | repo_performAction repo 171 | 172 | -- witnessProxy :: Tagged a b -> (Proxy a -> r) -> r 173 | -- witnessProxy _ f = f Proxy 174 | 175 | data NoRepo = NoRepo 176 | 177 | instance Repo NoRepo where 178 | repo_retrieveInfo = return $ NoRepo 179 | repo_runChecks _ = return () 180 | repo_displaySummary _ = return () 181 | repo_ActionSummary _ = return [] 182 | repo_performAction _ = return () 183 | -------------------------------------------------------------------------------- /src/Development/Iridium/UI/Console.hs: -------------------------------------------------------------------------------- 1 | module Development.Iridium.UI.Console 2 | ( LogLevel (..) 3 | , setLogMask 4 | , pushLog 5 | , pushLogPrepare 6 | , pushLogFinalize 7 | , writeCurLine 8 | , pushCurLine 9 | , LogState 10 | , initialLogState 11 | , withIndentation 12 | , withoutIndentation 13 | , isEnabledLogLevel 14 | ) 15 | where 16 | 17 | 18 | 19 | import Data.IORef 20 | import Control.Monad 21 | import Control.Monad.IO.Class 22 | 23 | import Control.Monad.Trans.MultiRWS 24 | 25 | import System.Console.ANSI 26 | import System.IO 27 | 28 | import Development.Iridium.Types 29 | 30 | 31 | 32 | initialLogState :: LogState 33 | initialLogState = LogState 34 | [ LogLevelPrint 35 | , LogLevelWarn 36 | , LogLevelError 37 | , LogLevelInfo 38 | ] 39 | 0 40 | Nothing 41 | "" 42 | 43 | -- only logmessages that are _in_ the list in this IORef are printed. 44 | -- {-# NOINLINE currentLogMask #-} 45 | -- currentLogMask :: IORef [LogLevel] 46 | -- currentLogMask 47 | -- = Unsafe.performIO 48 | -- $ newIORef 49 | -- $ [ LogLevelPrint 50 | -- , LogLevelWarn 51 | -- , LogLevelError 52 | -- , LogLevelInfo 53 | -- ] 54 | 55 | -- setLogMask :: MonadIO io => [LogLevel] -> io () 56 | -- setLogMask = liftIO . writeIORef currentLogMask 57 | 58 | -- putLog :: MonadIO io => LogLevel -> String -> io () 59 | -- putLog level message = liftIO $ do 60 | -- mask <- readIORef currentLogMask 61 | -- when (level `elem` mask) $ 62 | -- putStrLn message 63 | 64 | setLogMask 65 | :: ( MonadMultiState LogState m ) 66 | => [LogLevel] 67 | -> m () 68 | setLogMask levels = do 69 | s <- mGet 70 | mSet $ s { _log_mask = levels } 71 | 72 | withIndentation 73 | :: MonadMultiState LogState m 74 | => m a 75 | -> m a 76 | withIndentation k = do 77 | s <- mGet 78 | mSet $ s { _log_indent = _log_indent s + 1 } 79 | r <- k 80 | s2 <- mGet 81 | mSet $ s2 { _log_indent = _log_indent s } 82 | return r 83 | 84 | withoutIndentation 85 | :: MonadMultiState LogState m 86 | => m a 87 | -> m a 88 | withoutIndentation k = do 89 | s <- mGet 90 | mSet $ s { _log_indent = 0 } 91 | r <- k 92 | mSet s -- we do a full reset here. this might be evil. 93 | -- but probably just the right thing to do. 94 | return r 95 | 96 | checkWhenLevel 97 | :: ( MonadMultiState LogState m ) 98 | => LogLevel 99 | -> m () 100 | -> m () 101 | checkWhenLevel level m = do 102 | s <- mGet 103 | when (level `elem` _log_mask s) m 104 | 105 | getIndentLine 106 | :: ( MonadMultiState LogState m ) 107 | => String 108 | -> m String 109 | getIndentLine str = do 110 | s <- mGet 111 | return $ replicate (2*_log_indent s) ' ' ++ str 112 | 113 | flushPrepared 114 | :: ( MonadIO m 115 | , MonadMultiState LogState m 116 | ) 117 | => m () 118 | flushPrepared = do 119 | s <- mGet 120 | liftIO $ clearLine >> setCursorColumn 0 >> hFlush stdout 121 | case _log_prepared s of 122 | Nothing -> return () 123 | Just x -> do 124 | liftIO $ putStrLn x 125 | mSet $ s { _log_prepared = Nothing } 126 | 127 | pushLog 128 | :: ( MonadMultiState LogState m 129 | , MonadIO m 130 | ) 131 | => LogLevel 132 | -> String 133 | -> m () 134 | pushLog level message = checkWhenLevel level $ do 135 | flushPrepared 136 | forM_ (lines message) $ 137 | (liftIO . putStrLn =<<) . getIndentLine 138 | 139 | pushLogPrepare 140 | :: ( MonadMultiState LogState m 141 | , MonadIO m 142 | ) 143 | => String 144 | -> m () 145 | pushLogPrepare message = do 146 | s <- mGet 147 | flushPrepared 148 | mess <- getIndentLine message 149 | mSet $ s { _log_prepared = Just mess } 150 | 151 | pushLogFinalize 152 | :: ( MonadMultiState LogState m 153 | , MonadIO m 154 | ) 155 | => Int 156 | -> String 157 | -> m () 158 | pushLogFinalize indent message = do 159 | s <- mGet 160 | liftIO $ clearLine >> setCursorColumn 0 >> hFlush stdout 161 | case _log_prepared s of 162 | Nothing -> do 163 | liftIO $ putStrLn $ replicate indent ' ' ++ message 164 | Just x -> do 165 | liftIO $ if length x > indent 166 | then do 167 | putStrLn x 168 | putStrLn $ replicate indent ' ' ++ message 169 | else do 170 | putStrLn $ x ++ replicate (indent - length x) ' ' ++ message 171 | mSet $ s { _log_prepared = Nothing } 172 | 173 | writeCurLine 174 | :: ( MonadMultiState LogState m 175 | , MonadIO m 176 | ) 177 | => String 178 | -> m () 179 | writeCurLine message = do 180 | liftIO $ clearLine >> setCursorColumn 0 181 | s <- mGet 182 | imess <- getIndentLine message 183 | liftIO $ putStr $ "> " ++ imess 184 | liftIO $ hFlush stdout 185 | mSet $ s { _log_cur = imess } 186 | 187 | pushCurLine 188 | :: ( MonadMultiState LogState m 189 | , MonadIO m 190 | ) 191 | => LogLevel 192 | -> m () 193 | pushCurLine level = do 194 | s <- mGet 195 | if level `elem` _log_mask s 196 | then liftIO $ putStrLn "" 197 | else liftIO $ clearLine >> setCursorColumn 0 >> hFlush stdout 198 | mSet $ s { _log_cur = "" } 199 | 200 | isEnabledLogLevel 201 | :: ( MonadMultiState LogState m ) 202 | => LogLevel 203 | -> m Bool 204 | isEnabledLogLevel level = do 205 | s <- mGet 206 | return $ level `elem` _log_mask s 207 | 208 | -- putLog 209 | -- :: ( MonadMultiState LogState m 210 | -- , MonadIO m 211 | -- ) 212 | -- => LogLevel 213 | -- -> String 214 | -- -> m () 215 | -- putLog level message = do 216 | -- LogState mask i <- mGet 217 | -- liftIO $ when (level `elem` mask) $ 218 | -- putStrLn $ replicate (2*i) ' ' ++ message 219 | 220 | -------------------------------------------------------------------------------- /src/Development/Iridium/UI/Prompt.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | 3 | module Development.Iridium.UI.Prompt 4 | ( askConfirmationOrMZero 5 | , promptYesOrNo 6 | , promptSpecific 7 | ) 8 | where 9 | 10 | 11 | 12 | import qualified Data.Text as Text 13 | import qualified Turtle as Turtle 14 | import qualified Control.Foldl as Foldl 15 | 16 | import Data.Text ( Text ) 17 | import Control.Monad.Trans.Maybe 18 | import Control.Monad.Trans.Class 19 | import Control.Monad.IO.Class 20 | import Control.Monad 21 | 22 | import Development.Iridium.Types 23 | import Development.Iridium.UI.Console 24 | import Development.Iridium.Config 25 | 26 | import Control.Monad.Trans.MultiRWS 27 | 28 | import System.Process 29 | import System.IO ( hFlush, stdout ) 30 | import Control.Concurrent ( threadDelay ) 31 | 32 | 33 | 34 | askConfirmationOrMZero 35 | :: ( MonadIO m 36 | , MonadPlus m 37 | , MonadMultiState LogState m 38 | ) 39 | => m () 40 | askConfirmationOrMZero = do 41 | liftIO $ putStr "> Abort imminent; enter 'i' to overwrite and continue> " 42 | liftIO $ hFlush stdout 43 | s <- liftIO $ getLine 44 | case s of 45 | "i" -> do 46 | pushLog LogLevelPrint " (Remember that you can disable individual tests in iridium.yaml)" 47 | liftIO $ threadDelay 1000000 48 | return () 49 | _ -> mzero 50 | 51 | promptYesOrNo 52 | :: (MonadIO m, MonadPlus m) 53 | => String 54 | -> m () 55 | promptYesOrNo p = do 56 | liftIO $ putStr $ "> " ++ p ++ "> " 57 | liftIO $ hFlush stdout 58 | s <- liftIO $ getLine 59 | case s of 60 | "y" -> do 61 | return () 62 | "n" -> mzero 63 | _ -> promptYesOrNo p 64 | 65 | promptSpecific 66 | :: (MonadIO m, MonadPlus m) 67 | => String 68 | -> String 69 | -> m () 70 | promptSpecific p cont = do 71 | liftIO $ putStr $ "> " ++ p ++ "> " 72 | liftIO $ hFlush stdout 73 | s <- liftIO $ getLine 74 | if s == cont then return () else mzero 75 | -------------------------------------------------------------------------------- /src/Development/Iridium/Utils.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | {-# LANGUAGE ExistentialQuantification #-} 5 | 6 | module Development.Iridium.Utils 7 | ( askAllBuildInfo 8 | , askPackageName 9 | , askPackageVersion 10 | , createDefaultCompilerFlag 11 | , mzeroToFalse 12 | , falseToMZero 13 | , runCheck 14 | , fallbackCheck 15 | -- , falseToConfirm 16 | , falseToAbort 17 | , ignoreBool 18 | , boolToWarning 19 | , boolToError 20 | , getLocalFilePath 21 | , mzeroIfNonzero 22 | ) 23 | where 24 | 25 | 26 | import Prelude hiding ( FilePath ) 27 | 28 | import qualified Data.Text as Text 29 | import qualified Turtle as Turtle 30 | import qualified Control.Foldl as Foldl 31 | import qualified Control.Exception as C 32 | 33 | import qualified Data.Yaml as Yaml 34 | import Control.Monad.Trans.MultiRWS 35 | import Control.Monad.Trans.MultiState as MultiState 36 | import Control.Monad.Trans.Maybe 37 | import Control.Monad.Trans.Class 38 | import Control.Monad.IO.Class 39 | import Distribution.PackageDescription 40 | import Distribution.Package 41 | import Filesystem.Path.CurrentOS hiding ( null ) 42 | import Data.Version ( Version(..) ) 43 | import Data.Proxy 44 | import Data.Tagged 45 | import Control.Applicative 46 | import Control.Monad 47 | import Data.Functor 48 | import Data.List 49 | import System.Exit 50 | import System.IO 51 | import Control.Concurrent.MVar 52 | import Control.Concurrent 53 | import System.IO.Error 54 | import GHC.IO.Exception ( ioException, IOErrorType(..), IOException(..) ) 55 | import Foreign.C 56 | import System.Process.Internals 57 | import Data.IORef 58 | import qualified Data.List.Split as Split 59 | import qualified System.Process as Process 60 | import qualified Data.Char as Char 61 | import Text.Read ( readMaybe ) 62 | 63 | -- well, no Turtle, apparently. 64 | -- no way to retrieve stdout, stderr and exitcode. 65 | -- the most generic case, not supported? psshhh. 66 | import System.Process hiding ( cwd ) 67 | 68 | import Data.Maybe ( maybeToList ) 69 | 70 | import qualified Filesystem.Path.CurrentOS as Path 71 | 72 | import Development.Iridium.Types 73 | import Development.Iridium.UI.Console 74 | import Development.Iridium.UI.Prompt 75 | import Development.Iridium.CheckState 76 | import Development.Iridium.Config 77 | 78 | 79 | 80 | runCheck 81 | :: ( MonadIO m 82 | , MonadMultiState LogState m 83 | ) 84 | => String 85 | -> m Bool 86 | -> m Bool 87 | runCheck s m = do 88 | pushLogPrepare $ s ++ ":" 89 | writeCurLine $ s ++ ":" 90 | r <- withIndentation m 91 | if r 92 | then do 93 | pushLogFinalize 70 "clear." 94 | return True 95 | else do 96 | pushLogFinalize 70 "failed." 97 | pushLog LogLevelPrint $ "(Latest: " ++ s ++ ")" 98 | return False 99 | 100 | askAllBuildInfo :: (MonadMultiReader Infos m) => m [BuildInfo] 101 | askAllBuildInfo = do 102 | Infos _ pDesc _ _ <- mAsk 103 | return $ (libBuildInfo . condTreeData <$> maybeToList (condLibrary pDesc)) 104 | ++ (buildInfo . condTreeData . snd <$> condExecutables pDesc) 105 | ++ (testBuildInfo . condTreeData . snd <$> condTestSuites pDesc) 106 | ++ (benchmarkBuildInfo . condTreeData . snd <$> condBenchmarks pDesc) 107 | 108 | askPackageName :: MonadMultiReader Infos m => m PackageName 109 | askPackageName = do 110 | Infos _ pDesc _ _ <- mAsk 111 | return $ pkgName $ package $ packageDescription pDesc 112 | 113 | askPackageVersion :: MonadMultiReader Infos m => m Version 114 | askPackageVersion = do 115 | Infos _ pDesc _ _ <- mAsk 116 | return $ pkgVersion $ package $ packageDescription pDesc 117 | 118 | createDefaultCompilerFlag :: MonadMultiReader Config m => m [String] 119 | createDefaultCompilerFlag = liftM maybeToList $ runMaybeT $ do 120 | comp <- MaybeT $ configReadStringMaybeM ["setup", "default-compiler"] 121 | let confList = ["setup", "compiler-paths", comp] 122 | compilerPath <- MaybeT $ configReadStringMaybeM confList 123 | return $ "-w" ++ compilerPath 124 | 125 | mzeroToFalse :: Monad m => MaybeT m a -> m Bool 126 | mzeroToFalse m = do 127 | x <- runMaybeT m 128 | case x of 129 | Nothing -> return False 130 | Just _ -> return True 131 | 132 | falseToMZero :: MonadPlus m => m Bool -> m () 133 | falseToMZero m = m >>= guard 134 | 135 | -- mzeroToFalse :: MonadPlus m => m a -> m Bool 136 | -- mzeroToFalse m = liftM (const True) m `mplus` return False 137 | 138 | -- falseToConfirm 139 | -- :: (MonadMultiState LogState m, MonadPlus m, MonadIO m) => m Bool -> m Bool 140 | -- falseToConfirm m = m >>= \x -> if x 141 | -- then return True 142 | -- else askConfirmationOrMZero >> return False 143 | 144 | falseToAbort :: MonadPlus m => m Bool -> m Bool 145 | falseToAbort m = m >>= guard >> return True 146 | 147 | fallbackCheck :: Monad m => m Bool -> m Bool -> m Bool 148 | fallbackCheck m1 m2 = do 149 | x <- m1 150 | if x 151 | then return True 152 | else m2 153 | 154 | mzeroIfNonzero 155 | :: ( MonadPlus m ) 156 | => m ExitCode 157 | -> m () 158 | mzeroIfNonzero k = do 159 | r <- k 160 | case r of 161 | ExitSuccess -> return () 162 | ExitFailure _ -> mzero 163 | 164 | ignoreBool :: Monad m => m Bool -> m () 165 | ignoreBool = liftM (const ()) 166 | 167 | boolToWarning 168 | :: ( MonadMultiState CheckState m ) 169 | => m Bool 170 | -> m () 171 | boolToWarning m = do 172 | b <- m 173 | unless b incWarningCounter 174 | 175 | 176 | boolToError 177 | :: ( MonadMultiState CheckState m ) 178 | => m Bool 179 | -> m () 180 | boolToError m = do 181 | b <- m 182 | unless b incErrorCounter 183 | 184 | 185 | getLocalFilePath 186 | :: ( MonadMultiReader Infos m ) 187 | => String 188 | -> m Turtle.FilePath 189 | getLocalFilePath s = do 190 | infos <- mAsk 191 | return $ _i_cwd infos decodeString s 192 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # For more information, see: https://github.com/commercialhaskell/stack/blob/release/doc/yaml_configuration.md 2 | 3 | # Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2) 4 | resolver: lts-6.30 5 | 6 | # Local packages, usually specified by relative directory name 7 | packages: 8 | - '.' 9 | 10 | # Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3) 11 | extra-deps: [multistate-0.7.1.1, unsafe-0.0, turtle-1.3.1, optparse-applicative-0.13.1.0] 12 | 13 | # Override default flag values for local packages and extra-deps 14 | flags: {} 15 | 16 | # Extra package databases containing global packages 17 | extra-package-dbs: [] 18 | 19 | # Control whether we use the GHC we find on the path 20 | # system-ghc: true 21 | 22 | # Require a specific version of stack, using version ranges 23 | # require-stack-version: -any # Default 24 | # require-stack-version: >= 0.1.10.0 25 | 26 | # Override the architecture used by stack, especially useful on Windows 27 | # arch: i386 28 | # arch: x86_64 29 | 30 | # Extra directories used by stack for building 31 | # extra-include-dirs: [/path/to/dir] 32 | # extra-lib-dirs: [/path/to/dir] 33 | --------------------------------------------------------------------------------