├── .ghci ├── .gitattributes ├── .github └── workflows │ ├── build.yml │ └── publish.yml ├── .gitignore ├── CHANGELOG.md ├── LICENSE ├── README.md ├── Setup.lhs ├── cabal.project ├── driver └── Main.hs ├── get-hpack.sh ├── hie.yaml ├── hpack.cabal ├── package.yaml ├── resources └── test │ └── hpack.cabal ├── src ├── Data │ └── Aeson │ │ └── Config │ │ ├── FromValue.hs │ │ ├── Key.hs │ │ ├── KeyMap.hs │ │ ├── Parser.hs │ │ ├── Types.hs │ │ └── Util.hs ├── Hpack.hs ├── Hpack │ ├── CabalFile.hs │ ├── Config.hs │ ├── Defaults.hs │ ├── Error.hs │ ├── Haskell.hs │ ├── License.hs │ ├── Module.hs │ ├── Options.hs │ ├── Render.hs │ ├── Render │ │ ├── Dsl.hs │ │ └── Hints.hs │ ├── Syntax │ │ ├── BuildTools.hs │ │ ├── Defaults.hs │ │ ├── Dependencies.hs │ │ ├── DependencyVersion.hs │ │ ├── Git.hs │ │ └── ParseDependencies.hs │ ├── Utf8.hs │ ├── Util.hs │ └── Yaml.hs ├── Imports.hs └── Path.hs ├── stack.yaml ├── stack.yaml.lock ├── test ├── Data │ └── Aeson │ │ └── Config │ │ ├── FromValueSpec.hs │ │ ├── TypesSpec.hs │ │ └── UtilSpec.hs ├── EndToEndSpec.hs ├── Helper.hs ├── Hpack │ ├── CabalFileSpec.hs │ ├── ConfigSpec.hs │ ├── DefaultsSpec.hs │ ├── HaskellSpec.hs │ ├── LicenseSpec.hs │ ├── ModuleSpec.hs │ ├── OptionsSpec.hs │ ├── Render │ │ ├── DslSpec.hs │ │ └── HintsSpec.hs │ ├── RenderSpec.hs │ ├── Syntax │ │ ├── BuildToolsSpec.hs │ │ ├── DefaultsSpec.hs │ │ ├── DependenciesSpec.hs │ │ └── GitSpec.hs │ ├── Utf8Spec.hs │ └── UtilSpec.hs ├── HpackSpec.hs ├── Spec.hs ├── SpecHook.hs └── fixtures │ └── vcr-tape.yaml └── util ├── gh-md-toc └── update-toc /.ghci: -------------------------------------------------------------------------------- 1 | :set -XHaskell2010 -Wredundant-constraints -fno-warn-incomplete-uni-patterns -DTEST -isrc -itest -i./dist-newstyle/build/x86_64-linux/ghc-9.10.1/hpack-0.37.0/build/autogen 2 | -------------------------------------------------------------------------------- /.gitattributes: -------------------------------------------------------------------------------- 1 | /*.cabal linguist-generated=true 2 | -------------------------------------------------------------------------------- /.github/workflows/build.yml: -------------------------------------------------------------------------------- 1 | name: build 2 | 3 | concurrency: 4 | group: ${{ github.workflow }}-${{ github.head_ref || github.run_id }} 5 | cancel-in-progress: true 6 | 7 | on: 8 | push: 9 | branches: 10 | - main 11 | pull_request: 12 | branches: 13 | - main 14 | schedule: 15 | - cron: 0 0 * * * 16 | 17 | jobs: 18 | build: 19 | name: ${{ matrix.os }} / GHC ${{ matrix.ghc }} 20 | runs-on: ${{ matrix.os }} 21 | 22 | strategy: 23 | fail-fast: true 24 | matrix: 25 | os: 26 | - ubuntu-latest 27 | ghc: 28 | - '9.2' 29 | - '9.4' 30 | - '9.6' 31 | - '9.8' 32 | - '9.10' 33 | - '9.12' 34 | include: 35 | - os: macos-latest 36 | ghc: '9.10' 37 | - os: windows-latest 38 | ghc: '9.10' 39 | steps: 40 | - uses: actions/checkout@v3 41 | - uses: hspec/setup-haskell@v1 42 | with: 43 | ghc-version: ${{ matrix.ghc }} 44 | - uses: sol/run-haskell-tests@v1 45 | with: 46 | caching: true 47 | 48 | success: 49 | needs: build 50 | runs-on: ubuntu-latest 51 | if: always() # this is required as GitHub considers "skipped" jobs as "passed" when checking branch protection rules 52 | 53 | steps: 54 | - run: false 55 | if: needs.build.result != 'success' 56 | 57 | - uses: actions/checkout@v3 58 | - name: Check for trailing whitespace 59 | run: '! git grep -I "\s\+$"' 60 | -------------------------------------------------------------------------------- /.github/workflows/publish.yml: -------------------------------------------------------------------------------- 1 | name: publish 2 | 3 | permissions: 4 | contents: write 5 | 6 | on: 7 | push: 8 | branches: 9 | - main 10 | 11 | jobs: 12 | publish: 13 | runs-on: ubuntu-latest 14 | steps: 15 | - uses: actions/checkout@v3 16 | 17 | - run: cabal check --ignore=missing-upper-bounds 18 | 19 | - uses: sol/haskell-autotag@v1 20 | id: autotag 21 | with: 22 | prefix: null 23 | 24 | - run: cabal sdist 25 | 26 | - uses: haskell-actions/hackage-publish@v1.1 27 | with: 28 | hackageToken: ${{ secrets.HACKAGE_AUTH_TOKEN }} 29 | publish: true 30 | if: steps.autotag.outputs.created 31 | 32 | - name: publish binaries 33 | run: | 34 | cabal update 35 | cabal build --disable-tests --disable-benchmarks --disable-documentation 36 | binary=hpack 37 | asset="${binary}_linux.gz" 38 | cat "$(cabal list-bin $binary)" | gzip > "$asset" 39 | gh release create ${{ steps.autotag.outputs.name }} --title ${{ steps.autotag.outputs.name }} --verify-tag "$asset" 40 | env: 41 | GH_TOKEN: ${{ github.token }} 42 | if: steps.autotag.outputs.created 43 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | /.stack-work/ 2 | /dist-newstyle/ 3 | /dist/ 4 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | ## Changes in 0.38.1 2 | - Add support for `extra-files` (see #603) 3 | - Preserve empty lines in `description` when `cabal-version >= 3` (see #612) 4 | 5 | ## Changes in 0.38.0 6 | - Generate `build-tool-depends` instead of `build-tools` starting with 7 | `cabal-version: 2` (fixes #596) 8 | 9 | ## Changes in 0.37.0 10 | - Add support for `asm-options` and `asm-sources` (see #573) 11 | 12 | ## Changes in 0.36.1 13 | - Allow `Cabal-3.12.*` 14 | - Support `base >= 4.20.0` (`Imports` does not re-export `Data.List.List`) 15 | 16 | ## Changes in 0.36.0 17 | - Don't infer `Paths_`-module with `spec-version: 0.36.0` or later 18 | 19 | ## Changes in 0.35.5 20 | - Add (undocumented) `list` command 21 | 22 | ## Changes in 0.35.4 23 | - Add `--canonical`, which can be used to produce canonical output instead of 24 | trying to produce minimal diffs 25 | - Avoid unnecessary writes on `--force` (see #555) 26 | - When an existing `.cabal` does not align fields then do not align fields in 27 | the generated `.cabal` file. 28 | - Fix a bug related to git conflict markers in existing `.cabal` files: When a 29 | `.cabal` file was essentially unchanged, but contained git conflict markers 30 | then `hpack` did not write a new `.cabal` file at all. To address this 31 | `hpack` now unconditionally writes a new `.cabal` file when the existing 32 | `.cabal` file contains any git conflict markers. 33 | 34 | ## Changes in 0.35.3 35 | - Depend on `crypton` instead of `cryptonite` 36 | 37 | ## Changes in 0.35.2 38 | - Add support for `ghc-shared-options` 39 | 40 | ## Changes in 0.35.1 41 | - Allow `Cabal-3.8.*` 42 | - Additions to internal API 43 | 44 | ## Changes in 0.35.0 45 | - Add support for `language` (thanks @mpilgrem) 46 | - Accept Cabal names for fields where Hpack and Cabal use different 47 | terminology, but still warn (e.g. accept `hs-source-dirs` as an alias for 48 | `source-dirs`) 49 | 50 | ## Changes in 0.34.7 51 | - Support `Cabal-3.6.*` 52 | - Make sure that verbatim `import` fields are rendered at the beginning of 53 | a section (see #486) 54 | 55 | ## Changes in 0.34.6 56 | - Add `Paths_` module to `autogen-modules` when `cabal-version >= 2` 57 | 58 | ## Changes in 0.34.5 59 | - Compatibility with `aeson-2.*` 60 | 61 | ## Changes in 0.34.4 62 | - Render `default-extensions` / `other-extensions` line-separated 63 | - Compatibility with `Cabal-3.4.0.0` 64 | 65 | ## Changes in 0.34.3 66 | - Ignore duplicate source directories (see #356) 67 | - Do not infer duplicate modules (see #408, #406, #353) 68 | - Reject empty `then` / `else` sections (see #362) 69 | - Omit conditionals that are always `false` from generated `.cabal` file 70 | (see #404) 71 | - Infer correct `cabal-version` when `Paths_` is used with `RebindableSyntax` 72 | and `OverloadedStrings` or `OverloadedLists` (see #400) 73 | - Do not use indentation from any existing `.cabal` file if it is invalid 74 | (e.g. `0`) (fixes #252) 75 | - Accept lists for `tested-with` (see #407) 76 | - Render current directory as `./` instead of `./.` for forward compatibility 77 | with future version of Cabal 78 | 79 | ## Changes in 0.34.2 80 | - Accept subcomponents as dependencies (close #382) 81 | 82 | ## Changes in 0.34.1 83 | - Fix a bug in `github: ...` introduced with `0.34.0` 84 | (f63eb19b956517b4dd8e28dc5785be5889a99298) 85 | 86 | ## Changes in 0.34.0 (deprecated) 87 | - Use `PreferNoHash` as default `GenerateHashStrategy` 88 | - Add support for library `visibility` (see #382) 89 | - Reject URLs for `github` 90 | 91 | ## Changes in 0.33.1 92 | - Add `GenerateHashStrategy`. The default is `PreferHash` for `0.33.0` and 93 | will change to `PreferNoHash` with `0.34.0`. See 94 | https://github.com/sol/hpack/pull/390) for details. 95 | 96 | - Add command-line options `--hash` and `--no-hash` 97 | 98 | ## Changes in 0.33.0.1 99 | - Silently ignore missing hash when the cabal file content didn't change at 100 | all (for forward compatibility with #390) 101 | 102 | ## Changes in 0.33.0 103 | - Support GHC 8.8.1: `fail` is no longer a part of `Monad`. Instead, it lives 104 | in the `MonadFail` class. Adapting our code to this change meant changing 105 | the types of exporting functions, unfortunately, hence the major version 106 | bump. 107 | 108 | ## Changes in 0.32.0 109 | - Support Cabal 3.0 110 | - Switch reexported-modules to comma-separated list 111 | 112 | ## Changes in 0.31.2 113 | - Add default value for maintainer (see #339) 114 | - Escape commas and spaces in filenames when generating cabal files 115 | 116 | ## Changes in 0.31.1 117 | - Show the header when printing to stdout (see #331) 118 | - Add help for `--numeric-version`(see #337) 119 | 120 | ## Changes in 0.31.0 121 | - Add `mixin` to the fields read by dependencies when they are 122 | objects (see #318) 123 | - `hpack` now returns with a successful exit code if the `.cabal` 124 | file is up to date, even if it was generated by a newer version of 125 | `hpack`. 126 | 127 | ## Changes in 0.30.0 128 | - Warn on duplicate fields (see #283) 129 | - Always render `cabal-version` as `x.y` instead of `>= x.y` so that `cabal 130 | check` does not complain (see #322) 131 | - Extend `build-tools` so that it subsumes Cabal's `build-tools` and 132 | `build-tool-depends` (see #254) 133 | - Add support for `system-build-tools` 134 | - Keep declaration order for literal files in c-sources (and other fields 135 | that accept glob patterns). This is crucial as a workaround for 136 | https://ghc.haskell.org/trac/ghc/ticket/13786 (see #324) 137 | 138 | ## Changes in 0.29.7 139 | - Expose more stuff from `Hpack.Yaml` so that it can be used by third parties 140 | 141 | ## Changes in 0.29.6 142 | - Add `spec-version` (see #300) 143 | 144 | ## Changes in 0.29.5 145 | - Fix a regression related to indentation sniffing (close #310) 146 | 147 | ## Changes in 0.29.4 148 | - Desugar ^>= when dependency is a string (see #309) 149 | - Add support for Apache, MPL and ISC when inferring `license` (see #305) 150 | 151 | ## Changes in 0.29.3 152 | - Desugar `^>=` for compatibility with `Cabal < 2` (see #213) 153 | - Add support for GPL, LGPL and AGPL when inferring `license` (see #305) 154 | 155 | ## Changes in 0.29.2 156 | - Add missing `extra-source-files` (see #302) 157 | 158 | ## Changes in 0.29.1 159 | - Infer `license` from `license-file` 160 | 161 | ## Changes in 0.29.0 162 | - Put the `cabal-version` at the beginning of the generated file. This Is 163 | required with `cabal-version: 2.1` and higher. (see #292) 164 | - With `cabal-version: 2.1` or higher omit `>=` when rendering (see #292) 165 | - Require `cabal-version: 2.2` when SPDX license identifiers are used (see #292) 166 | - Map cabal-style licenses to SPDX license identifiers when `cabal-version` 167 | is 2.2 or higher (see #292) 168 | 169 | ## Changes in 0.28.2 170 | - Exit with `exitFailure` on `AlreadyGeneratedByNewerHpack` or 171 | `ExistingCabalFileWasModifiedManually` in `Hpack.printResult` 172 | 173 | ## Changes in 0.28.1 174 | - GHC 8.4.1 compatibility 175 | 176 | ## Changes in 0.28.0 177 | - Add support for `cxx-options` and `cxx-sources` (see #205) 178 | - Add support for `data-dir` (see #100) 179 | - Generate valid `.cabal` files when `verbatim` is used top-level (see #280) 180 | 181 | ## Changes in 0.27.0 182 | - Local defaults are now resolved relative to the file they are 183 | mentioned in, not the CWD that hpack is invoked from. 184 | 185 | ## Changes in 0.26.0 186 | - Major refactoring of the exposed API (much cleaner now, but lot's of 187 | breaking changes!) 188 | - Remove Git conflict markers before checking the hash of any existing 189 | `.cabal` files (equivalent to `git checkout --ours`). This allows to 190 | regenerate the `.cabal` file on conflicts when rebasing without passing 191 | `-f` in some cases and helps with preserving the formatting. 192 | - Allow local files to be used as defaults (#248) 193 | 194 | ## Changes in 0.25.0 195 | - Keep non-existing literal files on glob expansion (see #101) 196 | 197 | ## Changes in 0.24.0 198 | - Add support for `verbatim` Cabal escape hatch 199 | - Allow `version` be a numbers 200 | - Ignore fields that start with an underscore everywhere, not just globally 201 | 202 | ## Changes in 0.23.0 203 | - Add support for custom decoders to allow for alternate syntax (e.g. Dhall) 204 | - `generated-exposed-modules` and `generated-other-modules`, for populating 205 | the `autogen-modules` field (#207). 206 | - Corrected `cabal-version` setting for `reexported-modules` inside 207 | a conditional. 208 | 209 | ## Changes in 0.22.0 210 | - Add support for `defaults` 211 | - Add `--numeric-version` 212 | - Add support for `signatures` 213 | - `extra-doc-files` requires setting `cabal-version` to at least 214 | 1.18; this is now done properly. 215 | - Accept bool for `condition` (see #230) 216 | 217 | ## Changes in 0.21.2 218 | - Fix a bug in module inference for conditionals (see #236) 219 | - Add support for `extra-doc-files`. 220 | - Add support for `pkg-config-dependencies` 221 | 222 | ## Changes in 0.21.1 223 | - Allow dependency constraints to be numbers (see #234) 224 | 225 | ## Changes in 0.21.0 226 | - Accept section-specific fields in conditionals (see #175, thanks to Scott 227 | Fleischman) 228 | - New section: `internal-libraries`, for Cabal 2's internal libraries (see #200). 229 | 230 | ## Changes in 0.20.0 231 | - Do not overwrite any existing cabal file if it has been modified manually 232 | 233 | ## Changes in 0.19.3 234 | - Add support for `frameworks` and `extra-frameworks-dirs` 235 | 236 | ## Changes in 0.19.2 237 | - Compatibility with `Glob >= 0.9.0` 238 | 239 | ## Changes in 0.19.1 240 | - Add `IsList` instance for `Dependencies` 241 | 242 | ## Changes in 0.19.0 243 | - Add Paths_* module to executables (see #195, for GHC 8.2.1 compatibility) 244 | - Allow specifying dependencies as a hash (see #198) 245 | 246 | ## Changes in 0.18.1 247 | - Output generated cabal file to `stdout` when `-` is given as a command-line 248 | option (see #113) 249 | - Recognize `.chs`, `.y`, `.ly` and `.x` as Haskell modules when inferring 250 | modules for 251 | 252 | ## Changes in 0.18.0 253 | - Make `executable` a shortcut of `executables: { package-name: ... }` 254 | - Add support for `ghcjs-options` and `js-sources` (see #161) 255 | - Allow `license-file` to be a list 256 | - Accept input file on command-line (see #106) 257 | - Add Paths_* when no modules are specified (see #86) 258 | 259 | ## Changes in 0.17.1 260 | - Do not descend into irrelevant directories when inferring modules (see #165) 261 | 262 | ## Changes in 0.17.0 263 | - Added custom-setup section 264 | - Add support for `!include` directives 265 | 266 | ## Changes in 0.16.0 267 | - Warn when `name` is missing 268 | - Support globs in `c-sources` 269 | - Use binary I/O for cabal files avoiding problems with non-UTF-8 locales 270 | - Fix rendering of `.` as directory (cabal syntax issue) 271 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2014-2025 Simon Hengel 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining a copy 4 | of this software and associated documentation files (the "Software"), to deal 5 | in the Software without restriction, including without limitation the rights 6 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 7 | copies of the Software, and to permit persons to whom the Software is 8 | furnished to do so, subject to the following conditions: 9 | 10 | The above copyright notice and this permission notice shall be included in 11 | all copies or substantial portions of the Software. 12 | 13 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 14 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 15 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 16 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 17 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 18 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 19 | THE SOFTWARE. 20 | -------------------------------------------------------------------------------- /Setup.lhs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env runhaskell 2 | > import Distribution.Simple 3 | > main = defaultMain 4 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: 2 | hpack.cabal 3 | 4 | package hpack 5 | ghc-options: -Werror 6 | 7 | tests: True 8 | -------------------------------------------------------------------------------- /driver/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | module Main (main) where 3 | 4 | import System.Environment 5 | 6 | import qualified Hpack 7 | import Hpack.Config 8 | import Control.Exception 9 | 10 | main :: IO () 11 | main = getArgs >>= \ case 12 | ["list"] -> exposedModules packageConfig >>= mapM_ (putStrLn . unModule) 13 | args -> Hpack.getOptions packageConfig args >>= mapM_ (uncurry Hpack.hpack) 14 | 15 | exposedModules :: FilePath -> IO [Module] 16 | exposedModules file = readPackageConfig defaultDecodeOptions {decodeOptionsTarget = file} >>= \ case 17 | Left err -> throwIO $ ErrorCall err 18 | Right result -> return $ modules result 19 | where 20 | modules :: DecodeResult -> [Module] 21 | modules = maybe [] (libraryExposedModules . sectionData) . packageLibrary . decodeResultPackage 22 | -------------------------------------------------------------------------------- /get-hpack.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | set -o nounset 3 | set -o errexit 4 | 5 | dst="$HOME/.local/bin" 6 | hpack="$dst/hpack" 7 | 8 | mkdir -p "$dst" 9 | 10 | os="${1:-${TRAVIS_OS_NAME:-linux}}" 11 | url=$(curl -sSL https://api.github.com/repos/sol/hpack/releases/latest | jq -r ".assets[] | select(.name | test(\"$os\")) | .browser_download_url") 12 | 13 | echo "Downloading $url" 14 | 15 | curl -sSL "$url" | gunzip > "$hpack.tmp" 16 | chmod +x "$hpack.tmp" 17 | mv "$hpack.tmp" "$hpack" 18 | 19 | echo "Installed hpack to $hpack" 20 | -------------------------------------------------------------------------------- /hie.yaml: -------------------------------------------------------------------------------- 1 | cradle: 2 | cabal: 3 | component: hpack:test:spec 4 | -------------------------------------------------------------------------------- /hpack.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.0 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.38.0. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | 7 | name: hpack 8 | version: 0.38.1 9 | synopsis: A modern format for Haskell packages 10 | description: See README at 11 | category: Development 12 | homepage: https://github.com/sol/hpack#readme 13 | bug-reports: https://github.com/sol/hpack/issues 14 | author: Simon Hengel 15 | maintainer: Simon Hengel 16 | license: MIT 17 | license-file: LICENSE 18 | build-type: Simple 19 | extra-source-files: 20 | CHANGELOG.md 21 | resources/test/hpack.cabal 22 | 23 | source-repository head 24 | type: git 25 | location: https://github.com/sol/hpack 26 | 27 | library 28 | exposed-modules: 29 | Hpack 30 | Hpack.Config 31 | Hpack.Render 32 | Hpack.Yaml 33 | Hpack.Error 34 | other-modules: 35 | Data.Aeson.Config.FromValue 36 | Data.Aeson.Config.Key 37 | Data.Aeson.Config.KeyMap 38 | Data.Aeson.Config.Parser 39 | Data.Aeson.Config.Types 40 | Data.Aeson.Config.Util 41 | Hpack.CabalFile 42 | Hpack.Defaults 43 | Hpack.Haskell 44 | Hpack.License 45 | Hpack.Module 46 | Hpack.Options 47 | Hpack.Render.Dsl 48 | Hpack.Render.Hints 49 | Hpack.Syntax.BuildTools 50 | Hpack.Syntax.Defaults 51 | Hpack.Syntax.Dependencies 52 | Hpack.Syntax.DependencyVersion 53 | Hpack.Syntax.Git 54 | Hpack.Syntax.ParseDependencies 55 | Hpack.Utf8 56 | Hpack.Util 57 | Imports 58 | Path 59 | Paths_hpack 60 | autogen-modules: 61 | Paths_hpack 62 | hs-source-dirs: 63 | src 64 | ghc-options: -Wall -fno-warn-incomplete-uni-patterns 65 | build-depends: 66 | Cabal >=3.0.0.0 && <3.15 67 | , Glob >=0.9.0 68 | , aeson >=1.4.3.0 69 | , base >=4.13 && <5 70 | , bifunctors 71 | , bytestring 72 | , containers 73 | , crypton 74 | , deepseq 75 | , directory >=1.2.5.0 76 | , filepath 77 | , http-client 78 | , http-client-tls >=0.3.6.2 79 | , http-types 80 | , infer-license >=0.2.0 && <0.3 81 | , mtl 82 | , pretty 83 | , scientific 84 | , text 85 | , transformers 86 | , unordered-containers 87 | , vector 88 | , yaml >=0.10.0 89 | default-language: Haskell2010 90 | if impl(ghc >= 9.4.5) && os(windows) 91 | build-depends: 92 | network >=3.1.2.9 93 | 94 | executable hpack 95 | main-is: Main.hs 96 | hs-source-dirs: 97 | driver 98 | ghc-options: -Wall -fno-warn-incomplete-uni-patterns 99 | build-depends: 100 | Cabal >=3.0.0.0 && <3.15 101 | , Glob >=0.9.0 102 | , aeson >=1.4.3.0 103 | , base >=4.13 && <5 104 | , bifunctors 105 | , bytestring 106 | , containers 107 | , crypton 108 | , deepseq 109 | , directory >=1.2.5.0 110 | , filepath 111 | , hpack 112 | , http-client 113 | , http-client-tls >=0.3.6.2 114 | , http-types 115 | , infer-license >=0.2.0 && <0.3 116 | , mtl 117 | , pretty 118 | , scientific 119 | , text 120 | , transformers 121 | , unordered-containers 122 | , vector 123 | , yaml >=0.10.0 124 | default-language: Haskell2010 125 | if impl(ghc >= 9.4.5) && os(windows) 126 | build-depends: 127 | network >=3.1.2.9 128 | 129 | test-suite spec 130 | type: exitcode-stdio-1.0 131 | main-is: Spec.hs 132 | other-modules: 133 | Data.Aeson.Config.FromValueSpec 134 | Data.Aeson.Config.TypesSpec 135 | Data.Aeson.Config.UtilSpec 136 | EndToEndSpec 137 | Helper 138 | Hpack.CabalFileSpec 139 | Hpack.ConfigSpec 140 | Hpack.DefaultsSpec 141 | Hpack.HaskellSpec 142 | Hpack.LicenseSpec 143 | Hpack.ModuleSpec 144 | Hpack.OptionsSpec 145 | Hpack.Render.DslSpec 146 | Hpack.Render.HintsSpec 147 | Hpack.RenderSpec 148 | Hpack.Syntax.BuildToolsSpec 149 | Hpack.Syntax.DefaultsSpec 150 | Hpack.Syntax.DependenciesSpec 151 | Hpack.Syntax.GitSpec 152 | Hpack.Utf8Spec 153 | Hpack.UtilSpec 154 | HpackSpec 155 | SpecHook 156 | Data.Aeson.Config.FromValue 157 | Data.Aeson.Config.Key 158 | Data.Aeson.Config.KeyMap 159 | Data.Aeson.Config.Parser 160 | Data.Aeson.Config.Types 161 | Data.Aeson.Config.Util 162 | Hpack 163 | Hpack.CabalFile 164 | Hpack.Config 165 | Hpack.Defaults 166 | Hpack.Error 167 | Hpack.Haskell 168 | Hpack.License 169 | Hpack.Module 170 | Hpack.Options 171 | Hpack.Render 172 | Hpack.Render.Dsl 173 | Hpack.Render.Hints 174 | Hpack.Syntax.BuildTools 175 | Hpack.Syntax.Defaults 176 | Hpack.Syntax.Dependencies 177 | Hpack.Syntax.DependencyVersion 178 | Hpack.Syntax.Git 179 | Hpack.Syntax.ParseDependencies 180 | Hpack.Utf8 181 | Hpack.Util 182 | Hpack.Yaml 183 | Imports 184 | Path 185 | Paths_hpack 186 | autogen-modules: 187 | Paths_hpack 188 | hs-source-dirs: 189 | test 190 | src 191 | ghc-options: -Wall -fno-warn-incomplete-uni-patterns 192 | cpp-options: -DTEST 193 | build-tool-depends: 194 | hspec-discover:hspec-discover 195 | build-depends: 196 | Cabal >=3.0.0.0 && <3.15 197 | , Glob >=0.9.0 198 | , HUnit >=1.6.0.0 199 | , QuickCheck 200 | , aeson >=1.4.3.0 201 | , base >=4.13 && <5 202 | , bifunctors 203 | , bytestring 204 | , containers 205 | , crypton 206 | , deepseq 207 | , directory >=1.2.5.0 208 | , filepath 209 | , hspec ==2.* 210 | , http-client 211 | , http-client-tls >=0.3.6.2 212 | , http-types 213 | , infer-license >=0.2.0 && <0.3 214 | , interpolate 215 | , mockery >=0.3 216 | , mtl 217 | , pretty 218 | , scientific 219 | , template-haskell 220 | , temporary 221 | , text 222 | , transformers 223 | , unordered-containers 224 | , vcr 225 | , vector 226 | , yaml >=0.10.0 227 | default-language: Haskell2010 228 | if impl(ghc >= 9.4.5) && os(windows) 229 | build-depends: 230 | network >=3.1.2.9 231 | -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | spec-version: 0.36.0 2 | name: hpack 3 | version: 0.38.1 4 | synopsis: A modern format for Haskell packages 5 | description: See README at 6 | author: Simon Hengel 7 | maintainer: Simon Hengel 8 | github: sol/hpack 9 | category: Development 10 | extra-source-files: 11 | - CHANGELOG.md 12 | - resources/**/* 13 | 14 | ghc-options: -Wall -fno-warn-incomplete-uni-patterns 15 | 16 | dependencies: 17 | - base >= 4.13 && < 5 18 | - bytestring 19 | - deepseq 20 | - directory >= 1.2.5.0 21 | - filepath 22 | - Glob >= 0.9.0 23 | - text 24 | - containers 25 | - unordered-containers 26 | - yaml >= 0.10.0 27 | - aeson >= 1.4.3.0 28 | - scientific 29 | - Cabal >= 3.0.0.0 && < 3.15 30 | - pretty 31 | - bifunctors 32 | - crypton 33 | - transformers 34 | - mtl 35 | - http-types 36 | - http-client 37 | - http-client-tls >= 0.3.6.2 38 | - vector 39 | - infer-license >= 0.2.0 && < 0.3 40 | 41 | # See https://github.com/haskell/network/pull/552. 42 | when: 43 | condition: impl(ghc >= 9.4.5) && os(windows) 44 | dependencies: network >= 3.1.2.9 45 | 46 | library: 47 | source-dirs: src 48 | exposed-modules: 49 | - Hpack 50 | - Hpack.Config 51 | - Hpack.Render 52 | - Hpack.Yaml 53 | - Hpack.Error 54 | generated-other-modules: Paths_hpack 55 | 56 | executable: 57 | main: Main.hs 58 | source-dirs: driver 59 | dependencies: 60 | - hpack 61 | 62 | tests: 63 | spec: 64 | cpp-options: -DTEST 65 | main: Spec.hs 66 | source-dirs: 67 | - test 68 | - src 69 | generated-other-modules: Paths_hpack 70 | dependencies: 71 | - hspec == 2.* 72 | - vcr 73 | - QuickCheck 74 | - temporary 75 | - mockery >= 0.3 76 | - interpolate 77 | - template-haskell 78 | - HUnit >= 1.6.0.0 79 | build-tools: hspec-discover 80 | -------------------------------------------------------------------------------- /resources/test/hpack.cabal: -------------------------------------------------------------------------------- 1 | ../../hpack.cabal -------------------------------------------------------------------------------- /src/Data/Aeson/Config/FromValue.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DefaultSignatures #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | {-# LANGUAGE TypeOperators #-} 7 | {-# LANGUAGE StandaloneDeriving #-} 8 | {-# LANGUAGE RecordWildCards #-} 9 | {-# LANGUAGE ConstraintKinds #-} 10 | {-# LANGUAGE DataKinds #-} 11 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 12 | {-# LANGUAGE TypeApplications #-} 13 | {-# LANGUAGE DeriveFunctor #-} 14 | module Data.Aeson.Config.FromValue ( 15 | FromValue(..) 16 | , Parser 17 | , Result 18 | , decodeValue 19 | 20 | , Generic 21 | , GenericDecode 22 | , genericFromValue 23 | , Options(..) 24 | , genericFromValueWith 25 | 26 | , typeMismatch 27 | , withObject 28 | , withText 29 | , withString 30 | , withArray 31 | , withNumber 32 | , withBool 33 | 34 | , parseArray 35 | , traverseObject 36 | 37 | , (.:) 38 | , (.:?) 39 | 40 | , Key 41 | , Value(..) 42 | , Object 43 | , Array 44 | 45 | , Alias(..) 46 | , unAlias 47 | ) where 48 | 49 | import Imports 50 | 51 | import Data.Monoid (Last(..)) 52 | import GHC.Generics 53 | import GHC.TypeLits 54 | import Data.Proxy 55 | 56 | import Data.Map.Lazy (Map) 57 | import qualified Data.Map.Lazy as Map 58 | import qualified Data.Vector as V 59 | import Data.Aeson.Config.Key (Key) 60 | import qualified Data.Aeson.Config.Key as Key 61 | import Data.Aeson.Config.KeyMap (member) 62 | import qualified Data.Aeson.Config.KeyMap as KeyMap 63 | 64 | import Data.Aeson.Types (FromJSON(..)) 65 | 66 | import Data.Aeson.Config.Util 67 | import Data.Aeson.Config.Parser 68 | 69 | type Result a = Either String (a, [String], [(String, String)]) 70 | 71 | decodeValue :: FromValue a => Value -> Result a 72 | decodeValue = runParser fromValue 73 | 74 | (.:) :: FromValue a => Object -> Key -> Parser a 75 | (.:) = explicitParseField fromValue 76 | 77 | (.:?) :: FromValue a => Object -> Key -> Parser (Maybe a) 78 | (.:?) = explicitParseFieldMaybe fromValue 79 | 80 | class FromValue a where 81 | fromValue :: Value -> Parser a 82 | default fromValue :: forall d m. (Generic a, Rep a ~ D1 d m, Datatype d, GenericDecode (Rep a)) => Value -> Parser a 83 | fromValue = genericFromValue 84 | 85 | genericFromValue :: forall a d m. (Generic a, Rep a ~ D1 d m, Datatype d, GenericDecode (Rep a)) => Value -> Parser a 86 | genericFromValue = genericFromValueWith (Options $ hyphenize name) 87 | where 88 | name :: String 89 | name = datatypeName (undefined :: D1 d m p) 90 | 91 | instance FromValue Bool where 92 | fromValue = liftParser . parseJSON 93 | 94 | instance FromValue Int where 95 | fromValue = liftParser . parseJSON 96 | 97 | instance FromValue Text where 98 | fromValue = liftParser . parseJSON 99 | 100 | instance {-# OVERLAPPING #-} FromValue String where 101 | fromValue = liftParser . parseJSON 102 | 103 | instance FromValue a => FromValue (Maybe a) where 104 | fromValue value = liftParser (parseJSON value) >>= traverse fromValue 105 | 106 | instance FromValue a => FromValue [a] where 107 | fromValue = withArray (parseArray fromValue) 108 | 109 | parseArray :: (Value -> Parser a) -> Array -> Parser [a] 110 | parseArray f = zipWithM (parseIndexed f) [0..] . V.toList 111 | where 112 | parseIndexed :: (Value -> Parser a) -> Int -> Value -> Parser a 113 | parseIndexed p n value = p value Index n 114 | 115 | instance FromValue a => FromValue (Map String a) where 116 | fromValue = withObject $ \ o -> do 117 | xs <- traverseObject fromValue o 118 | return $ Map.fromList (map (first Key.toString) xs) 119 | 120 | traverseObject :: (Value -> Parser a) -> Object -> Parser [(Key, a)] 121 | traverseObject f o = do 122 | forM (KeyMap.toList o) $ \ (name, value) -> 123 | (,) name <$> f value Key name 124 | 125 | instance (FromValue a, FromValue b) => FromValue (a, b) where 126 | fromValue v = (,) <$> fromValue v <*> fromValue v 127 | 128 | instance (FromValue a, FromValue b) => FromValue (Either a b) where 129 | fromValue v = Left <$> fromValue v <|> Right <$> fromValue v 130 | 131 | data Options = Options { 132 | optionsRecordSelectorModifier :: String -> String 133 | } 134 | 135 | genericFromValueWith :: (Generic a, GenericDecode (Rep a)) => Options -> Value -> Parser a 136 | genericFromValueWith opts = fmap to . genericDecode opts 137 | 138 | class GenericDecode f where 139 | genericDecode :: Options -> Value -> Parser (f p) 140 | 141 | instance (GenericDecode a) => GenericDecode (D1 d a) where 142 | genericDecode opts = fmap M1 . genericDecode opts 143 | 144 | instance (GenericDecode a) => GenericDecode (C1 c a) where 145 | genericDecode opts = fmap M1 . genericDecode opts 146 | 147 | instance (GenericDecode a, GenericDecode b) => GenericDecode (a :*: b) where 148 | genericDecode opts o = (:*:) <$> genericDecode opts o <*> genericDecode opts o 149 | 150 | type RecordField sel a = S1 sel (Rec0 a) 151 | 152 | instance (Selector sel, FromValue a) => GenericDecode (RecordField sel a) where 153 | genericDecode = accessFieldWith (.:) 154 | 155 | instance {-# OVERLAPPING #-} (Selector sel, FromValue a) => GenericDecode (RecordField sel (Maybe a)) where 156 | genericDecode = accessFieldWith (.:?) 157 | 158 | instance {-# OVERLAPPING #-} (Selector sel, FromValue a) => GenericDecode (RecordField sel (Last a)) where 159 | genericDecode = accessFieldWith (\ value key -> Last <$> (value .:? key)) 160 | 161 | instance {-# OVERLAPPING #-} (Selector sel, FromValue a, KnownBool deprecated, KnownSymbol alias) => GenericDecode (RecordField sel (Alias deprecated alias (Maybe a))) where 162 | genericDecode = accessFieldWith (\ value key -> aliasAccess (.:?) value (Alias key)) 163 | 164 | instance {-# OVERLAPPING #-} (Selector sel, FromValue a, KnownBool deprecated, KnownSymbol alias) => GenericDecode (RecordField sel (Alias deprecated alias (Last a))) where 165 | genericDecode = accessFieldWith (\ value key -> fmap Last <$> aliasAccess (.:?) value (Alias key)) 166 | 167 | aliasAccess :: forall deprecated alias a. (KnownBool deprecated, KnownSymbol alias) => (Object -> Key -> Parser a) -> Object -> (Alias deprecated alias Key) -> Parser (Alias deprecated alias a) 168 | aliasAccess op value (Alias key) 169 | | alias `member` value && not (key `member` value) = Alias <$> value `op` alias <* deprecated 170 | | otherwise = Alias <$> value `op` key 171 | where 172 | deprecated = case boolVal (Proxy @deprecated) of 173 | False -> return () 174 | True -> markDeprecated alias key 175 | alias = Key.fromString (symbolVal $ Proxy @alias) 176 | 177 | accessFieldWith :: forall sel a p. Selector sel => (Object -> Key -> Parser a) -> Options -> Value -> Parser (RecordField sel a p) 178 | accessFieldWith op Options{..} v = M1 . K1 <$> withObject (`op` Key.fromString label) v 179 | where 180 | label = optionsRecordSelectorModifier $ selName (undefined :: RecordField sel a p) 181 | 182 | newtype Alias (deprecated :: Bool) (alias :: Symbol) a = Alias a 183 | deriving (Show, Eq, Semigroup, Monoid, Functor) 184 | 185 | unAlias :: Alias deprecated alias a -> a 186 | unAlias (Alias a) = a 187 | 188 | class KnownBool (a :: Bool) where 189 | boolVal :: Proxy a -> Bool 190 | 191 | instance KnownBool 'True where 192 | boolVal _ = True 193 | 194 | instance KnownBool 'False where 195 | boolVal _ = False 196 | -------------------------------------------------------------------------------- /src/Data/Aeson/Config/Key.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module Data.Aeson.Config.Key (module Data.Aeson.Config.Key) where 3 | 4 | #if MIN_VERSION_aeson(2,0,0) 5 | 6 | import Data.Aeson.Key as Data.Aeson.Config.Key 7 | 8 | #else 9 | 10 | import Data.Text (Text) 11 | import qualified Data.Text as T 12 | 13 | type Key = Text 14 | 15 | toText :: Key -> Text 16 | toText = id 17 | 18 | toString :: Key -> String 19 | toString = T.unpack 20 | 21 | fromString :: String -> Key 22 | fromString = T.pack 23 | 24 | #endif 25 | -------------------------------------------------------------------------------- /src/Data/Aeson/Config/KeyMap.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module Data.Aeson.Config.KeyMap (module KeyMap) where 3 | 4 | #if MIN_VERSION_aeson(2,0,0) 5 | import Data.Aeson.KeyMap as KeyMap 6 | #else 7 | import Data.HashMap.Strict as KeyMap 8 | #endif 9 | -------------------------------------------------------------------------------- /src/Data/Aeson/Config/Parser.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | {-# LANGUAGE ViewPatterns #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE CPP #-} 5 | module Data.Aeson.Config.Parser ( 6 | Parser 7 | , runParser 8 | 9 | , typeMismatch 10 | , withObject 11 | , withText 12 | , withString 13 | , withArray 14 | , withNumber 15 | , withBool 16 | 17 | , explicitParseField 18 | , explicitParseFieldMaybe 19 | 20 | , Aeson.JSONPathElement(..) 21 | , () 22 | 23 | , Value(..) 24 | , Object 25 | , Array 26 | 27 | , liftParser 28 | 29 | , fromAesonPath 30 | , formatPath 31 | 32 | , markDeprecated 33 | ) where 34 | 35 | import Imports 36 | 37 | import qualified Control.Monad.Fail as Fail 38 | import Control.Monad.Trans.Class 39 | import Control.Monad.Trans.Writer 40 | import Data.Scientific 41 | import Data.Set (Set, notMember) 42 | import qualified Data.Set as Set 43 | import qualified Data.Text as T 44 | import qualified Data.Vector as V 45 | import Data.Aeson.Config.Key (Key) 46 | import qualified Data.Aeson.Config.Key as Key 47 | import qualified Data.Aeson.Config.KeyMap as KeyMap 48 | import Data.Aeson.Types (Value(..), Object, Array) 49 | import qualified Data.Aeson.Types as Aeson 50 | #if MIN_VERSION_aeson(2,1,0) 51 | import Data.Aeson.Types (IResult(..), iparse) 52 | #else 53 | import Data.Aeson.Internal (IResult(..), iparse) 54 | #endif 55 | #if !MIN_VERSION_aeson(1,4,5) 56 | import qualified Data.Aeson.Internal as Aeson 57 | #endif 58 | 59 | -- This is needed so that we have an Ord instance for aeson < 1.2.4. 60 | data JSONPathElement = Key Text | Index Int 61 | deriving (Eq, Show, Ord) 62 | 63 | type JSONPath = [JSONPathElement] 64 | 65 | data Path = Consumed JSONPath | Deprecated JSONPath JSONPath 66 | deriving (Eq, Ord, Show) 67 | 68 | fromAesonPath :: Aeson.JSONPath -> JSONPath 69 | fromAesonPath = reverse . map fromAesonPathElement 70 | 71 | fromAesonPathElement :: Aeson.JSONPathElement -> JSONPathElement 72 | fromAesonPathElement e = case e of 73 | Aeson.Key k -> Key (Key.toText k) 74 | Aeson.Index n -> Index n 75 | 76 | newtype Parser a = Parser {unParser :: WriterT (Set Path) Aeson.Parser a} 77 | deriving (Functor, Applicative, Alternative, Monad, Fail.MonadFail) 78 | 79 | liftParser :: Aeson.Parser a -> Parser a 80 | liftParser = Parser . lift 81 | 82 | runParser :: (Value -> Parser a) -> Value -> Either String (a, [String], [(String, String)]) 83 | runParser p v = case iparse (runWriterT . unParser <$> p) v of 84 | IError path err -> Left ("Error while parsing " ++ formatPath (fromAesonPath path) ++ " - " ++ err) 85 | ISuccess (a, paths) -> Right (a, map formatPath (determineUnconsumed paths v), [(formatPath name, formatPath substitute) | Deprecated name substitute <- Set.toList paths]) 86 | 87 | formatPath :: JSONPath -> String 88 | formatPath = go "$" . reverse 89 | where 90 | go :: String -> JSONPath -> String 91 | go acc path = case path of 92 | [] -> acc 93 | Index n : xs -> go (acc ++ "[" ++ show n ++ "]") xs 94 | Key key : xs -> go (acc ++ "." ++ T.unpack key) xs 95 | 96 | determineUnconsumed :: Set Path -> Value -> [JSONPath] 97 | determineUnconsumed ((<> Set.singleton (Consumed [])) -> consumed) = Set.toList . execWriter . go [] 98 | where 99 | go :: JSONPath -> Value -> Writer (Set JSONPath) () 100 | go path value 101 | | Consumed path `notMember` consumed = tell (Set.singleton path) 102 | | otherwise = case value of 103 | Number _ -> return () 104 | String _ -> return () 105 | Bool _ -> return () 106 | Null -> return () 107 | Object o -> do 108 | forM_ (KeyMap.toList o) $ \ (Key.toText -> k, v) -> do 109 | unless ("_" `T.isPrefixOf` k) $ do 110 | go (Key k : path) v 111 | Array xs -> do 112 | forM_ (zip [0..] $ V.toList xs) $ \ (n, v) -> do 113 | go (Index n : path) v 114 | 115 | () :: Parser a -> Aeson.JSONPathElement -> Parser a 116 | () (Parser (WriterT p)) e = do 117 | Parser (WriterT (p Aeson. e)) <* markConsumed (fromAesonPathElement e) 118 | 119 | markConsumed :: JSONPathElement -> Parser () 120 | markConsumed e = do 121 | path <- getPath 122 | Parser $ tell (Set.singleton . Consumed $ e : path) 123 | 124 | markDeprecated :: Key -> Key -> Parser () 125 | markDeprecated (Key.toText -> name) (Key.toText -> substitute) = do 126 | path <- getPath 127 | Parser $ tell (Set.singleton $ Deprecated (Key name : path) (Key substitute : path)) 128 | 129 | getPath :: Parser JSONPath 130 | getPath = liftParser $ Aeson.parserCatchError empty $ \ path _ -> return (fromAesonPath path) 131 | 132 | explicitParseField :: (Value -> Parser a) -> Object -> Key -> Parser a 133 | explicitParseField p o key = case KeyMap.lookup key o of 134 | Nothing -> fail $ "key " ++ show key ++ " not present" 135 | Just v -> p v Aeson.Key key 136 | 137 | explicitParseFieldMaybe :: (Value -> Parser a) -> Object -> Key -> Parser (Maybe a) 138 | explicitParseFieldMaybe p o key = case KeyMap.lookup key o of 139 | Nothing -> pure Nothing 140 | Just v -> Just <$> p v Aeson.Key key 141 | 142 | typeMismatch :: String -> Value -> Parser a 143 | typeMismatch expected = liftParser . Aeson.typeMismatch expected 144 | 145 | withObject :: (Object -> Parser a) -> Value -> Parser a 146 | withObject p (Object o) = p o 147 | withObject _ v = typeMismatch "Object" v 148 | 149 | withText :: (Text -> Parser a) -> Value -> Parser a 150 | withText p (String s) = p s 151 | withText _ v = typeMismatch "String" v 152 | 153 | withString :: (String -> Parser a) -> Value -> Parser a 154 | withString p = withText (p . T.unpack) 155 | 156 | withArray :: (Array -> Parser a) -> Value -> Parser a 157 | withArray p (Array xs) = p xs 158 | withArray _ v = typeMismatch "Array" v 159 | 160 | withNumber :: (Scientific -> Parser a) -> Value -> Parser a 161 | withNumber p (Number n) = p n 162 | withNumber _ v = typeMismatch "Number" v 163 | 164 | withBool :: (Bool -> Parser a) -> Value -> Parser a 165 | withBool p (Bool b) = p b 166 | withBool _ v = typeMismatch "Boolean" v 167 | -------------------------------------------------------------------------------- /src/Data/Aeson/Config/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor #-} 2 | {-# LANGUAGE DeriveFoldable #-} 3 | {-# LANGUAGE DeriveTraversable #-} 4 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 5 | module Data.Aeson.Config.Types where 6 | 7 | import Imports 8 | 9 | import Data.Bitraversable 10 | import Data.Bifoldable 11 | 12 | import Data.Aeson.Config.FromValue 13 | 14 | newtype List a = List {fromList :: [a]} 15 | deriving (Eq, Show, Functor, Foldable, Traversable, Semigroup, Monoid) 16 | 17 | instance FromValue a => FromValue (List a) where 18 | fromValue v = List <$> case v of 19 | Array _ -> fromValue v 20 | _ -> return <$> fromValue v 21 | 22 | fromMaybeList :: Maybe (List a) -> [a] 23 | fromMaybeList = maybe [] fromList 24 | 25 | data Product a b = Product a b 26 | deriving (Eq, Show, Functor, Foldable, Traversable) 27 | 28 | instance (Semigroup a, Semigroup b, Monoid a, Monoid b) => Monoid (Product a b) where 29 | mempty = Product mempty mempty 30 | mappend = (<>) 31 | 32 | instance (Semigroup a, Semigroup b) => Semigroup (Product a b) where 33 | Product a1 b1 <> Product a2 b2 = Product (a1 <> a2) (b1 <> b2) 34 | 35 | instance Bifunctor Product where 36 | bimap fa fb (Product a b) = Product (fa a) (fb b) 37 | 38 | instance Bifoldable Product where 39 | bifoldMap = bifoldMapDefault 40 | 41 | instance Bitraversable Product where 42 | bitraverse fa fb (Product a b) = Product <$> fa a <*> fb b 43 | 44 | instance (FromValue a, FromValue b) => FromValue (Product a b) where 45 | fromValue v = Product <$> fromValue v <*> fromValue v 46 | -------------------------------------------------------------------------------- /src/Data/Aeson/Config/Util.hs: -------------------------------------------------------------------------------- 1 | module Data.Aeson.Config.Util where 2 | 3 | import Data.Aeson.Types (camelTo2) 4 | 5 | hyphenize :: String -> String -> String 6 | hyphenize name = camelTo2 '-' . dropPrefix . dropWhile (== '_') 7 | where 8 | dropPrefix = drop (length (dropWhile (== '_') $ reverse name)) 9 | -------------------------------------------------------------------------------- /src/Hpack.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE ViewPatterns #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | {-# LANGUAGE LambdaCase #-} 5 | module Hpack ( 6 | -- | /__NOTE:__/ This module is exposed to allow integration of Hpack into 7 | -- other tools. It is not meant for general use by end users. The following 8 | -- caveats apply: 9 | -- 10 | -- * The API is undocumented, consult the source instead. 11 | -- 12 | -- * The exposed types and functions primarily serve Hpack's own needs, not 13 | -- that of a public API. Breaking changes can happen as Hpack evolves. 14 | -- 15 | -- As an Hpack user you either want to use the @hpack@ executable or a build 16 | -- tool that supports Hpack (e.g. @stack@ or @cabal2nix@). 17 | 18 | -- * Version 19 | version 20 | 21 | -- * Running Hpack 22 | , hpack 23 | , hpackResult 24 | , hpackResultWithError 25 | , printResult 26 | , Result(..) 27 | , Status(..) 28 | 29 | -- * Options 30 | , defaultOptions 31 | , setProgramName 32 | , setTarget 33 | , setDecode 34 | , setFormatYamlParseError 35 | , getOptions 36 | , Verbose(..) 37 | , Options(..) 38 | , Force(..) 39 | , GenerateHashStrategy(..) 40 | , OutputStrategy(..) 41 | 42 | #ifdef TEST 43 | , hpackResultWithVersion 44 | , header 45 | , renderCabalFile 46 | #endif 47 | ) where 48 | 49 | import Imports 50 | 51 | import Data.Version (Version) 52 | import qualified Data.Version as Version 53 | import System.FilePath 54 | import System.Environment 55 | import System.Exit 56 | import System.IO (stderr) 57 | import Data.Aeson (Value) 58 | import Data.Maybe 59 | 60 | import Paths_hpack (version) 61 | import Hpack.Options 62 | import Hpack.Config 63 | import Hpack.Error (HpackError, formatHpackError) 64 | import Hpack.Render 65 | import Hpack.Util 66 | import Hpack.Utf8 as Utf8 67 | import Hpack.CabalFile 68 | import qualified Data.Yaml as Yaml 69 | 70 | programVersion :: Maybe Version -> String 71 | programVersion Nothing = "hpack" 72 | programVersion (Just v) = "hpack version " ++ Version.showVersion v 73 | 74 | header :: FilePath -> Maybe Version -> (Maybe Hash) -> [String] 75 | header p v hash = [ 76 | "-- This file has been generated from " ++ takeFileName p ++ " by " ++ programVersion v ++ "." 77 | , "--" 78 | , "-- see: https://github.com/sol/hpack" 79 | ] ++ case hash of 80 | Just h -> ["--" , "-- hash: " ++ h, ""] 81 | Nothing -> [""] 82 | 83 | data Options = Options { 84 | optionsDecodeOptions :: DecodeOptions 85 | , optionsForce :: Force 86 | , optionsGenerateHashStrategy :: GenerateHashStrategy 87 | , optionsToStdout :: Bool 88 | , optionsOutputStrategy :: OutputStrategy 89 | } 90 | 91 | data GenerateHashStrategy = ForceHash | ForceNoHash | PreferHash | PreferNoHash 92 | deriving (Eq, Show) 93 | 94 | getOptions :: FilePath -> [String] -> IO (Maybe (Verbose, Options)) 95 | getOptions defaultPackageConfig args = do 96 | result <- parseOptions defaultPackageConfig args 97 | case result of 98 | PrintVersion -> do 99 | putStrLn (programVersion $ Just version) 100 | return Nothing 101 | PrintNumericVersion -> do 102 | putStrLn (Version.showVersion version) 103 | return Nothing 104 | Help -> do 105 | printHelp 106 | return Nothing 107 | Run (ParseOptions verbose force hash toStdout file outputStrategy) -> do 108 | let generateHash = case hash of 109 | Just True -> ForceHash 110 | Just False -> ForceNoHash 111 | Nothing -> PreferNoHash 112 | return $ Just (verbose, Options defaultDecodeOptions {decodeOptionsTarget = file} force generateHash toStdout outputStrategy) 113 | ParseError -> do 114 | printHelp 115 | exitFailure 116 | 117 | printHelp :: IO () 118 | printHelp = do 119 | name <- getProgName 120 | Utf8.hPutStrLn stderr $ unlines [ 121 | "Usage: " ++ name ++ " [ --silent ] [ --canonical ] [ --force | -f ] [ --[no-]hash ] [ PATH ] [ - ]" 122 | , " " ++ name ++ " --version" 123 | , " " ++ name ++ " --numeric-version" 124 | , " " ++ name ++ " --help" 125 | ] 126 | 127 | hpack :: Verbose -> Options -> IO () 128 | hpack verbose options = hpackResult options >>= printResult verbose 129 | 130 | defaultOptions :: Options 131 | defaultOptions = Options defaultDecodeOptions NoForce PreferNoHash False MinimizeDiffs 132 | 133 | setTarget :: FilePath -> Options -> Options 134 | setTarget target options@Options{..} = 135 | options {optionsDecodeOptions = optionsDecodeOptions {decodeOptionsTarget = target}} 136 | 137 | setProgramName :: ProgramName -> Options -> Options 138 | setProgramName name options@Options{..} = 139 | options {optionsDecodeOptions = optionsDecodeOptions {decodeOptionsProgramName = name}} 140 | 141 | setDecode :: (FilePath -> IO (Either String ([String], Value))) -> Options -> Options 142 | setDecode decode options@Options{..} = 143 | options {optionsDecodeOptions = optionsDecodeOptions {decodeOptionsDecode = decode}} 144 | 145 | -- | This is used to format any `Yaml.ParseException`s encountered during 146 | -- decoding of . 147 | -- 148 | -- Note that: 149 | -- 150 | -- 1. This is not used to format `Yaml.ParseException`s encountered during 151 | -- decoding of the main @package.yaml@. To customize this you have to set a 152 | -- custom decode function. 153 | -- 154 | -- 2. Some of the constructors of `Yaml.ParseException` are never produced by 155 | -- Hpack (e.g. `Yaml.AesonException` as Hpack uses it's own mechanism to decode 156 | -- `Yaml.Value`s). 157 | -- 158 | -- Example: 159 | -- 160 | -- @ 161 | -- example :: IO (Either `HpackError` `Result`) 162 | -- example = `hpackResultWithError` options 163 | -- where 164 | -- options :: `Options` 165 | -- options = setCustomYamlParseErrorFormat format `defaultOptions` 166 | -- 167 | -- format :: FilePath -> `Yaml.ParseException` -> String 168 | -- format file err = file ++ ": " ++ displayException err 169 | -- 170 | -- setCustomYamlParseErrorFormat :: (FilePath -> `Yaml.ParseException` -> String) -> `Options` -> `Options` 171 | -- setCustomYamlParseErrorFormat format = `setDecode` decode >>> `setFormatYamlParseError` format 172 | -- where 173 | -- decode :: FilePath -> IO (Either String ([String], Value)) 174 | -- decode file = first (format file) \<$> `Hpack.Yaml.decodeYamlWithParseError` file 175 | -- @ 176 | setFormatYamlParseError :: (FilePath -> Yaml.ParseException -> String) -> Options -> Options 177 | setFormatYamlParseError formatYamlParseError options@Options{..} = 178 | options {optionsDecodeOptions = optionsDecodeOptions {decodeOptionsFormatYamlParseError = formatYamlParseError}} 179 | 180 | data Result = Result { 181 | resultWarnings :: [String] 182 | , resultCabalFile :: String 183 | , resultStatus :: Status 184 | } deriving (Eq, Show) 185 | 186 | data Status = 187 | Generated 188 | | ExistingCabalFileWasModifiedManually 189 | | AlreadyGeneratedByNewerHpack 190 | | OutputUnchanged 191 | deriving (Eq, Show) 192 | 193 | printResult :: Verbose -> Result -> IO () 194 | printResult verbose r = do 195 | printWarnings (resultWarnings r) 196 | when (verbose == Verbose) $ putStrLn $ 197 | case resultStatus r of 198 | Generated -> "generated " ++ resultCabalFile r 199 | OutputUnchanged -> resultCabalFile r ++ " is up-to-date" 200 | AlreadyGeneratedByNewerHpack -> resultCabalFile r ++ " was generated with a newer version of hpack, please upgrade and try again." 201 | ExistingCabalFileWasModifiedManually -> resultCabalFile r ++ " was modified manually, please use --force to overwrite." 202 | case resultStatus r of 203 | Generated -> return () 204 | OutputUnchanged -> return () 205 | AlreadyGeneratedByNewerHpack -> exitFailure 206 | ExistingCabalFileWasModifiedManually -> exitFailure 207 | 208 | printWarnings :: [String] -> IO () 209 | printWarnings = mapM_ $ Utf8.hPutStrLn stderr . ("WARNING: " ++) 210 | 211 | mkStatus :: NewCabalFile -> ExistingCabalFile -> Status 212 | mkStatus new@(CabalFile _ mNewVersion mNewHash _ _) existing@(CabalFile _ mExistingVersion _ _ _) 213 | | new `hasSameContent` existing = OutputUnchanged 214 | | otherwise = case mExistingVersion of 215 | Nothing -> ExistingCabalFileWasModifiedManually 216 | Just _ 217 | | mNewVersion < mExistingVersion -> AlreadyGeneratedByNewerHpack 218 | | isJust mNewHash && hashMismatch existing -> ExistingCabalFileWasModifiedManually 219 | | otherwise -> Generated 220 | 221 | hasSameContent :: NewCabalFile -> ExistingCabalFile -> Bool 222 | hasSameContent (CabalFile cabalVersionA _ _ a ()) (CabalFile cabalVersionB _ _ b gitConflictMarkers) = 223 | cabalVersionA == cabalVersionB 224 | && a == b 225 | && gitConflictMarkers == DoesNotHaveGitConflictMarkers 226 | 227 | hashMismatch :: ExistingCabalFile -> Bool 228 | hashMismatch cabalFile = case cabalFileHash cabalFile of 229 | Nothing -> False 230 | Just hash -> cabalFileGitConflictMarkers cabalFile == HasGitConflictMarkers || hash /= calculateHash cabalFile 231 | 232 | calculateHash :: CabalFile a -> Hash 233 | calculateHash (CabalFile cabalVersion _ _ body _) = sha256 (unlines $ cabalVersion ++ body) 234 | 235 | hpackResult :: Options -> IO Result 236 | hpackResult opts = hpackResultWithError opts >>= either (die . formatHpackError programName) return 237 | where 238 | programName = decodeOptionsProgramName (optionsDecodeOptions opts) 239 | 240 | hpackResultWithError :: Options -> IO (Either HpackError Result) 241 | hpackResultWithError = hpackResultWithVersion version 242 | 243 | hpackResultWithVersion :: Version -> Options -> IO (Either HpackError Result) 244 | hpackResultWithVersion v (Options options force generateHashStrategy toStdout outputStrategy) = do 245 | readPackageConfigWithError options >>= \ case 246 | Right (DecodeResult pkg (lines -> cabalVersion) cabalFileName warnings) -> do 247 | mExistingCabalFile <- readCabalFile cabalFileName 248 | let 249 | newCabalFile = makeCabalFile outputStrategy generateHashStrategy mExistingCabalFile cabalVersion v pkg 250 | 251 | status = case force of 252 | Force -> Generated 253 | NoForce -> maybe Generated (mkStatus newCabalFile) mExistingCabalFile 254 | 255 | case status of 256 | Generated -> writeCabalFile options toStdout cabalFileName newCabalFile 257 | _ -> return () 258 | 259 | return $ Right Result { 260 | resultWarnings = warnings 261 | , resultCabalFile = cabalFileName 262 | , resultStatus = status 263 | } 264 | Left err -> return $ Left err 265 | 266 | writeCabalFile :: DecodeOptions -> Bool -> FilePath -> NewCabalFile -> IO () 267 | writeCabalFile options toStdout name cabalFile = do 268 | write . unlines $ renderCabalFile (decodeOptionsTarget options) cabalFile 269 | where 270 | write = if toStdout then Utf8.putStr else Utf8.ensureFile name 271 | 272 | makeCabalFile :: OutputStrategy -> GenerateHashStrategy -> Maybe ExistingCabalFile -> [String] -> Version -> Package -> NewCabalFile 273 | makeCabalFile outputStrategy generateHashStrategy mExistingCabalFile cabalVersion v pkg = cabalFile 274 | where 275 | hints :: [String] 276 | hints = case outputStrategy of 277 | CanonicalOutput -> [] 278 | MinimizeDiffs -> maybe [] cabalFileContents mExistingCabalFile 279 | 280 | cabalFile :: NewCabalFile 281 | cabalFile = CabalFile cabalVersion (Just v) hash body () 282 | 283 | hash :: Maybe Hash 284 | hash 285 | | shouldGenerateHash mExistingCabalFile generateHashStrategy = Just $ calculateHash cabalFile 286 | | otherwise = Nothing 287 | 288 | body :: [String] 289 | body = lines $ renderPackage hints pkg 290 | 291 | shouldGenerateHash :: Maybe ExistingCabalFile -> GenerateHashStrategy -> Bool 292 | shouldGenerateHash mExistingCabalFile strategy = case (strategy, mExistingCabalFile) of 293 | (ForceHash, _) -> True 294 | (ForceNoHash, _) -> False 295 | (PreferHash, Nothing) -> True 296 | (PreferNoHash, Nothing) -> False 297 | (_, Just CabalFile {cabalFileHash = Nothing}) -> False 298 | (_, Just CabalFile {cabalFileHash = Just _}) -> True 299 | 300 | renderCabalFile :: FilePath -> NewCabalFile -> [String] 301 | renderCabalFile file (CabalFile cabalVersion hpackVersion hash body _) = cabalVersion ++ header file hpackVersion hash ++ body 302 | -------------------------------------------------------------------------------- /src/Hpack/CabalFile.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | {-# LANGUAGE ViewPatterns #-} 5 | module Hpack.CabalFile ( 6 | CabalFile(..) 7 | , GitConflictMarkers(..) 8 | , ExistingCabalFile 9 | , NewCabalFile 10 | , readCabalFile 11 | , parseVersion 12 | #ifdef TEST 13 | , extractVersion 14 | , removeGitConflictMarkers 15 | #endif 16 | ) where 17 | 18 | import Imports 19 | 20 | import Data.Maybe 21 | import Data.Version (Version(..)) 22 | import qualified Data.Version as Version 23 | import Text.ParserCombinators.ReadP 24 | 25 | import Hpack.Util 26 | 27 | data CabalFile a = CabalFile { 28 | cabalFileCabalVersion :: [String] 29 | , cabalFileHpackVersion :: Maybe Version 30 | , cabalFileHash :: Maybe Hash 31 | , cabalFileContents :: [String] 32 | , cabalFileGitConflictMarkers :: a 33 | } deriving (Eq, Show) 34 | 35 | data GitConflictMarkers = HasGitConflictMarkers | DoesNotHaveGitConflictMarkers 36 | deriving (Show, Eq) 37 | 38 | type ExistingCabalFile = CabalFile GitConflictMarkers 39 | type NewCabalFile = CabalFile () 40 | 41 | readCabalFile :: FilePath -> IO (Maybe ExistingCabalFile) 42 | readCabalFile cabalFile = fmap parseCabalFile <$> tryReadFile cabalFile 43 | 44 | parseCabalFile :: String -> ExistingCabalFile 45 | parseCabalFile (lines -> input) = case span isComment <$> span (not . isComment) clean of 46 | (cabalVersion, (header, body)) -> CabalFile { 47 | cabalFileCabalVersion = cabalVersion 48 | , cabalFileHpackVersion = extractVersion header 49 | , cabalFileHash = extractHash header 50 | , cabalFileContents = dropWhile null body 51 | , cabalFileGitConflictMarkers = gitConflictMarkers 52 | } 53 | where 54 | clean :: [String] 55 | clean = removeGitConflictMarkers input 56 | 57 | gitConflictMarkers :: GitConflictMarkers 58 | gitConflictMarkers 59 | | input == clean = DoesNotHaveGitConflictMarkers 60 | | otherwise = HasGitConflictMarkers 61 | 62 | isComment :: String -> Bool 63 | isComment = ("--" `isPrefixOf`) 64 | 65 | extractHash :: [String] -> Maybe Hash 66 | extractHash = extract "-- hash: " Just 67 | 68 | extractVersion :: [String] -> Maybe Version 69 | extractVersion = extract prefix (stripFileName >=> parseVersion . safeInit) 70 | where 71 | prefix = "-- This file has been generated from " 72 | stripFileName :: String -> Maybe String 73 | stripFileName = listToMaybe . mapMaybe (stripPrefix " by hpack version ") . tails 74 | 75 | extract :: String -> (String -> Maybe a) -> [String] -> Maybe a 76 | extract prefix parse = listToMaybe . mapMaybe (stripPrefix prefix >=> parse) 77 | 78 | safeInit :: [a] -> [a] 79 | safeInit [] = [] 80 | safeInit xs = init xs 81 | 82 | parseVersion :: String -> Maybe Version 83 | parseVersion xs = case [v | (v, "") <- readP_to_S Version.parseVersion xs] of 84 | [v] -> Just v 85 | _ -> Nothing 86 | 87 | removeGitConflictMarkers :: [String] -> [String] 88 | removeGitConflictMarkers = takeBoth 89 | where 90 | takeBoth input = case break (isPrefixOf marker) input of 91 | (both, _marker : rest) -> both ++ takeOurs rest 92 | (both, []) -> both 93 | where 94 | marker = "<<<<<<< " 95 | 96 | takeOurs input = case break (== marker) input of 97 | (ours, _marker : rest) -> ours ++ dropTheirs rest 98 | (ours, []) -> ours 99 | where 100 | marker = "=======" 101 | 102 | dropTheirs input = case break (isPrefixOf marker) input of 103 | (_theirs, _marker : rest) -> takeBoth rest 104 | (_theirs, []) -> [] 105 | where 106 | marker = ">>>>>>> " 107 | -------------------------------------------------------------------------------- /src/Hpack/Defaults.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE CPP #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | {-# LANGUAGE ViewPatterns #-} 5 | {-# LANGUAGE LambdaCase #-} 6 | module Hpack.Defaults ( 7 | ensure 8 | , Defaults(..) 9 | #ifdef TEST 10 | , Result(..) 11 | , ensureFile 12 | #endif 13 | ) where 14 | 15 | import Imports 16 | 17 | import Network.HTTP.Client 18 | import Network.HTTP.Client.TLS 19 | import qualified Data.ByteString.Lazy as LB 20 | import System.FilePath 21 | import System.Directory 22 | 23 | import Hpack.Error 24 | import Hpack.Syntax.Defaults 25 | 26 | defaultsUrl :: Github -> URL 27 | defaultsUrl Github{..} = "https://raw.githubusercontent.com/" ++ githubOwner ++ "/" ++ githubRepo ++ "/" ++ githubRef ++ "/" ++ intercalate "/" githubPath 28 | 29 | defaultsCachePath :: FilePath -> Github -> FilePath 30 | defaultsCachePath dir Github{..} = joinPath $ 31 | dir : "defaults" : githubOwner : githubRepo : githubRef : githubPath 32 | 33 | data Result = Found | NotFound | Failed Status 34 | deriving (Eq, Show) 35 | 36 | get :: URL -> FilePath -> IO Result 37 | get url file = do 38 | manager <- newManager tlsManagerSettings 39 | request <- parseRequest url 40 | response <- httpLbs request manager 41 | case responseStatus response of 42 | Status 200 _ -> do 43 | createDirectoryIfMissing True (takeDirectory file) 44 | LB.writeFile file (responseBody response) 45 | return Found 46 | Status 404 _ -> return NotFound 47 | status -> return (Failed status) 48 | 49 | ensure :: FilePath -> FilePath -> Defaults -> IO (Either HpackError FilePath) 50 | ensure userDataDir dir = \ case 51 | DefaultsGithub defaults -> do 52 | let 53 | url = defaultsUrl defaults 54 | file = defaultsCachePath userDataDir defaults 55 | ensureFile file url >>= \ case 56 | Found -> return (Right file) 57 | NotFound -> notFound url 58 | Failed status -> return (Left $ DefaultsDownloadFailed url status) 59 | DefaultsLocal (Local ((dir ) -> file)) -> do 60 | doesFileExist file >>= \ case 61 | True -> return (Right file) 62 | False -> notFound file 63 | where 64 | notFound = return . Left . DefaultsFileNotFound 65 | 66 | ensureFile :: FilePath -> URL -> IO Result 67 | ensureFile file url = do 68 | doesFileExist file >>= \ case 69 | True -> return Found 70 | False -> get url file 71 | -------------------------------------------------------------------------------- /src/Hpack/Error.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | module Hpack.Error ( 3 | -- | /__NOTE:__/ This module is exposed to allow integration of Hpack into 4 | -- other tools. It is not meant for general use by end users. The following 5 | -- caveats apply: 6 | -- 7 | -- * The API is undocumented, consult the source instead. 8 | -- 9 | -- * The exposed types and functions primarily serve Hpack's own needs, not 10 | -- that of a public API. Breaking changes can happen as Hpack evolves. 11 | -- 12 | -- As an Hpack user you either want to use the @hpack@ executable or a build 13 | -- tool that supports Hpack (e.g. @stack@ or @cabal2nix@). 14 | HpackError (..) 15 | , formatHpackError 16 | , ProgramName (..) 17 | , URL 18 | , Status (..) 19 | , formatStatus 20 | ) where 21 | 22 | import qualified Data.ByteString.Char8 as B 23 | import Data.List (intercalate) 24 | import Data.String (IsString (..)) 25 | import Data.Version (Version (..), showVersion) 26 | import Network.HTTP.Types.Status (Status (..)) 27 | 28 | type URL = String 29 | 30 | data HpackError = 31 | HpackVersionNotSupported FilePath Version Version 32 | | DefaultsFileNotFound FilePath 33 | | DefaultsDownloadFailed URL Status 34 | | CycleInDefaults [FilePath] 35 | | ParseError String 36 | | DecodeValueError FilePath String 37 | deriving (Eq, Show) 38 | 39 | newtype ProgramName = ProgramName {unProgramName :: String} 40 | deriving (Eq, Show) 41 | 42 | instance IsString ProgramName where 43 | fromString = ProgramName 44 | 45 | formatHpackError :: ProgramName -> HpackError -> String 46 | formatHpackError (ProgramName progName) = \ case 47 | HpackVersionNotSupported file wanted supported -> 48 | "The file " ++ file ++ " requires version " ++ showVersion wanted ++ 49 | " of the Hpack package specification, however this version of " ++ 50 | progName ++ " only supports versions up to " ++ showVersion supported ++ 51 | ". Upgrading to the latest version of " ++ progName ++ " may resolve this issue." 52 | DefaultsFileNotFound file -> "Invalid value for \"defaults\"! File " ++ file ++ " does not exist!" 53 | DefaultsDownloadFailed url status -> "Error while downloading " ++ url ++ " (" ++ formatStatus status ++ ")" 54 | CycleInDefaults files -> "cycle in defaults (" ++ intercalate " -> " files ++ ")" 55 | ParseError err -> err 56 | DecodeValueError file err -> file ++ ": " ++ err 57 | 58 | formatStatus :: Status -> String 59 | formatStatus (Status code message) = show code ++ " " ++ B.unpack message 60 | -------------------------------------------------------------------------------- /src/Hpack/Haskell.hs: -------------------------------------------------------------------------------- 1 | module Hpack.Haskell ( 2 | isModule 3 | , isModuleNameComponent 4 | , isQualifiedIdentifier 5 | , isIdentifier 6 | ) where 7 | 8 | import Data.Char 9 | 10 | isModule :: [String] -> Bool 11 | isModule name = (not . null) name && all isModuleNameComponent name 12 | 13 | isModuleNameComponent :: String -> Bool 14 | isModuleNameComponent name = case name of 15 | x : xs -> isUpper x && all isIdChar xs 16 | _ -> False 17 | 18 | isQualifiedIdentifier :: [String] -> Bool 19 | isQualifiedIdentifier name = case reverse name of 20 | x : xs -> isIdentifier x && isModule xs 21 | _ -> False 22 | 23 | isIdentifier :: String -> Bool 24 | isIdentifier name = case name of 25 | x : xs -> isLower x && all isIdChar xs && name `notElem` reserved 26 | _ -> False 27 | 28 | reserved :: [String] 29 | reserved = [ 30 | "case" 31 | , "class" 32 | , "data" 33 | , "default" 34 | , "deriving" 35 | , "do" 36 | , "else" 37 | , "foreign" 38 | , "if" 39 | , "import" 40 | , "in" 41 | , "infix" 42 | , "infixl" 43 | , "infixr" 44 | , "instance" 45 | , "let" 46 | , "module" 47 | , "newtype" 48 | , "of" 49 | , "then" 50 | , "type" 51 | , "where" 52 | , "_" 53 | ] 54 | 55 | isIdChar :: Char -> Bool 56 | isIdChar c = isAlphaNum c || c == '_' || c == '\'' 57 | -------------------------------------------------------------------------------- /src/Hpack/License.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DeriveFunctor #-} 3 | {-# LANGUAGE ViewPatterns #-} 4 | {-# LANGUAGE LambdaCase #-} 5 | module Hpack.License where 6 | 7 | import Imports 8 | 9 | import Distribution.Pretty (prettyShow) 10 | import Distribution.Version (mkVersion) 11 | import qualified Distribution.License as Cabal 12 | import qualified Distribution.SPDX.License as SPDX 13 | import Distribution.Parsec (eitherParsec) 14 | 15 | import qualified Data.License.Infer as Infer 16 | 17 | data License a = DontTouch String | CanSPDX Cabal.License a | MustSPDX a 18 | deriving (Eq, Show, Functor) 19 | 20 | parseLicense :: String -> License SPDX.License 21 | parseLicense license = case lookup license knownLicenses of 22 | Just l -> CanSPDX l (Cabal.licenseToSPDX l) 23 | Nothing -> case spdxLicense of 24 | Just l -> MustSPDX l 25 | Nothing -> DontTouch license 26 | where 27 | knownLicenses :: [(String, Cabal.License)] 28 | knownLicenses = map (prettyShow &&& id) (Cabal.BSD4 : Cabal.knownLicenses) 29 | 30 | spdxLicense :: Maybe SPDX.License 31 | spdxLicense = either (const Nothing) Just (eitherParsec license) 32 | 33 | inferLicense :: String -> Maybe (License SPDX.License) 34 | inferLicense = fmap (uncurry CanSPDX . (id &&& Cabal.licenseToSPDX) . toLicense) . Infer.inferLicense 35 | where 36 | toLicense = \ case 37 | Infer.MIT -> Cabal.MIT 38 | Infer.ISC -> Cabal.ISC 39 | Infer.BSD2 -> Cabal.BSD2 40 | Infer.BSD3 -> Cabal.BSD3 41 | Infer.BSD4 -> Cabal.BSD4 42 | Infer.Apache_2_0 -> Cabal.Apache (Just $ mkVersion [2,0]) 43 | Infer.MPL_2_0 -> Cabal.MPL (mkVersion [2,0]) 44 | Infer.GPLv2 -> Cabal.GPL (Just $ mkVersion [2]) 45 | Infer.GPLv3 -> Cabal.GPL (Just $ mkVersion [3]) 46 | Infer.LGPLv2_1 -> Cabal.LGPL (Just $ mkVersion [2,1]) 47 | Infer.LGPLv3 -> Cabal.LGPL (Just $ mkVersion [3]) 48 | Infer.AGPLv3 -> Cabal.AGPL (Just $ mkVersion [3]) 49 | -------------------------------------------------------------------------------- /src/Hpack/Module.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE ViewPatterns #-} 3 | {-# LANGUAGE CPP #-} 4 | module Hpack.Module ( 5 | Module(..) 6 | , toModule 7 | , getModules 8 | #ifdef TEST 9 | , getModuleFilesRecursive 10 | #endif 11 | ) where 12 | 13 | import Imports 14 | 15 | import System.FilePath 16 | import qualified System.Directory as Directory 17 | 18 | import Data.Aeson.Config.FromValue 19 | import Hpack.Util 20 | import Hpack.Haskell 21 | 22 | import Path (Path(..), PathComponent(..)) 23 | import qualified Path 24 | 25 | newtype Module = Module {unModule :: String} 26 | deriving (Eq, Ord) 27 | 28 | instance Show Module where 29 | show = show . unModule 30 | 31 | instance IsString Module where 32 | fromString = Module 33 | 34 | instance FromValue Module where 35 | fromValue = fmap Module . fromValue 36 | 37 | toModule :: Path -> Module 38 | toModule path = case reverse $ Path.components path of 39 | [] -> Module "" 40 | file : dirs -> Module . intercalate "." . reverse $ dropExtension file : dirs 41 | 42 | getModules :: FilePath -> FilePath -> IO [Module] 43 | getModules dir literalSrc = sortModules <$> do 44 | exists <- Directory.doesDirectoryExist (dir literalSrc) 45 | if exists 46 | then do 47 | canonicalSrc <- Directory.canonicalizePath (dir literalSrc) 48 | 49 | let 50 | srcIsProjectRoot :: Bool 51 | srcIsProjectRoot = canonicalSrc == dir 52 | 53 | toModules :: [Path] -> [Module] 54 | toModules = removeSetup . nub . map toModule 55 | 56 | removeSetup :: [Module] -> [Module] 57 | removeSetup 58 | | srcIsProjectRoot = filter (/= "Setup") 59 | | otherwise = id 60 | 61 | toModules <$> getModuleFilesRecursive canonicalSrc 62 | else return [] 63 | 64 | sortModules :: [Module] -> [Module] 65 | sortModules = map Module . sort . map unModule 66 | 67 | isSourceFile :: PathComponent -> Bool 68 | isSourceFile (splitExtension . unPathComponent -> (name, ext)) = ext `elem` extensions && isModuleNameComponent name 69 | where 70 | extensions :: [String] 71 | extensions = [ 72 | ".hs" 73 | , ".lhs" 74 | , ".chs" 75 | , ".hsc" 76 | , ".y" 77 | , ".ly" 78 | , ".x" 79 | ] 80 | 81 | isModuleComponent :: PathComponent -> Bool 82 | isModuleComponent = isModuleNameComponent . unPathComponent 83 | 84 | getModuleFilesRecursive :: FilePath -> IO [Path] 85 | getModuleFilesRecursive baseDir = go (Path []) 86 | where 87 | addBaseDir :: Path -> FilePath 88 | addBaseDir = (baseDir ) . Path.toFilePath 89 | 90 | listDirectory :: Path -> IO [PathComponent] 91 | listDirectory = fmap (map PathComponent) . Directory.listDirectory . addBaseDir 92 | 93 | doesFileExist :: Path -> IO Bool 94 | doesFileExist = Directory.doesFileExist . addBaseDir 95 | 96 | doesDirectoryExist :: Path -> IO Bool 97 | doesDirectoryExist = Directory.doesDirectoryExist . addBaseDir 98 | 99 | go :: Path -> IO [Path] 100 | go dir = do 101 | entries <- listDirectory dir 102 | 103 | files <- filterWith doesFileExist (filter isSourceFile entries) 104 | directories <- filterWith doesDirectoryExist (filter isModuleComponent entries) 105 | 106 | subdirsFiles <- concat <$> mapM go directories 107 | return (files ++ subdirsFiles) 108 | where 109 | filterWith :: (Path -> IO Bool) -> [PathComponent] -> IO [Path] 110 | filterWith p = filterM p . map addDir 111 | 112 | addDir :: PathComponent -> Path 113 | addDir entry = Path (unPath dir ++ [entry]) 114 | -------------------------------------------------------------------------------- /src/Hpack/Options.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | module Hpack.Options where 3 | 4 | import Imports 5 | 6 | import Data.Maybe 7 | import System.FilePath 8 | import System.Directory 9 | 10 | data ParseResult = Help | PrintVersion | PrintNumericVersion | Run ParseOptions | ParseError 11 | deriving (Eq, Show) 12 | 13 | data Verbose = Verbose | NoVerbose 14 | deriving (Eq, Show) 15 | 16 | data Force = Force | NoForce 17 | deriving (Eq, Show) 18 | 19 | data OutputStrategy = CanonicalOutput | MinimizeDiffs 20 | deriving (Eq, Show) 21 | 22 | data ParseOptions = ParseOptions { 23 | parseOptionsVerbose :: Verbose 24 | , parseOptionsForce :: Force 25 | , parseOptionsHash :: Maybe Bool 26 | , parseOptionsToStdout :: Bool 27 | , parseOptionsTarget :: FilePath 28 | , parseOptionsOutputStrategy :: OutputStrategy 29 | } deriving (Eq, Show) 30 | 31 | parseOptions :: FilePath -> [String] -> IO ParseResult 32 | parseOptions defaultTarget = \ case 33 | ["--version"] -> return PrintVersion 34 | ["--numeric-version"] -> return PrintNumericVersion 35 | ["--help"] -> return Help 36 | args -> case targets of 37 | Right (target, toStdout) -> do 38 | file <- expandTarget defaultTarget target 39 | let 40 | options 41 | | toStdout = ParseOptions NoVerbose Force hash toStdout file outputStrategy 42 | | otherwise = ParseOptions verbose force hash toStdout file outputStrategy 43 | return (Run options) 44 | Left err -> return err 45 | where 46 | silentFlag = "--silent" 47 | forceFlags = ["--force", "-f"] 48 | hashFlag = "--hash" 49 | noHashFlag = "--no-hash" 50 | canonicalFlag = "--canonical" 51 | 52 | flags = canonicalFlag : hashFlag : noHashFlag : silentFlag : forceFlags 53 | 54 | verbose :: Verbose 55 | verbose = if silentFlag `elem` args then NoVerbose else Verbose 56 | 57 | outputStrategy :: OutputStrategy 58 | outputStrategy = if canonicalFlag `elem` args then CanonicalOutput else MinimizeDiffs 59 | 60 | force :: Force 61 | force = if any (`elem` args) forceFlags then Force else NoForce 62 | 63 | hash :: Maybe Bool 64 | hash = listToMaybe . reverse $ mapMaybe parse args 65 | where 66 | parse :: String -> Maybe Bool 67 | parse t = True <$ guard (t == hashFlag) <|> False <$ guard (t == noHashFlag) 68 | 69 | ys = filter (`notElem` flags) args 70 | 71 | targets :: Either ParseResult (Maybe FilePath, Bool) 72 | targets = case ys of 73 | ["-"] -> Right (Nothing, True) 74 | ["-", "-"] -> Left ParseError 75 | [path] -> Right (Just path, False) 76 | [path, "-"] -> Right (Just path, True) 77 | [] -> Right (Nothing, False) 78 | _ -> Left ParseError 79 | 80 | expandTarget :: FilePath -> Maybe FilePath -> IO FilePath 81 | expandTarget defaultTarget = \ case 82 | Nothing -> return defaultTarget 83 | Just "" -> return defaultTarget 84 | Just target -> do 85 | isFile <- doesFileExist target 86 | isDirectory <- doesDirectoryExist target 87 | return $ case takeFileName target of 88 | _ | isFile -> target 89 | _ | isDirectory -> target defaultTarget 90 | "" -> target defaultTarget 91 | _ -> target 92 | -------------------------------------------------------------------------------- /src/Hpack/Render/Dsl.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 4 | module Hpack.Render.Dsl ( 5 | -- * AST 6 | Element (..) 7 | , Value (..) 8 | 9 | -- * Render 10 | , RenderSettings (..) 11 | , CommaStyle (..) 12 | , defaultRenderSettings 13 | , Alignment (..) 14 | , Nesting 15 | , render 16 | 17 | -- * Utils 18 | , sortFieldsBy 19 | 20 | #ifdef TEST 21 | , Lines (..) 22 | , renderValue 23 | , addSortKey 24 | #endif 25 | ) where 26 | 27 | import Imports 28 | 29 | data Value = 30 | Literal String 31 | | CommaSeparatedList [String] 32 | | LineSeparatedList [String] 33 | | WordList [String] 34 | deriving (Eq, Show) 35 | 36 | data Element = Stanza String [Element] | Group Element Element | Field String Value | Verbatim String 37 | deriving (Eq, Show) 38 | 39 | data Lines = SingleLine String | MultipleLines [String] 40 | deriving (Eq, Show) 41 | 42 | data CommaStyle = LeadingCommas | TrailingCommas 43 | deriving (Eq, Show) 44 | 45 | newtype Nesting = Nesting Int 46 | deriving (Eq, Show, Num, Enum) 47 | 48 | newtype Alignment = Alignment Int 49 | deriving (Eq, Show, Num) 50 | 51 | data RenderSettings = RenderSettings { 52 | renderSettingsIndentation :: Int 53 | , renderSettingsFieldAlignment :: Alignment 54 | , renderSettingsCommaStyle :: CommaStyle 55 | } deriving (Eq, Show) 56 | 57 | defaultRenderSettings :: RenderSettings 58 | defaultRenderSettings = RenderSettings 2 0 LeadingCommas 59 | 60 | render :: RenderSettings -> Nesting -> Element -> [String] 61 | render settings nesting (Stanza name elements) = indent settings nesting name : renderElements settings (succ nesting) elements 62 | render settings nesting (Group a b) = render settings nesting a ++ render settings nesting b 63 | render settings nesting (Field name value) = renderField settings nesting name value 64 | render settings nesting (Verbatim str) = map (indent settings nesting) (lines str) 65 | 66 | renderElements :: RenderSettings -> Nesting -> [Element] -> [String] 67 | renderElements settings nesting = concatMap (render settings nesting) 68 | 69 | renderField :: RenderSettings -> Nesting -> String -> Value -> [String] 70 | renderField settings@RenderSettings{..} nesting name value = case renderValue settings value of 71 | SingleLine "" -> [] 72 | SingleLine x -> [indent settings nesting (name ++ ": " ++ padding ++ x)] 73 | MultipleLines [] -> [] 74 | MultipleLines xs -> (indent settings nesting name ++ ":") : map (indent settings $ succ nesting) xs 75 | where 76 | Alignment fieldAlignment = renderSettingsFieldAlignment 77 | padding = replicate (fieldAlignment - length name - 2) ' ' 78 | 79 | renderValue :: RenderSettings -> Value -> Lines 80 | renderValue RenderSettings{..} v = case v of 81 | Literal s -> SingleLine s 82 | WordList ws -> SingleLine $ unwords ws 83 | LineSeparatedList xs -> renderLineSeparatedList renderSettingsCommaStyle xs 84 | CommaSeparatedList xs -> renderCommaSeparatedList renderSettingsCommaStyle xs 85 | 86 | renderLineSeparatedList :: CommaStyle -> [String] -> Lines 87 | renderLineSeparatedList style = MultipleLines . map (padding ++) 88 | where 89 | padding = case style of 90 | LeadingCommas -> " " 91 | TrailingCommas -> "" 92 | 93 | renderCommaSeparatedList :: CommaStyle -> [String] -> Lines 94 | renderCommaSeparatedList style = MultipleLines . case style of 95 | LeadingCommas -> map renderLeadingComma . zip (True : repeat False) 96 | TrailingCommas -> map renderTrailingComma . reverse . zip (True : repeat False) . reverse 97 | where 98 | renderLeadingComma :: (Bool, String) -> String 99 | renderLeadingComma (isFirst, x) 100 | | isFirst = " " ++ x 101 | | otherwise = ", " ++ x 102 | 103 | renderTrailingComma :: (Bool, String) -> String 104 | renderTrailingComma (isLast, x) 105 | | isLast = x 106 | | otherwise = x ++ "," 107 | 108 | instance IsString Value where 109 | fromString = Literal 110 | 111 | indent :: RenderSettings -> Nesting -> String -> String 112 | indent RenderSettings{..} (Nesting nesting) s = replicate (nesting * renderSettingsIndentation) ' ' ++ s 113 | 114 | sortFieldsBy :: [String] -> [Element] -> [Element] 115 | sortFieldsBy existingFieldOrder = 116 | map snd 117 | . sortOn fst 118 | . addSortKey 119 | . map (\a -> (existingIndex a, a)) 120 | where 121 | existingIndex :: Element -> Maybe Int 122 | existingIndex (Field name _) = name `elemIndex` existingFieldOrder 123 | existingIndex _ = Nothing 124 | 125 | addSortKey :: [(Maybe Int, a)] -> [((Int, Int), a)] 126 | addSortKey = go (-1) . zip [0..] 127 | where 128 | go :: Int -> [(Int, (Maybe Int, a))] -> [((Int, Int), a)] 129 | go n xs = case xs of 130 | [] -> [] 131 | (x, (Just y, a)) : ys -> ((y, x), a) : go y ys 132 | (x, (Nothing, a)) : ys -> ((n, x), a) : go n ys 133 | -------------------------------------------------------------------------------- /src/Hpack/Render/Hints.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE ViewPatterns #-} 3 | module Hpack.Render.Hints ( 4 | FormattingHints (..) 5 | , sniffFormattingHints 6 | #ifdef TEST 7 | , sniffRenderSettings 8 | , extractFieldOrder 9 | , extractSectionsFieldOrder 10 | , sanitize 11 | , unindent 12 | , sniffAlignment 13 | , splitField 14 | , sniffIndentation 15 | , sniffCommaStyle 16 | #endif 17 | ) where 18 | 19 | import Imports 20 | 21 | import Data.Char 22 | import Data.Maybe 23 | 24 | import Hpack.Render.Dsl 25 | import Hpack.Util 26 | 27 | data FormattingHints = FormattingHints { 28 | formattingHintsFieldOrder :: [String] 29 | , formattingHintsSectionsFieldOrder :: [(String, [String])] 30 | , formattingHintsAlignment :: Maybe Alignment 31 | , formattingHintsRenderSettings :: RenderSettings 32 | } deriving (Eq, Show) 33 | 34 | sniffFormattingHints :: [String] -> FormattingHints 35 | sniffFormattingHints (sanitize -> input) = FormattingHints { 36 | formattingHintsFieldOrder = extractFieldOrder input 37 | , formattingHintsSectionsFieldOrder = extractSectionsFieldOrder input 38 | , formattingHintsAlignment = sniffAlignment input 39 | , formattingHintsRenderSettings = sniffRenderSettings input 40 | } 41 | 42 | sanitize :: [String] -> [String] 43 | sanitize = filter (not . isPrefixOf "cabal-version:") . filter (not . null) . map stripEnd 44 | 45 | stripEnd :: String -> String 46 | stripEnd = reverse . dropWhile isSpace . reverse 47 | 48 | extractFieldOrder :: [String] -> [String] 49 | extractFieldOrder = map fst . catMaybes . map splitField 50 | 51 | extractSectionsFieldOrder :: [String] -> [(String, [String])] 52 | extractSectionsFieldOrder = map (fmap extractFieldOrder) . splitSections 53 | where 54 | splitSections input = case break startsWithSpace input of 55 | ([], []) -> [] 56 | (xs, ys) -> case span startsWithSpace ys of 57 | (fields, zs) -> case reverse xs of 58 | name : _ -> (name, unindent fields) : splitSections zs 59 | _ -> splitSections zs 60 | 61 | startsWithSpace :: String -> Bool 62 | startsWithSpace xs = case xs of 63 | y : _ -> isSpace y 64 | _ -> False 65 | 66 | unindent :: [String] -> [String] 67 | unindent input = map (drop indentation) input 68 | where 69 | indentation = minimum $ map (length . takeWhile isSpace) input 70 | 71 | data Indentation = Indentation { 72 | indentationFieldNameLength :: Int 73 | , indentationPadding :: Int 74 | } 75 | 76 | indentationTotal :: Indentation -> Int 77 | indentationTotal (Indentation fieldName padding) = fieldName + padding 78 | 79 | sniffAlignment :: [String] -> Maybe Alignment 80 | sniffAlignment input = case indentations of 81 | [] -> Nothing 82 | _ | all (indentationPadding >>> (== 1)) indentations -> Just 0 83 | _ -> case nub (map indentationTotal indentations) of 84 | [n] -> Just (Alignment n) 85 | _ -> Nothing 86 | where 87 | indentations :: [Indentation] 88 | indentations = catMaybes . map (splitField >=> indentation) $ input 89 | 90 | indentation :: (String, String) -> Maybe Indentation 91 | indentation (name, value) = case span isSpace value of 92 | (_, "") -> Nothing 93 | (padding, _) -> Just Indentation { 94 | indentationFieldNameLength = succ $ length name 95 | , indentationPadding = length padding 96 | } 97 | 98 | splitField :: String -> Maybe (String, String) 99 | splitField field = case span isNameChar field of 100 | (xs, ':':ys) -> Just (xs, ys) 101 | _ -> Nothing 102 | where 103 | isNameChar = (`elem` nameChars) 104 | nameChars = ['a'..'z'] ++ ['A'..'Z'] ++ "-" 105 | 106 | sniffIndentation :: [String] -> Maybe Int 107 | sniffIndentation input = sniffFrom "library" <|> sniffFrom "executable" 108 | where 109 | sniffFrom :: String -> Maybe Int 110 | sniffFrom section = case findSection . removeEmptyLines $ input of 111 | _ : x : _ -> Just . length $ takeWhile isSpace x 112 | _ -> Nothing 113 | where 114 | findSection = dropWhile (not . isPrefixOf section) 115 | 116 | removeEmptyLines :: [String] -> [String] 117 | removeEmptyLines = filter $ any (not . isSpace) 118 | 119 | sniffCommaStyle :: [String] -> Maybe CommaStyle 120 | sniffCommaStyle input 121 | | any startsWithComma input = Just LeadingCommas 122 | | any (startsWithComma . reverse) input = Just TrailingCommas 123 | | otherwise = Nothing 124 | where 125 | startsWithComma = isPrefixOf "," . dropWhile isSpace 126 | 127 | sniffRenderSettings :: [String] -> RenderSettings 128 | sniffRenderSettings input = RenderSettings indentation fieldAlignment commaStyle 129 | where 130 | indentation = max def $ fromMaybe def (sniffIndentation input) 131 | where def = renderSettingsIndentation defaultRenderSettings 132 | 133 | fieldAlignment = renderSettingsFieldAlignment defaultRenderSettings 134 | commaStyle = fromMaybe (renderSettingsCommaStyle defaultRenderSettings) (sniffCommaStyle input) 135 | -------------------------------------------------------------------------------- /src/Hpack/Syntax/BuildTools.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 3 | {-# LANGUAGE ViewPatterns #-} 4 | module Hpack.Syntax.BuildTools ( 5 | BuildTools(..) 6 | , ParseBuildTool(..) 7 | , SystemBuildTools(..) 8 | ) where 9 | 10 | import Imports 11 | 12 | import qualified Control.Monad.Fail as Fail 13 | import qualified Data.Text as T 14 | import qualified Distribution.Package as D 15 | import Data.Map.Lazy (Map) 16 | import qualified Data.Map.Lazy as Map 17 | 18 | import qualified Distribution.Types.ExeDependency as D 19 | import qualified Distribution.Types.UnqualComponentName as D 20 | import qualified Distribution.Types.LegacyExeDependency as D 21 | 22 | import Data.Aeson.Config.FromValue 23 | 24 | import Hpack.Syntax.DependencyVersion 25 | import Hpack.Syntax.Dependencies (parseDependency) 26 | 27 | import Hpack.Syntax.ParseDependencies 28 | 29 | data ParseBuildTool = QualifiedBuildTool String String | UnqualifiedBuildTool String 30 | deriving (Show, Eq) 31 | 32 | newtype BuildTools = BuildTools { 33 | unBuildTools :: [(ParseBuildTool, DependencyVersion)] 34 | } deriving (Show, Eq, Semigroup, Monoid) 35 | 36 | instance FromValue BuildTools where 37 | fromValue = fmap BuildTools . parseDependencies parse 38 | where 39 | parse :: Parse ParseBuildTool DependencyVersion 40 | parse = Parse { 41 | parseString = buildToolFromString 42 | , parseListItem = objectDependency 43 | , parseDictItem = dependencyVersion 44 | , parseName = nameToBuildTool 45 | } 46 | 47 | nameToBuildTool :: Text -> ParseBuildTool 48 | nameToBuildTool (T.unpack -> name) = case break (== ':') name of 49 | (executable, "") -> UnqualifiedBuildTool executable 50 | (package, executable) -> QualifiedBuildTool package (drop 1 executable) 51 | 52 | buildToolFromString :: Text -> Parser (ParseBuildTool, DependencyVersion) 53 | buildToolFromString s = parseQualifiedBuildTool s <|> parseUnqualifiedBuildTool s 54 | 55 | parseQualifiedBuildTool :: Fail.MonadFail m => Text -> m (ParseBuildTool, DependencyVersion) 56 | parseQualifiedBuildTool = fmap fromCabal . cabalParse "build tool" . T.unpack 57 | where 58 | fromCabal :: D.ExeDependency -> (ParseBuildTool, DependencyVersion) 59 | fromCabal (D.ExeDependency package executable version) = ( 60 | QualifiedBuildTool (D.unPackageName package) (D.unUnqualComponentName executable) 61 | , DependencyVersion Nothing $ versionConstraintFromCabal version 62 | ) 63 | 64 | parseUnqualifiedBuildTool :: Fail.MonadFail m => Text -> m (ParseBuildTool, DependencyVersion) 65 | parseUnqualifiedBuildTool = fmap (first UnqualifiedBuildTool) . parseDependency "build tool" 66 | 67 | newtype SystemBuildTools = SystemBuildTools { 68 | unSystemBuildTools :: Map String VersionConstraint 69 | } deriving (Show, Eq, Semigroup, Monoid) 70 | 71 | instance FromValue SystemBuildTools where 72 | fromValue = fmap (SystemBuildTools . Map.fromList) . parseDependencies parse 73 | where 74 | parse :: Parse String VersionConstraint 75 | parse = Parse { 76 | parseString = parseSystemBuildTool 77 | , parseListItem = (.: "version") 78 | , parseDictItem = versionConstraint 79 | , parseName = T.unpack 80 | } 81 | 82 | parseSystemBuildTool :: Fail.MonadFail m => Text -> m (String, VersionConstraint) 83 | parseSystemBuildTool = fmap fromCabal . cabalParse "system build tool" . T.unpack 84 | where 85 | fromCabal :: D.LegacyExeDependency -> (String, VersionConstraint) 86 | fromCabal (D.LegacyExeDependency name version) = (name, versionConstraintFromCabal version) 87 | -------------------------------------------------------------------------------- /src/Hpack/Syntax/Defaults.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE DeriveAnyClass #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | {-# LANGUAGE RecordWildCards #-} 6 | module Hpack.Syntax.Defaults ( 7 | Defaults(..) 8 | , Github(..) 9 | , Local(..) 10 | #ifdef TEST 11 | , isValidOwner 12 | , isValidRepo 13 | #endif 14 | ) where 15 | 16 | import Imports 17 | 18 | import Data.Aeson.Config.KeyMap (member) 19 | import qualified Data.Text as T 20 | import System.FilePath.Posix (splitDirectories) 21 | 22 | import Data.Aeson.Config.FromValue 23 | import Hpack.Syntax.Git 24 | 25 | data ParseGithub = ParseGithub { 26 | parseGithubGithub :: GithubRepo 27 | , parseGithubRef :: Ref 28 | , parseGithubPath :: Maybe Path 29 | } deriving (Generic, FromValue) 30 | 31 | data GithubRepo = GithubRepo { 32 | githubRepoOwner :: String 33 | , githubRepoName :: String 34 | } 35 | 36 | instance FromValue GithubRepo where 37 | fromValue = withString parseGithub 38 | 39 | parseGithub :: String -> Parser GithubRepo 40 | parseGithub github 41 | | not (isValidOwner owner) = fail ("invalid owner name " ++ show owner) 42 | | not (isValidRepo repo) = fail ("invalid repository name " ++ show repo) 43 | | otherwise = return (GithubRepo owner repo) 44 | where 45 | (owner, repo) = drop 1 <$> break (== '/') github 46 | 47 | isValidOwner :: String -> Bool 48 | isValidOwner owner = 49 | not (null owner) 50 | && all isAlphaNumOrHyphen owner 51 | && doesNotHaveConsecutiveHyphens owner 52 | && doesNotBeginWithHyphen owner 53 | && doesNotEndWithHyphen owner 54 | where 55 | isAlphaNumOrHyphen = (`elem` '-' : alphaNum) 56 | doesNotHaveConsecutiveHyphens = not . isInfixOf "--" 57 | doesNotBeginWithHyphen = not . isPrefixOf "-" 58 | doesNotEndWithHyphen = not . isSuffixOf "-" 59 | 60 | isValidRepo :: String -> Bool 61 | isValidRepo repo = 62 | not (null repo) 63 | && repo `notElem` [".", ".."] 64 | && all isValid repo 65 | where 66 | isValid = (`elem` '_' : '.' : '-' : alphaNum) 67 | 68 | alphaNum :: [Char] 69 | alphaNum = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] 70 | 71 | data Ref = Ref {unRef :: String} 72 | 73 | instance FromValue Ref where 74 | fromValue = withString parseRef 75 | 76 | parseRef :: String -> Parser Ref 77 | parseRef ref 78 | | isValidRef ref = return (Ref ref) 79 | | otherwise = fail ("invalid Git reference " ++ show ref) 80 | 81 | data Path = Path {unPath :: [FilePath]} 82 | 83 | instance FromValue Path where 84 | fromValue = withString parsePath 85 | 86 | parsePath :: String -> Parser Path 87 | parsePath path 88 | | '\\' `elem` path = fail ("rejecting '\\' in " ++ show path ++ ", please use '/' to separate path components") 89 | | ':' `elem` path = fail ("rejecting ':' in " ++ show path) 90 | | "/" `elem` p = fail ("rejecting absolute path " ++ show path) 91 | | ".." `elem` p = fail ("rejecting \"..\" in " ++ show path) 92 | | otherwise = return (Path p) 93 | where 94 | p = splitDirectories path 95 | 96 | data Github = Github { 97 | githubOwner :: String 98 | , githubRepo :: String 99 | , githubRef :: String 100 | , githubPath :: [FilePath] 101 | } deriving (Eq, Show) 102 | 103 | toDefaultsGithub :: ParseGithub -> Github 104 | toDefaultsGithub ParseGithub{..} = Github { 105 | githubOwner = githubRepoOwner parseGithubGithub 106 | , githubRepo = githubRepoName parseGithubGithub 107 | , githubRef = unRef parseGithubRef 108 | , githubPath = maybe [".hpack", "defaults.yaml"] unPath parseGithubPath 109 | } 110 | 111 | parseDefaultsGithubFromString :: String -> Parser ParseGithub 112 | parseDefaultsGithubFromString xs = case break (== '@') xs of 113 | (github, '@' : ref) -> ParseGithub <$> parseGithub github <*> parseRef ref <*> pure Nothing 114 | _ -> fail ("missing Git reference for " ++ show xs ++ ", the expected format is owner/repo@ref") 115 | 116 | data Local = Local { 117 | localLocal :: String 118 | } deriving (Eq, Show, Generic, FromValue) 119 | 120 | data Defaults = DefaultsLocal Local | DefaultsGithub Github 121 | deriving (Eq, Show) 122 | 123 | instance FromValue Defaults where 124 | fromValue v = case v of 125 | String s -> DefaultsGithub . toDefaultsGithub <$> parseDefaultsGithubFromString (T.unpack s) 126 | Object o | "local" `member` o -> DefaultsLocal <$> fromValue v 127 | Object o | "github" `member` o -> DefaultsGithub . toDefaultsGithub <$> fromValue v 128 | Object _ -> fail "neither key \"github\" nor key \"local\" present" 129 | _ -> typeMismatch "Object or String" v 130 | -------------------------------------------------------------------------------- /src/Hpack/Syntax/Dependencies.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | module Hpack.Syntax.Dependencies ( 6 | Dependencies(..) 7 | , DependencyInfo(..) 8 | , parseDependency 9 | ) where 10 | 11 | import Imports 12 | 13 | import qualified Control.Monad.Fail as Fail 14 | import qualified Data.Text as T 15 | import qualified Distribution.Package as D 16 | import qualified Distribution.Types.LibraryName as D 17 | import Distribution.Pretty (prettyShow) 18 | import Data.Map.Lazy (Map) 19 | import qualified Data.Map.Lazy as Map 20 | import GHC.Exts 21 | 22 | #if MIN_VERSION_Cabal(3,4,0) 23 | import qualified Distribution.Compat.NonEmptySet as DependencySet 24 | #else 25 | import qualified Data.Set as DependencySet 26 | #endif 27 | 28 | import Data.Aeson.Config.FromValue 29 | import Data.Aeson.Config.Types 30 | 31 | import Hpack.Syntax.DependencyVersion 32 | import Hpack.Syntax.ParseDependencies 33 | 34 | newtype Dependencies = Dependencies { 35 | unDependencies :: Map String DependencyInfo 36 | } deriving (Eq, Show, Semigroup, Monoid) 37 | 38 | instance IsList Dependencies where 39 | type Item Dependencies = (String, DependencyInfo) 40 | fromList = Dependencies . Map.fromList 41 | toList = Map.toList . unDependencies 42 | 43 | instance FromValue Dependencies where 44 | fromValue = fmap (Dependencies . Map.fromList) . parseDependencies parse 45 | where 46 | parse :: Parse String DependencyInfo 47 | parse = Parse { 48 | parseString = \ input -> do 49 | (name, version) <- parseDependency "dependency" input 50 | return (name, DependencyInfo [] version) 51 | , parseListItem = objectDependencyInfo 52 | , parseDictItem = dependencyInfo 53 | , parseName = T.unpack 54 | } 55 | 56 | data DependencyInfo = DependencyInfo { 57 | dependencyInfoMixins :: [String] 58 | , dependencyInfoVersion :: DependencyVersion 59 | } deriving (Eq, Ord, Show) 60 | 61 | addMixins :: Object -> DependencyVersion -> Parser DependencyInfo 62 | addMixins o version = do 63 | mixinsMay <- o .:? "mixin" 64 | return $ DependencyInfo (fromMaybeList mixinsMay) version 65 | 66 | objectDependencyInfo :: Object -> Parser DependencyInfo 67 | objectDependencyInfo o = objectDependency o >>= addMixins o 68 | 69 | dependencyInfo :: Value -> Parser DependencyInfo 70 | dependencyInfo = withDependencyVersion (DependencyInfo []) addMixins 71 | 72 | parseDependency :: Fail.MonadFail m => String -> Text -> m (String, DependencyVersion) 73 | parseDependency subject = fmap fromCabal . cabalParse subject . T.unpack 74 | where 75 | fromCabal :: D.Dependency -> (String, DependencyVersion) 76 | fromCabal d = (toName (D.depPkgName d) (DependencySet.toList $ D.depLibraries d), DependencyVersion Nothing . versionConstraintFromCabal $ D.depVerRange d) 77 | 78 | toName :: D.PackageName -> [D.LibraryName] -> String 79 | toName package components = prettyShow package <> case components of 80 | [D.LMainLibName] -> "" 81 | [D.LSubLibName lib] -> ":" <> prettyShow lib 82 | xs -> ":{" <> (intercalate "," $ map prettyShow [name | D.LSubLibName name <- xs]) <> "}" 83 | -------------------------------------------------------------------------------- /src/Hpack/Syntax/DependencyVersion.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE LambdaCase #-} 4 | {-# LANGUAGE ViewPatterns #-} 5 | module Hpack.Syntax.DependencyVersion ( 6 | githubBaseUrl 7 | , GitRef 8 | , GitUrl 9 | 10 | , VersionConstraint(..) 11 | , versionConstraint 12 | , anyVersion 13 | , versionRange 14 | 15 | , DependencyVersion(..) 16 | , withDependencyVersion 17 | , dependencyVersion 18 | 19 | , SourceDependency(..) 20 | , objectDependency 21 | 22 | , versionConstraintFromCabal 23 | 24 | , scientificToVersion 25 | , cabalParse 26 | ) where 27 | 28 | import Imports 29 | 30 | import qualified Control.Monad.Fail as Fail 31 | import Data.Maybe 32 | import Data.Scientific 33 | import qualified Data.Text as T 34 | import qualified Data.Aeson.Config.KeyMap as KeyMap 35 | import Text.PrettyPrint (renderStyle, Style(..), Mode(..)) 36 | 37 | import qualified Distribution.Version as D 38 | 39 | import qualified Distribution.Parsec as D 40 | import qualified Distribution.Pretty as D 41 | import qualified Distribution.Types.VersionRange.Internal as D 42 | 43 | import Data.Aeson.Config.FromValue 44 | 45 | githubBaseUrl :: String 46 | githubBaseUrl = "https://github.com/" 47 | 48 | type GitUrl = String 49 | type GitRef = String 50 | 51 | data VersionConstraint = AnyVersion | VersionRange String 52 | deriving (Eq, Ord, Show) 53 | 54 | instance FromValue VersionConstraint where 55 | fromValue = versionConstraint 56 | 57 | versionConstraint :: Value -> Parser VersionConstraint 58 | versionConstraint v = case v of 59 | Null -> return AnyVersion 60 | Number n -> return (numericVersionConstraint n) 61 | String s -> stringVersionConstraint s 62 | _ -> typeMismatch "Null, Number, or String" v 63 | 64 | anyVersion :: DependencyVersion 65 | anyVersion = DependencyVersion Nothing AnyVersion 66 | 67 | versionRange :: String -> DependencyVersion 68 | versionRange = DependencyVersion Nothing . VersionRange 69 | 70 | data DependencyVersion = DependencyVersion (Maybe SourceDependency) VersionConstraint 71 | deriving (Eq, Ord, Show) 72 | 73 | withDependencyVersion 74 | :: (DependencyVersion -> a) 75 | -> (Object -> DependencyVersion -> Parser a) 76 | -> Value 77 | -> Parser a 78 | withDependencyVersion k obj v = case v of 79 | Null -> return $ k anyVersion 80 | Object o -> objectDependency o >>= obj o 81 | Number n -> return $ k (DependencyVersion Nothing $ numericVersionConstraint n) 82 | String s -> k . DependencyVersion Nothing <$> stringVersionConstraint s 83 | _ -> typeMismatch "Null, Object, Number, or String" v 84 | 85 | dependencyVersion :: Value -> Parser DependencyVersion 86 | dependencyVersion = withDependencyVersion id (const return) 87 | 88 | data SourceDependency = GitRef GitUrl GitRef (Maybe FilePath) | Local FilePath 89 | deriving (Eq, Ord, Show) 90 | 91 | objectDependency :: Object -> Parser DependencyVersion 92 | objectDependency o = let 93 | version :: Parser VersionConstraint 94 | version = fromMaybe AnyVersion <$> (o .:? "version") 95 | 96 | local :: Parser SourceDependency 97 | local = Local <$> o .: "path" 98 | 99 | git :: Parser SourceDependency 100 | git = GitRef <$> url <*> ref <*> subdir 101 | 102 | url :: Parser String 103 | url = 104 | ((githubBaseUrl ++) <$> o .: "github") 105 | <|> (o .: "git") 106 | <|> fail "neither key \"git\" nor key \"github\" present" 107 | 108 | ref :: Parser String 109 | ref = o .: "ref" 110 | 111 | subdir :: Parser (Maybe FilePath) 112 | subdir = o .:? "subdir" 113 | 114 | source :: Parser (Maybe SourceDependency) 115 | source 116 | | any (`KeyMap.member` o) ["path", "git", "github", "ref", "subdir"] = Just <$> (local <|> git) 117 | | otherwise = return Nothing 118 | 119 | in DependencyVersion <$> source <*> version 120 | 121 | numericVersionConstraint :: Scientific -> VersionConstraint 122 | numericVersionConstraint n = VersionRange ("==" ++ version) 123 | where 124 | version = scientificToVersion n 125 | 126 | stringVersionConstraint :: Text -> Parser VersionConstraint 127 | stringVersionConstraint s = parseVersionRange ("== " ++ input) <|> parseVersionRange input 128 | where 129 | input = T.unpack s 130 | 131 | scientificToVersion :: Scientific -> String 132 | scientificToVersion n = version 133 | where 134 | version = formatScientific Fixed (Just decimalPlaces) n 135 | decimalPlaces 136 | | e < 0 = abs e 137 | | otherwise = 0 138 | e = base10Exponent n 139 | 140 | parseVersionRange :: Fail.MonadFail m => String -> m VersionConstraint 141 | parseVersionRange = fmap versionConstraintFromCabal . parseCabalVersionRange 142 | 143 | parseCabalVersionRange :: Fail.MonadFail m => String -> m D.VersionRange 144 | parseCabalVersionRange = cabalParse "constraint" 145 | 146 | cabalParse :: (Fail.MonadFail m, D.Parsec a) => String -> String -> m a 147 | cabalParse subject s = case D.eitherParsec s of 148 | Right d -> return d 149 | Left _ ->fail $ unwords ["invalid", subject, show s] 150 | 151 | renderVersionRange :: D.VersionRange -> String 152 | renderVersionRange = \ case 153 | D.IntersectVersionRanges (D.OrLaterVersion x) (D.EarlierVersion y) | differByOneInLeastPosition (x, y) -> "==" ++ render x ++ ".*" 154 | v -> render v 155 | where 156 | differByOneInLeastPosition = \ case 157 | (reverse . D.versionNumbers -> x : xs, reverse . D.versionNumbers -> y : ys) -> xs == ys && succ x == y 158 | _ -> False 159 | 160 | render :: D.Pretty a => a -> String 161 | render = renderStyle (Style OneLineMode 0 0) . D.pretty 162 | 163 | versionConstraintFromCabal :: D.VersionRange -> VersionConstraint 164 | versionConstraintFromCabal range 165 | | D.isAnyVersion range = AnyVersion 166 | | otherwise = VersionRange . renderVersionRange $ toPreCabal2VersionRange range 167 | where 168 | toPreCabal2VersionRange :: D.VersionRange -> D.VersionRange 169 | toPreCabal2VersionRange = D.embedVersionRange . D.cataVersionRange f 170 | where 171 | f :: D.VersionRangeF (D.VersionRangeF D.VersionRange) -> D.VersionRangeF D.VersionRange 172 | f = \ case 173 | D.MajorBoundVersionF v -> D.IntersectVersionRangesF (D.embedVersionRange lower) (D.embedVersionRange upper) 174 | where 175 | lower = D.OrLaterVersionF v 176 | upper = D.EarlierVersionF (D.majorUpperBound v) 177 | 178 | D.ThisVersionF v -> D.ThisVersionF v 179 | D.LaterVersionF v -> D.LaterVersionF v 180 | D.OrLaterVersionF v -> D.OrLaterVersionF v 181 | D.EarlierVersionF v -> D.EarlierVersionF v 182 | D.OrEarlierVersionF v -> D.OrEarlierVersionF v 183 | D.UnionVersionRangesF a b -> D.UnionVersionRangesF (D.embedVersionRange a) (D.embedVersionRange b) 184 | D.IntersectVersionRangesF a b -> D.IntersectVersionRangesF (D.embedVersionRange a) (D.embedVersionRange b) 185 | #if !MIN_VERSION_Cabal(3,4,0) 186 | D.WildcardVersionF v -> D.WildcardVersionF v 187 | D.VersionRangeParensF a -> D.VersionRangeParensF (D.embedVersionRange a) 188 | D.AnyVersionF -> D.AnyVersionF 189 | #endif 190 | -------------------------------------------------------------------------------- /src/Hpack/Syntax/Git.hs: -------------------------------------------------------------------------------- 1 | module Hpack.Syntax.Git ( 2 | isValidRef 3 | ) where 4 | 5 | import Imports 6 | 7 | import Data.Char (chr) 8 | import System.FilePath.Posix 9 | 10 | -- https://git-scm.com/docs/git-check-ref-format 11 | isValidRef :: String -> Bool 12 | isValidRef ref = 13 | not (null ref) 14 | && not (any (isSuffixOf ".lock") components) 15 | && not (any (isPrefixOf ".") components) 16 | && not (".." `isInfixOf` ref) 17 | && not (any isControl ref) 18 | && all (`notElem` " ~^:?*[\\") ref 19 | && not ("//" `isInfixOf` ref) 20 | && not ("/" `isPrefixOf` ref) 21 | && not ("/" `isSuffixOf` ref) 22 | && not ("." `isSuffixOf` ref) 23 | && not ("@{" `isInfixOf` ref) 24 | && not (ref == "@") 25 | where 26 | components = splitDirectories ref 27 | 28 | isControl :: Char -> Bool 29 | isControl c = c < chr 0o040 || c == chr 0o177 30 | -------------------------------------------------------------------------------- /src/Hpack/Syntax/ParseDependencies.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | module Hpack.Syntax.ParseDependencies where 4 | 5 | import Imports 6 | 7 | import Data.Aeson.Config.FromValue 8 | import qualified Data.Aeson.Config.Key as Key 9 | 10 | data Parse k v = Parse { 11 | parseString :: Text -> Parser (k, v) 12 | , parseListItem :: Object -> Parser v 13 | , parseDictItem :: Value -> Parser v 14 | , parseName :: Text -> k 15 | } 16 | 17 | parseDependencies :: Parse k v -> Value -> Parser [(k, v)] 18 | parseDependencies parse@Parse{..} v = case v of 19 | String s -> return <$> parseString s 20 | Array xs -> parseArray (buildToolFromValue parse) xs 21 | Object o -> map (first (parseName . Key.toText)) <$> traverseObject parseDictItem o 22 | _ -> typeMismatch "Array, Object, or String" v 23 | 24 | buildToolFromValue :: Parse k v -> Value -> Parser (k, v) 25 | buildToolFromValue Parse{..} v = case v of 26 | String s -> parseString s 27 | Object o -> sourceDependency o 28 | _ -> typeMismatch "Object or String" v 29 | where 30 | sourceDependency o = (,) <$> (parseName <$> name) <*> parseListItem o 31 | where 32 | name :: Parser Text 33 | name = o .: "name" 34 | -------------------------------------------------------------------------------- /src/Hpack/Utf8.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | module Hpack.Utf8 ( 4 | encodeUtf8 5 | , readFile 6 | , ensureFile 7 | , putStr 8 | , hPutStr 9 | , hPutStrLn 10 | ) where 11 | 12 | import Prelude hiding (readFile, writeFile, putStr) 13 | 14 | import Control.Monad 15 | import Control.Exception (try, IOException) 16 | import qualified Data.Text as T 17 | import qualified Data.Text.Encoding as Encoding 18 | import Data.Text.Encoding.Error (lenientDecode) 19 | import qualified Data.ByteString as B 20 | import System.IO (Handle, stdout, IOMode(..), withFile, Newline(..), nativeNewline) 21 | 22 | encodeUtf8 :: String -> B.ByteString 23 | encodeUtf8 = Encoding.encodeUtf8 . T.pack 24 | 25 | decodeUtf8 :: B.ByteString -> String 26 | decodeUtf8 = T.unpack . Encoding.decodeUtf8With lenientDecode 27 | 28 | encodeText :: String -> B.ByteString 29 | encodeText = encodeUtf8 . encodeNewlines 30 | 31 | decodeText :: B.ByteString -> String 32 | decodeText = decodeNewlines . decodeUtf8 33 | 34 | encodeNewlines :: String -> String 35 | encodeNewlines = case nativeNewline of 36 | LF -> id 37 | CRLF -> go 38 | where 39 | go xs = case xs of 40 | '\n' : ys -> '\r' : '\n' : ys 41 | y : ys -> y : go ys 42 | [] -> [] 43 | 44 | decodeNewlines :: String -> String 45 | decodeNewlines = go 46 | where 47 | go xs = case xs of 48 | '\r' : '\n' : ys -> '\n' : go ys 49 | y : ys -> y : go ys 50 | [] -> [] 51 | 52 | readFile :: FilePath -> IO String 53 | readFile = fmap decodeText . B.readFile 54 | 55 | ensureFile :: FilePath -> String -> IO () 56 | ensureFile name new = do 57 | try (readFile name) >>= \ case 58 | Left (_ :: IOException) -> do 59 | withFile name WriteMode (`hPutStr` new) 60 | Right old -> unless (old == new) $ do 61 | withFile name WriteMode (`hPutStr` new) 62 | 63 | putStr :: String -> IO () 64 | putStr = hPutStr stdout 65 | 66 | hPutStrLn :: Handle -> String -> IO () 67 | hPutStrLn h xs = hPutStr h xs >> hPutStr h "\n" 68 | 69 | hPutStr :: Handle -> String -> IO () 70 | hPutStr h = B.hPutStr h . encodeText 71 | -------------------------------------------------------------------------------- /src/Hpack/Util.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | module Hpack.Util ( 3 | GhcOption 4 | , GhcProfOption 5 | , GhcjsOption 6 | , CppOption 7 | , AsmOption 8 | , CcOption 9 | , CxxOption 10 | , LdOption 11 | , parseMain 12 | 13 | , tryReadFile 14 | , expandGlobs 15 | , sort 16 | , lexicographically 17 | , Hash 18 | , sha256 19 | 20 | , nub 21 | , nubOn 22 | ) where 23 | 24 | import Imports 25 | 26 | import Control.Exception 27 | import Data.Char 28 | import Data.Ord 29 | import qualified Data.Set as Set 30 | import System.IO.Error 31 | import System.Directory 32 | import System.FilePath 33 | import qualified System.FilePath.Posix as Posix 34 | import System.FilePath.Glob 35 | import Crypto.Hash 36 | 37 | import Hpack.Haskell 38 | import Hpack.Utf8 as Utf8 39 | 40 | sort :: [String] -> [String] 41 | sort = sortBy (comparing lexicographically) 42 | 43 | lexicographically :: String -> (String, String) 44 | lexicographically x = (map toLower x, x) 45 | 46 | type GhcOption = String 47 | type GhcProfOption = String 48 | type GhcjsOption = String 49 | type CppOption = String 50 | type AsmOption = String 51 | type CcOption = String 52 | type CxxOption = String 53 | type LdOption = String 54 | 55 | parseMain :: String -> (FilePath, [GhcOption]) 56 | parseMain main = case reverse name of 57 | x : _ | isQualifiedIdentifier name && x `notElem` ["hs", "lhs"] -> (intercalate "/" (init name) ++ ".hs", ["-main-is " ++ main]) 58 | _ | isModule name -> (intercalate "/" name ++ ".hs", ["-main-is " ++ main]) 59 | _ -> (main, []) 60 | where 61 | name = splitOn '.' main 62 | 63 | splitOn :: Char -> String -> [String] 64 | splitOn c = go 65 | where 66 | go xs = case break (== c) xs of 67 | (ys, "") -> [ys] 68 | (ys, _:zs) -> ys : go zs 69 | 70 | tryReadFile :: FilePath -> IO (Maybe String) 71 | tryReadFile file = do 72 | r <- tryJust (guard . isDoesNotExistError) (Utf8.readFile file) 73 | return $ either (const Nothing) Just r 74 | 75 | toPosixFilePath :: FilePath -> FilePath 76 | toPosixFilePath = Posix.joinPath . splitDirectories 77 | 78 | data GlobResult = GlobResult { 79 | _globResultPattern :: String 80 | , _globResultCompiledPattern :: Pattern 81 | , _globResultFiles :: [FilePath] 82 | } 83 | 84 | expandGlobs :: String -> FilePath -> [String] -> IO ([String], [FilePath]) 85 | expandGlobs name dir patterns = do 86 | files <- globDir compiledPatterns dir >>= mapM removeDirectories 87 | let 88 | results :: [GlobResult] 89 | results = map (uncurry $ uncurry GlobResult) $ zip (zip patterns compiledPatterns) (map sort files) 90 | return (combineResults results) 91 | where 92 | combineResults :: [GlobResult] -> ([String], [FilePath]) 93 | combineResults = bimap concat (nub . concat) . unzip . map fromResult 94 | 95 | fromResult :: GlobResult -> ([String], [FilePath]) 96 | fromResult (GlobResult pattern compiledPattern files) = case files of 97 | [] -> (warning, literalFile) 98 | xs -> ([], map normalize xs) 99 | where 100 | warning = [warn pattern compiledPattern] 101 | literalFile 102 | | isLiteral compiledPattern = [pattern] 103 | | otherwise = [] 104 | 105 | normalize :: FilePath -> FilePath 106 | normalize = toPosixFilePath . makeRelative dir 107 | 108 | warn :: String -> Pattern -> String 109 | warn pattern compiledPattern 110 | | isLiteral compiledPattern = "Specified file " ++ show pattern ++ " for " ++ name ++ " does not exist" 111 | | otherwise = "Specified pattern " ++ show pattern ++ " for " ++ name ++ " does not match any files" 112 | 113 | compiledPatterns :: [Pattern] 114 | compiledPatterns = map (compileWith options) patterns 115 | 116 | removeDirectories :: [FilePath] -> IO [FilePath] 117 | removeDirectories = filterM doesFileExist 118 | 119 | options :: CompOptions 120 | options = CompOptions { 121 | characterClasses = False 122 | , characterRanges = False 123 | , numberRanges = False 124 | , wildcards = True 125 | , recursiveWildcards = True 126 | , pathSepInRanges = False 127 | , errorRecovery = True 128 | } 129 | 130 | type Hash = String 131 | 132 | sha256 :: String -> Hash 133 | sha256 c = show (hash (Utf8.encodeUtf8 c) :: Digest SHA256) 134 | 135 | nub :: Ord a => [a] -> [a] 136 | nub = nubOn id 137 | 138 | nubOn :: Ord b => (a -> b) -> [a] -> [a] 139 | nubOn f = go mempty 140 | where 141 | go seen = \ case 142 | [] -> [] 143 | a : as 144 | | b `Set.member` seen -> go seen as 145 | | otherwise -> a : go (Set.insert b seen) as 146 | where 147 | b = f a 148 | -------------------------------------------------------------------------------- /src/Hpack/Yaml.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | module Hpack.Yaml ( 4 | -- | /__NOTE:__/ This module is exposed to allow integration of Hpack into 5 | -- other tools. It is not meant for general use by end users. The following 6 | -- caveats apply: 7 | -- 8 | -- * The API is undocumented, consult the source instead. 9 | -- 10 | -- * The exposed types and functions primarily serve Hpack's own needs, not 11 | -- that of a public API. Breaking changes can happen as Hpack evolves. 12 | -- 13 | -- As an Hpack user you either want to use the @hpack@ executable or a build 14 | -- tool that supports Hpack (e.g. @stack@ or @cabal2nix@). 15 | 16 | decodeYaml 17 | , decodeYamlWithParseError 18 | , ParseException 19 | , formatYamlParseError 20 | , formatWarning 21 | , module Data.Aeson.Config.FromValue 22 | ) where 23 | 24 | import Imports 25 | 26 | import Data.Yaml hiding (decodeFile, decodeFileWithWarnings) 27 | import Data.Yaml.Include 28 | import Data.Yaml.Internal (Warning(..)) 29 | import Data.Aeson.Config.FromValue 30 | import Data.Aeson.Config.Parser (fromAesonPath, formatPath) 31 | 32 | decodeYaml :: FilePath -> IO (Either String ([String], Value)) 33 | decodeYaml file = first (formatYamlParseError file) <$> decodeYamlWithParseError file 34 | 35 | decodeYamlWithParseError :: FilePath -> IO (Either ParseException ([String], Value)) 36 | decodeYamlWithParseError file = do 37 | result <- decodeFileWithWarnings file 38 | return $ fmap (first (map $ formatWarning file)) result 39 | 40 | formatYamlParseError :: FilePath -> ParseException -> String 41 | formatYamlParseError file err = file ++ case err of 42 | AesonException e -> ": " ++ e 43 | InvalidYaml (Just (YamlException s)) -> ": " ++ s 44 | InvalidYaml (Just (YamlParseException{..})) -> ":" ++ show yamlLine ++ ":" ++ show yamlColumn ++ ": " ++ yamlProblem ++ " " ++ yamlContext 45 | where YamlMark{..} = yamlProblemMark 46 | _ -> ": " ++ displayException err 47 | 48 | formatWarning :: FilePath -> Warning -> String 49 | formatWarning file = \ case 50 | DuplicateKey path -> file ++ ": Duplicate field " ++ formatPath (fromAesonPath path) 51 | -------------------------------------------------------------------------------- /src/Imports.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module Imports (module Imports) where 3 | 4 | import Control.Applicative as Imports 5 | import Control.Arrow as Imports ((>>>), (&&&)) 6 | import Control.Exception as Imports (Exception(..)) 7 | import Control.Monad as Imports 8 | import Control.Monad.IO.Class as Imports 9 | import Data.Bifunctor as Imports 10 | #if MIN_VERSION_base(4,20,0) 11 | import Data.List as Imports hiding (List, sort, nub) 12 | #else 13 | import Data.List as Imports hiding (sort, nub) 14 | #endif 15 | import Data.Monoid as Imports (Monoid(..)) 16 | import Data.Semigroup as Imports (Semigroup(..)) 17 | import Data.String as Imports 18 | import Data.Text as Imports (Text) 19 | -------------------------------------------------------------------------------- /src/Path.hs: -------------------------------------------------------------------------------- 1 | module Path where 2 | 3 | import Imports 4 | 5 | import System.FilePath 6 | 7 | fromFilePath :: FilePath -> Path 8 | fromFilePath = Path . map PathComponent . splitDirectories 9 | 10 | toFilePath :: Path -> FilePath 11 | toFilePath = joinPath . components 12 | 13 | components :: Path -> [String] 14 | components = map unPathComponent . unPath 15 | 16 | newtype Path = Path {unPath :: [PathComponent]} 17 | deriving Eq 18 | 19 | instance Show Path where 20 | show = show . toFilePath 21 | 22 | instance IsString Path where 23 | fromString = fromFilePath 24 | 25 | newtype PathComponent = PathComponent {unPathComponent :: String} 26 | deriving Eq 27 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | snapshot: lts-22.25 # GHC 9.6.5 2 | -------------------------------------------------------------------------------- /stack.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: [] 7 | snapshots: 8 | - completed: 9 | sha256: 9b43e51f2c54211993d5954da8b49604704d8288103b8d9150a19a703f4e55e7 10 | size: 719126 11 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/22/25.yaml 12 | original: lts-22.25 13 | -------------------------------------------------------------------------------- /test/Data/Aeson/Config/FromValueSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE DeriveAnyClass #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE ConstraintKinds #-} 6 | {-# LANGUAGE DataKinds #-} 7 | module Data.Aeson.Config.FromValueSpec where 8 | 9 | import Helper 10 | 11 | import GHC.Generics 12 | import qualified Data.Map.Lazy as Map 13 | import Data.Monoid (Last(..)) 14 | 15 | import Data.Aeson.Config.FromValue 16 | 17 | shouldDecodeTo :: (HasCallStack, Eq a, Show a, FromValue a) => Value -> Result a -> Expectation 18 | shouldDecodeTo value expected = decodeValue value `shouldBe` expected 19 | 20 | shouldDecodeTo_ :: (HasCallStack, Eq a, Show a, FromValue a) => Value -> a -> Expectation 21 | shouldDecodeTo_ value expected = decodeValue value `shouldBe` Right (expected, [], []) 22 | 23 | data Person = Person { 24 | personName :: String 25 | , personAge :: Int 26 | , personAddress :: Maybe Address 27 | } deriving (Eq, Show, Generic, FromValue) 28 | 29 | data Address = Address { 30 | addressRegion :: String 31 | , addressZip :: String 32 | } deriving (Eq, Show, Generic, FromValue) 33 | 34 | data Job = Job { 35 | jobRole :: String 36 | , jobSalary :: Int 37 | } deriving (Eq, Show, Generic, FromValue) 38 | 39 | data FlatMaybe = FlatMaybe { 40 | flatMaybeValue :: Maybe String 41 | } deriving (Eq, Show, Generic, FromValue) 42 | 43 | data AliasMaybe = AliasMaybe { 44 | aliasMaybeValue :: Alias 'False "some-alias" (Maybe String) 45 | } deriving (Eq, Show, Generic, FromValue) 46 | 47 | data NestedMaybe = NestedMaybe { 48 | nestedMaybeValue :: Maybe (Maybe String) 49 | } deriving (Eq, Show, Generic, FromValue) 50 | 51 | data AliasNestedMaybe = AliasNestedMaybe { 52 | aliasNestedMaybeValue :: Alias 'False "some-alias" (Maybe (Maybe String)) 53 | } deriving (Eq, Show, Generic, FromValue) 54 | 55 | data FlatLast = FlatLast { 56 | flatLastValue :: Last String 57 | } deriving (Eq, Show, Generic, FromValue) 58 | 59 | data AliasLast = AliasLast { 60 | aliasLastValue :: Alias 'False "some-alias" (Last String) 61 | } deriving (Eq, Show, Generic, FromValue) 62 | 63 | spec :: Spec 64 | spec = do 65 | describe "fromValue" $ do 66 | context "with a record" $ do 67 | let 68 | left :: String -> Result Person 69 | left = Left 70 | it "decodes a record" $ do 71 | [yaml| 72 | name: "Joe" 73 | age: 23 74 | |] `shouldDecodeTo_` Person "Joe" 23 Nothing 75 | 76 | it "captures unrecognized fields" $ do 77 | [yaml| 78 | name: "Joe" 79 | age: 23 80 | foo: bar 81 | |] `shouldDecodeTo` Right (Person "Joe" 23 Nothing, ["$.foo"], []) 82 | 83 | it "captures nested unrecognized fields" $ do 84 | [yaml| 85 | name: "Joe" 86 | age: 23 87 | address: 88 | region: somewhere 89 | zip: "123456" 90 | foo: 91 | bar: 23 92 | |] `shouldDecodeTo` Right (Person "Joe" 23 (Just (Address "somewhere" "123456")), ["$.address.foo"], []) 93 | 94 | it "ignores fields that start with an underscore" $ do 95 | [yaml| 96 | name: "Joe" 97 | age: 23 98 | address: 99 | region: somewhere 100 | zip: "123456" 101 | _foo: 102 | bar: 23 103 | |] `shouldDecodeTo_` Person "Joe" 23 (Just (Address "somewhere" "123456")) 104 | 105 | it "fails on missing field" $ do 106 | [yaml| 107 | name: "Joe" 108 | |] `shouldDecodeTo` left "Error while parsing $ - key \"age\" not present" 109 | 110 | it "fails on invalid field value" $ do 111 | [yaml| 112 | name: "Joe" 113 | age: "23" 114 | |] `shouldDecodeTo` left "Error while parsing $.age - parsing Int failed, expected Number, but encountered String" 115 | 116 | context "when parsing a field of type (Maybe a)" $ do 117 | it "accepts a value" $ do 118 | [yaml| 119 | value: some value 120 | |] `shouldDecodeTo_` FlatMaybe (Just "some value") 121 | 122 | it "allows the field to be omitted" $ do 123 | [yaml| 124 | {} 125 | |] `shouldDecodeTo_` FlatMaybe Nothing 126 | 127 | it "rejects null" $ do 128 | [yaml| 129 | value: null 130 | |] `shouldDecodeTo` (Left "Error while parsing $.value - expected String, but encountered Null" :: Result FlatMaybe) 131 | 132 | context "when parsing a field of type (Maybe (Maybe a))" $ do 133 | it "accepts a value" $ do 134 | [yaml| 135 | value: some value 136 | |] `shouldDecodeTo_` NestedMaybe (Just $ Just "some value") 137 | 138 | it "allows the field to be omitted" $ do 139 | [yaml| 140 | {} 141 | |] `shouldDecodeTo_` NestedMaybe Nothing 142 | 143 | it "accepts null" $ do 144 | [yaml| 145 | value: null 146 | |] `shouldDecodeTo_` NestedMaybe (Just Nothing) 147 | 148 | context "when parsing a field of type (Alias (Maybe a))" $ do 149 | it "accepts a value" $ do 150 | [yaml| 151 | value: some value 152 | |] `shouldDecodeTo_` AliasMaybe (Alias $ Just "some value") 153 | 154 | it "allows the field to be accessed by its alias" $ do 155 | [yaml| 156 | some-alias: some alias value 157 | |] `shouldDecodeTo_` AliasMaybe (Alias $ Just "some alias value") 158 | 159 | it "gives the primary name precedence" $ do 160 | [yaml| 161 | value: some value 162 | some-alias: some alias value 163 | |] `shouldDecodeTo` Right (AliasMaybe (Alias $ Just "some value"), ["$.some-alias"], []) 164 | 165 | it "allows the field to be omitted" $ do 166 | [yaml| 167 | {} 168 | |] `shouldDecodeTo_` AliasMaybe (Alias Nothing) 169 | 170 | it "rejects null" $ do 171 | [yaml| 172 | value: null 173 | |] `shouldDecodeTo` (Left "Error while parsing $.value - expected String, but encountered Null" :: Result AliasMaybe) 174 | 175 | context "when parsing a field of type (Alias (Maybe (Maybe a)))" $ do 176 | it "accepts a value" $ do 177 | [yaml| 178 | value: some value 179 | |] `shouldDecodeTo_` AliasNestedMaybe (Alias . Just $ Just "some value") 180 | 181 | it "allows the field to be accessed by its alias" $ do 182 | [yaml| 183 | some-alias: some value 184 | |] `shouldDecodeTo_` AliasNestedMaybe (Alias . Just $ Just "some value") 185 | 186 | it "gives the primary name precedence" $ do 187 | [yaml| 188 | value: some value 189 | some-alias: some alias value 190 | |] `shouldDecodeTo` Right (AliasNestedMaybe (Alias . Just $ Just "some value"), ["$.some-alias"], []) 191 | 192 | it "allows the field to be omitted" $ do 193 | [yaml| 194 | {} 195 | |] `shouldDecodeTo_` AliasNestedMaybe (Alias Nothing) 196 | 197 | it "accepts null" $ do 198 | [yaml| 199 | value: null 200 | |] `shouldDecodeTo_` AliasNestedMaybe (Alias $ Just Nothing) 201 | 202 | context "when parsing a field of type (Last a)" $ do 203 | it "accepts a value" $ do 204 | [yaml| 205 | value: some value 206 | |] `shouldDecodeTo_` FlatLast (Last $ Just "some value") 207 | 208 | it "allows the field to be omitted" $ do 209 | [yaml| 210 | {} 211 | |] `shouldDecodeTo_` FlatLast (Last Nothing) 212 | 213 | it "rejects null" $ do 214 | [yaml| 215 | value: null 216 | |] `shouldDecodeTo` (Left "Error while parsing $.value - expected String, but encountered Null" :: Result FlatLast) 217 | 218 | context "when parsing a field of type (Alias (Last a))" $ do 219 | it "accepts a value" $ do 220 | [yaml| 221 | value: some value 222 | |] `shouldDecodeTo_` AliasLast (Alias . Last $ Just "some value") 223 | 224 | it "allows the field to be accessed by its alias" $ do 225 | [yaml| 226 | some-alias: some value 227 | |] `shouldDecodeTo_` AliasLast (Alias . Last $ Just "some value") 228 | 229 | it "gives the primary name precedence" $ do 230 | [yaml| 231 | value: some value 232 | some-alias: some alias value 233 | |] `shouldDecodeTo` Right (AliasLast (Alias . Last $ Just "some value"), ["$.some-alias"], []) 234 | 235 | it "allows the field to be omitted" $ do 236 | [yaml| 237 | {} 238 | |] `shouldDecodeTo_` AliasLast (Alias $ Last Nothing) 239 | 240 | it "rejects null" $ do 241 | [yaml| 242 | value: null 243 | |] `shouldDecodeTo` (Left "Error while parsing $.value - expected String, but encountered Null" :: Result AliasLast) 244 | 245 | context "with (,)" $ do 246 | it "captures unrecognized fields" $ do 247 | [yaml| 248 | name: Joe 249 | age: 23 250 | role: engineer 251 | salary: 100000 252 | foo: bar 253 | |] `shouldDecodeTo` Right ((Person "Joe" 23 Nothing, Job "engineer" 100000), ["$.foo"], []) 254 | 255 | context "with []" $ do 256 | it "captures unrecognized fields" $ do 257 | let 258 | expected = [Person "Joe" 23 (Just (Address "somewhere" "123456")), Person "Marry" 25 Nothing] 259 | [yaml| 260 | - name: "Joe" 261 | age: 23 262 | address: 263 | region: somewhere 264 | zip: "123456" 265 | foo: 23 266 | - name: "Marry" 267 | age: 25 268 | bar: 42 269 | |] `shouldDecodeTo` Right (expected, ["$[1].bar", "$[0].address.foo"], []) 270 | 271 | context "with Map" $ do 272 | it "captures unrecognized fields" $ do 273 | [yaml| 274 | Joe: 275 | region: somewhere 276 | zip: '123456' 277 | foo: bar 278 | |] `shouldDecodeTo` Right (Map.fromList [("Joe", Address "somewhere" "123456")], ["$.Joe.foo"], []) 279 | -------------------------------------------------------------------------------- /test/Data/Aeson/Config/TypesSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes #-} 2 | module Data.Aeson.Config.TypesSpec (spec) where 3 | 4 | import Helper 5 | import Data.Aeson.Config.FromValueSpec (shouldDecodeTo, shouldDecodeTo_) 6 | 7 | import Data.Aeson.Config.FromValue 8 | import Data.Aeson.Config.Types 9 | 10 | spec :: Spec 11 | spec = do 12 | describe "fromValue" $ do 13 | context "List" $ do 14 | let 15 | parseError :: String -> Result (List Int) 16 | parseError prefix = Left (prefix ++ " - parsing Int failed, expected Number, but encountered String") 17 | 18 | context "when parsing single values" $ do 19 | it "returns the value in a singleton list" $ do 20 | [yaml|23|] `shouldDecodeTo_` (List [23 :: Int]) 21 | 22 | it "returns error messages from element parsing" $ do 23 | [yaml|foo|] `shouldDecodeTo` parseError "Error while parsing $" 24 | 25 | context "when parsing a list of values" $ do 26 | it "returns the list" $ do 27 | [yaml| 28 | - 23 29 | - 42 30 | |] `shouldDecodeTo_` List [23, 42 :: Int] 31 | 32 | it "propagates parse error messages of invalid elements" $ do 33 | [yaml| 34 | - 23 35 | - foo 36 | |] `shouldDecodeTo` parseError "Error while parsing $[1]" 37 | -------------------------------------------------------------------------------- /test/Data/Aeson/Config/UtilSpec.hs: -------------------------------------------------------------------------------- 1 | module Data.Aeson.Config.UtilSpec (spec) where 2 | 3 | import Test.Hspec 4 | 5 | import Data.Aeson.Config.Util 6 | 7 | spec :: Spec 8 | spec = do 9 | describe "hyphenize" $ do 10 | it "hyphenizes" $ do 11 | hyphenize "" "personFirstName" `shouldBe` "person-first-name" 12 | 13 | it "ignores leading underscores" $ do 14 | hyphenize "" "__personFirstName" `shouldBe` "person-first-name" 15 | 16 | context "when given a type name" $ do 17 | it "strips type name" $ do 18 | hyphenize "Person" "personFirstName" `shouldBe` "first-name" 19 | 20 | it "ignores trailing underscores in type name" $ do 21 | hyphenize "Person__" "personFirstName" `shouldBe` "first-name" 22 | -------------------------------------------------------------------------------- /test/Helper.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE ConstraintKinds #-} 3 | {-# OPTIONS_GHC -fno-warn-orphans #-} 4 | module Helper ( 5 | module Imports 6 | , module Test.Hspec 7 | , module Test.Mockery.Directory 8 | , module Control.Monad 9 | , module Control.Applicative 10 | , withTempDirectory 11 | , module System.FilePath 12 | , withCurrentDirectory 13 | , yaml 14 | , makeVersion 15 | ) where 16 | 17 | import Imports 18 | 19 | import Test.Hspec 20 | import Test.Mockery.Directory 21 | import Control.Monad 22 | import Control.Applicative 23 | import Data.Version (Version(..)) 24 | import System.Directory (getCurrentDirectory, setCurrentDirectory, canonicalizePath) 25 | import Control.Exception 26 | import qualified System.IO.Temp as Temp 27 | import System.FilePath 28 | 29 | import Data.Yaml.TH (yamlQQ) 30 | import Language.Haskell.TH.Quote (QuasiQuoter) 31 | 32 | import Hpack.Config 33 | 34 | instance IsString Cond where 35 | fromString = CondExpression 36 | 37 | withCurrentDirectory :: FilePath -> IO a -> IO a 38 | withCurrentDirectory dir action = do 39 | bracket getCurrentDirectory setCurrentDirectory $ \ _ -> do 40 | setCurrentDirectory dir 41 | action 42 | 43 | withTempDirectory :: (FilePath -> IO a) -> IO a 44 | withTempDirectory action = Temp.withSystemTempDirectory "hspec" $ \dir -> do 45 | canonicalizePath dir >>= action 46 | 47 | yaml :: Language.Haskell.TH.Quote.QuasiQuoter 48 | yaml = yamlQQ 49 | 50 | makeVersion :: [Int] -> Version 51 | makeVersion v = Version v [] 52 | -------------------------------------------------------------------------------- /test/Hpack/CabalFileSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes #-} 2 | module Hpack.CabalFileSpec (spec) where 3 | 4 | import Helper 5 | import Test.QuickCheck 6 | import Data.Version (showVersion) 7 | import Data.String.Interpolate 8 | import Data.String.Interpolate.Util 9 | 10 | import Paths_hpack (version) 11 | 12 | import Hpack.Util (Hash) 13 | import Data.Version (Version) 14 | import Hpack (header) 15 | 16 | import Hpack.CabalFile 17 | 18 | mkHeader :: FilePath -> Version -> Hash -> String 19 | mkHeader p v hash = unlines $ header p (Just v) (Just hash) 20 | 21 | spec :: Spec 22 | spec = do 23 | describe "readCabalFile" $ do 24 | let 25 | file = "hello.cabal" 26 | hash = "some-hash" 27 | 28 | it "includes hash" $ do 29 | inTempDirectory $ do 30 | writeFile file $ mkHeader "package.yaml" version hash 31 | readCabalFile file `shouldReturn` Just (CabalFile [] (Just version) (Just hash) [] DoesNotHaveGitConflictMarkers) 32 | 33 | it "accepts cabal-version at the beginning of the file" $ do 34 | inTempDirectory $ do 35 | writeFile file $ ("cabal-version: 2.2\n" ++ mkHeader "package.yaml" version hash) 36 | readCabalFile file `shouldReturn` Just (CabalFile ["cabal-version: 2.2"] (Just version) (Just hash) [] DoesNotHaveGitConflictMarkers) 37 | 38 | describe "extractVersion" $ do 39 | it "extracts Hpack version from a cabal file" $ do 40 | let cabalFile = ["-- This file has been generated from package.yaml by hpack version 0.10.0."] 41 | extractVersion cabalFile `shouldBe` Just (makeVersion [0, 10, 0]) 42 | 43 | it "is agnostic to file name" $ do 44 | let cabalFile = ["-- This file has been generated from some random file by hpack version 0.10.0."] 45 | extractVersion cabalFile `shouldBe` Just (makeVersion [0, 10, 0]) 46 | 47 | it "is total" $ do 48 | let cabalFile = ["-- This file has been generated from package.yaml by hpack version "] 49 | extractVersion cabalFile `shouldBe` Nothing 50 | 51 | describe "parseVersion" $ do 52 | it "is inverse to showVersion" $ do 53 | let positive = getPositive <$> arbitrary 54 | forAll (replicateM 3 positive) $ \xs -> do 55 | let v = makeVersion xs 56 | parseVersion (showVersion v) `shouldBe` Just v 57 | 58 | describe "removeGitConflictMarkers" $ do 59 | it "remove git conflict markers (git checkout --ours)" $ do 60 | let 61 | input = lines $ unindent [i| 62 | foo 63 | <<<<<<< 4a1ca1694ed77195a080688df9bef53c23045211 64 | bar2 65 | ======= 66 | bar1 67 | >>>>>>> update foo on branch foo 68 | baz 69 | |] 70 | expected = lines $ unindent [i| 71 | foo 72 | bar2 73 | baz 74 | |] 75 | removeGitConflictMarkers input `shouldBe` expected 76 | -------------------------------------------------------------------------------- /test/Hpack/DefaultsSpec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-name-shadowing #-} 2 | module Hpack.DefaultsSpec (spec) where 3 | 4 | import Helper 5 | import System.Directory 6 | 7 | import Hpack.Error 8 | import Hpack.Syntax.Defaults 9 | import Hpack.Defaults 10 | 11 | spec :: Spec 12 | spec = do 13 | describe "ensure" $ do 14 | it "fails when local file does not exist" $ do 15 | cwd <- getCurrentDirectory 16 | let expected = Left (DefaultsFileNotFound $ cwd "foo") 17 | ensure undefined cwd (DefaultsLocal $ Local "foo") `shouldReturn` expected 18 | 19 | describe "ensureFile" $ do 20 | let 21 | file = "foo" 22 | url = "https://raw.githubusercontent.com/sol/hpack/master/Setup.lhs" 23 | 24 | it "downloads file if missing" $ do 25 | expected <- readFile "Setup.lhs" 26 | inTempDirectory $ do 27 | Found <- ensureFile file url 28 | readFile file `shouldReturn` expected 29 | 30 | context "with existing file" $ do 31 | it "does nothing" $ do 32 | let expected = "contents of existing file" 33 | inTempDirectory $ do 34 | writeFile file expected 35 | Found <- ensureFile file url 36 | readFile file `shouldReturn` expected 37 | 38 | context "with 404" $ do 39 | let 40 | url = "https://raw.githubusercontent.com/sol/hpack/master/Setup.foo" 41 | 42 | it "does not create any files" $ do 43 | inTempDirectory $ do 44 | NotFound <- ensureFile file url 45 | doesFileExist file `shouldReturn` False 46 | -------------------------------------------------------------------------------- /test/Hpack/HaskellSpec.hs: -------------------------------------------------------------------------------- 1 | module Hpack.HaskellSpec (spec) where 2 | 3 | import Test.Hspec 4 | 5 | import Hpack.Haskell 6 | 7 | spec :: Spec 8 | spec = do 9 | describe "isModule" $ do 10 | it "accepts module names" $ do 11 | isModule ["Foo", "Bar"] `shouldBe` True 12 | 13 | it "rejects the empty list" $ do 14 | isModule [] `shouldBe` False 15 | 16 | describe "isQualifiedIdentifier" $ do 17 | it "accepts qualified Haskell identifiers" $ do 18 | isQualifiedIdentifier ["Foo", "Bar", "baz"] `shouldBe` True 19 | 20 | it "rejects invalid input" $ do 21 | isQualifiedIdentifier ["Foo", "Bar", "Baz"] `shouldBe` False 22 | 23 | describe "isIdentifier" $ do 24 | it "accepts Haskell identifiers" $ do 25 | isIdentifier "foo" `shouldBe` True 26 | 27 | it "rejects reserved keywords" $ do 28 | isIdentifier "case" `shouldBe` False 29 | 30 | it "rejects invalid input" $ do 31 | isIdentifier "Foo" `shouldBe` False 32 | -------------------------------------------------------------------------------- /test/Hpack/LicenseSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE QuasiQuotes #-} 3 | module Hpack.LicenseSpec (spec) where 4 | 5 | import Helper 6 | import Data.Maybe 7 | import Data.String.Interpolate 8 | 9 | import Distribution.Pretty (prettyShow) 10 | import Distribution.Parsec (simpleParsec) 11 | import qualified Distribution.License as Cabal 12 | 13 | import Hpack.License 14 | 15 | cabal :: String -> Cabal.License 16 | cabal = fromJust . simpleParsec 17 | 18 | cabalLicenses :: [(String, License String)] 19 | cabalLicenses = [ 20 | ("GPL", CanSPDX (cabal "GPL") "LicenseRef-GPL") 21 | , ("GPL-2", CanSPDX (cabal "GPL-2") "GPL-2.0-only") 22 | , ("GPL-3", CanSPDX (cabal "GPL-3") "GPL-3.0-only") 23 | 24 | , ("LGPL", CanSPDX (cabal "LGPL") "LicenseRef-LGPL") 25 | , ("LGPL-2.1", CanSPDX (cabal "LGPL-2.1") "LGPL-2.1-only") 26 | , ("LGPL-3", CanSPDX (cabal "LGPL-3") "LGPL-3.0-only") 27 | 28 | , ("AGPL", CanSPDX (cabal "AGPL") "LicenseRef-AGPL") 29 | , ("AGPL-3", CanSPDX (cabal "AGPL-3") "AGPL-3.0-only") 30 | 31 | 32 | , ("BSD2", CanSPDX (cabal "BSD2") "BSD-2-Clause") 33 | , ("BSD3", CanSPDX (cabal "BSD3") "BSD-3-Clause") 34 | , ("BSD4", CanSPDX (cabal "BSD4") "BSD-4-Clause") 35 | 36 | , ("MIT", CanSPDX (cabal "MIT") "MIT") 37 | , ("ISC", CanSPDX (cabal "ISC") "ISC") 38 | 39 | , ("MPL-2.0", CanSPDX (cabal "MPL-2.0") "MPL-2.0") 40 | 41 | , ("Apache", CanSPDX (cabal "Apache") "LicenseRef-Apache") 42 | , ("Apache-2.0", CanSPDX (cabal "Apache-2.0") "Apache-2.0") 43 | 44 | , ("PublicDomain", CanSPDX (cabal "PublicDomain") "LicenseRef-PublicDomain") 45 | , ("OtherLicense", CanSPDX (cabal "OtherLicense") "LicenseRef-OtherLicense") 46 | , ("AllRightsReserved", CanSPDX (cabal "AllRightsReserved") "NONE") 47 | ] 48 | 49 | spdxLicenses :: [(String, License String)] 50 | spdxLicenses = [ 51 | ("GPL-2.0-or-later", MustSPDX "GPL-2.0-or-later") 52 | ] 53 | 54 | unknownLicenses :: [(String, License String)] 55 | unknownLicenses = [ 56 | ("some-license", DontTouch "some-license") 57 | ] 58 | 59 | spec :: Spec 60 | spec = do 61 | describe "parseLicense" $ do 62 | forM_ (cabalLicenses ++ spdxLicenses ++ unknownLicenses) $ \ (license, expected) -> do 63 | it [i|parses #{license}|] $ do 64 | prettyShow <$> parseLicense license `shouldBe` expected 65 | -------------------------------------------------------------------------------- /test/Hpack/ModuleSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Hpack.ModuleSpec (spec) where 3 | 4 | import Helper 5 | 6 | import Hpack.Module 7 | 8 | spec :: Spec 9 | spec = do 10 | describe "getModules" $ around withTempDirectory $ do 11 | it "returns Haskell modules in specified source directory" $ \dir -> do 12 | touch (dir "src/Foo.hs") 13 | touch (dir "src/Bar/Baz.hs") 14 | touch (dir "src/Setup.hs") 15 | getModules dir "src" >>= (`shouldMatchList` ["Foo", "Bar.Baz", "Setup"]) 16 | 17 | context "when source directory is '.'" $ do 18 | it "ignores Setup" $ \dir -> do 19 | touch (dir "Foo.hs") 20 | touch (dir "Setup.hs") 21 | getModules dir "." `shouldReturn` ["Foo"] 22 | 23 | context "when source directory is './.'" $ do 24 | it "ignores Setup" $ \dir -> do 25 | touch (dir "Foo.hs") 26 | touch (dir "Setup.hs") 27 | getModules dir "./." `shouldReturn` ["Foo"] 28 | 29 | describe "toModule" $ do 30 | it "maps a Path to a Module" $ do 31 | toModule "Foo/Bar/Baz.hs" `shouldBe` "Foo.Bar.Baz" 32 | 33 | describe "getModuleFilesRecursive" $ do 34 | it "gets all Haskell source files from given directory" $ do 35 | inTempDirectory $ do 36 | touch "foo/Bar.hs" 37 | touch "foo/Baz.chs" 38 | actual <- getModuleFilesRecursive "foo" 39 | actual `shouldMatchList` [ 40 | "Bar.hs" 41 | , "Baz.chs" 42 | ] 43 | 44 | it "ignores other files" $ do 45 | inTempDirectory $ do 46 | touch "foo/Bar.js" 47 | getModuleFilesRecursive "foo" `shouldReturn` [] 48 | 49 | it "descends into subdirectories" $ do 50 | inTempDirectory $ do 51 | touch "foo/Bar/Baz.hs" 52 | getModuleFilesRecursive "foo" `shouldReturn` ["Bar/Baz.hs"] 53 | 54 | context "when a subdirectory is not a valid module name" $ do 55 | it "does not descend" $ do 56 | inTempDirectory $ do 57 | touch "foo/bar/Baz.hs" 58 | getModuleFilesRecursive "foo" `shouldReturn` empty 59 | -------------------------------------------------------------------------------- /test/Hpack/OptionsSpec.hs: -------------------------------------------------------------------------------- 1 | module Hpack.OptionsSpec (spec) where 2 | 3 | import Helper 4 | 5 | import Hpack.Options 6 | 7 | spec :: Spec 8 | spec = do 9 | describe "parseOptions" $ do 10 | let defaultTarget = "package.yaml" 11 | context "with --help" $ do 12 | it "returns Help" $ do 13 | parseOptions defaultTarget ["--help"] `shouldReturn` Help 14 | 15 | context "with --version" $ do 16 | it "returns PrintVersion" $ do 17 | parseOptions defaultTarget ["--version"] `shouldReturn` PrintVersion 18 | 19 | context "by default" $ do 20 | it "returns Run" $ do 21 | parseOptions defaultTarget [] `shouldReturn` Run (ParseOptions Verbose NoForce Nothing False defaultTarget MinimizeDiffs) 22 | 23 | it "includes target" $ do 24 | parseOptions defaultTarget ["foo.yaml"] `shouldReturn` Run (ParseOptions Verbose NoForce Nothing False "foo.yaml" MinimizeDiffs) 25 | 26 | context "with superfluous arguments" $ do 27 | it "returns ParseError" $ do 28 | parseOptions defaultTarget ["foo", "bar"] `shouldReturn` ParseError 29 | 30 | context "with --silent" $ do 31 | it "sets optionsVerbose to NoVerbose" $ do 32 | parseOptions defaultTarget ["--silent"] `shouldReturn` Run (ParseOptions NoVerbose NoForce Nothing False defaultTarget MinimizeDiffs) 33 | 34 | context "with --force" $ do 35 | it "sets optionsForce to Force" $ do 36 | parseOptions defaultTarget ["--force"] `shouldReturn` Run (ParseOptions Verbose Force Nothing False defaultTarget MinimizeDiffs) 37 | 38 | context "with -f" $ do 39 | it "sets optionsForce to Force" $ do 40 | parseOptions defaultTarget ["-f"] `shouldReturn` Run (ParseOptions Verbose Force Nothing False defaultTarget MinimizeDiffs) 41 | 42 | context "when determining parseOptionsHash" $ do 43 | 44 | it "assumes True on --hash" $ do 45 | parseOptions defaultTarget ["--hash"] `shouldReturn` Run (ParseOptions Verbose NoForce (Just True) False defaultTarget MinimizeDiffs) 46 | 47 | it "assumes False on --no-hash" $ do 48 | parseOptions defaultTarget ["--no-hash"] `shouldReturn` Run (ParseOptions Verbose NoForce (Just False) False defaultTarget MinimizeDiffs) 49 | 50 | it "gives last occurrence precedence" $ do 51 | parseOptions defaultTarget ["--no-hash", "--hash"] `shouldReturn` Run (ParseOptions Verbose NoForce (Just True) False defaultTarget MinimizeDiffs) 52 | parseOptions defaultTarget ["--hash", "--no-hash"] `shouldReturn` Run (ParseOptions Verbose NoForce (Just False) False defaultTarget MinimizeDiffs) 53 | 54 | context "with -" $ do 55 | it "sets optionsToStdout to True, implies Force and NoVerbose" $ do 56 | parseOptions defaultTarget ["-"] `shouldReturn` Run (ParseOptions NoVerbose Force Nothing True defaultTarget MinimizeDiffs) 57 | 58 | it "rejects - for target" $ do 59 | parseOptions defaultTarget ["-", "-"] `shouldReturn` ParseError 60 | 61 | describe "expandTarget" $ around_ inTempDirectory $ do 62 | let defaultTarget = "foo.yaml" 63 | context "when target is Nothing" $ do 64 | it "return default file" $ do 65 | expandTarget defaultTarget Nothing `shouldReturn` defaultTarget 66 | 67 | context "when target is a file" $ do 68 | it "return file" $ do 69 | let file = "foo/bar.yaml" 70 | touch file 71 | expandTarget defaultTarget (Just file) `shouldReturn` file 72 | 73 | context "when target is a directory" $ do 74 | it "appends default file" $ do 75 | touch "foo/.placeholder" 76 | expandTarget defaultTarget (Just "foo") `shouldReturn` "foo" defaultTarget 77 | 78 | context "when target file does not exist" $ do 79 | it "return target file" $ do 80 | expandTarget defaultTarget (Just "foo/bar") `shouldReturn` "foo/bar" 81 | 82 | context "when target directory does not exist" $ do 83 | it "appends default file" $ do 84 | expandTarget defaultTarget (Just "foo/") `shouldReturn` ("foo/" ++ defaultTarget) 85 | 86 | context "when target is the empty string" $ do 87 | it "return default file" $ do 88 | expandTarget defaultTarget (Just "") `shouldReturn` defaultTarget 89 | -------------------------------------------------------------------------------- /test/Hpack/Render/DslSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Hpack.Render.DslSpec where 3 | 4 | import Test.Hspec 5 | import Test.QuickCheck 6 | import Data.List 7 | import Data.Maybe 8 | 9 | import Hpack.Render.Dsl 10 | 11 | spec :: Spec 12 | spec = do 13 | describe "render" $ do 14 | let render_ = render defaultRenderSettings 0 15 | context "when rendering a Stanza" $ do 16 | it "renders stanza" $ do 17 | let stanza = Stanza "foo" [ 18 | Field "bar" "23" 19 | , Field "baz" "42" 20 | ] 21 | render_ stanza `shouldBe` [ 22 | "foo" 23 | , " bar: 23" 24 | , " baz: 42" 25 | ] 26 | 27 | it "omits empty fields" $ do 28 | let stanza = Stanza "foo" [ 29 | Field "bar" "23" 30 | , Field "baz" (WordList []) 31 | ] 32 | render_ stanza `shouldBe` [ 33 | "foo" 34 | , " bar: 23" 35 | ] 36 | 37 | it "allows to customize indentation" $ do 38 | let stanza = Stanza "foo" [ 39 | Field "bar" "23" 40 | , Field "baz" "42" 41 | ] 42 | render defaultRenderSettings{renderSettingsIndentation = 4} 0 stanza `shouldBe` [ 43 | "foo" 44 | , " bar: 23" 45 | , " baz: 42" 46 | ] 47 | 48 | it "renders nested stanzas" $ do 49 | let input = Stanza "foo" [Field "bar" "23", Stanza "baz" [Field "qux" "42"]] 50 | render_ input `shouldBe` [ 51 | "foo" 52 | , " bar: 23" 53 | , " baz" 54 | , " qux: 42" 55 | ] 56 | 57 | context "when rendering a Field" $ do 58 | context "when rendering a MultipleLines value" $ do 59 | it "takes nesting into account" $ do 60 | let field = Field "foo" (CommaSeparatedList ["bar", "baz"]) 61 | render defaultRenderSettings 1 field `shouldBe` [ 62 | " foo:" 63 | , " bar" 64 | , " , baz" 65 | ] 66 | 67 | context "when value is empty" $ do 68 | it "returns an empty list" $ do 69 | let field = Field "foo" (CommaSeparatedList []) 70 | render_ field `shouldBe` [] 71 | 72 | context "when rendering a SingleLine value" $ do 73 | it "returns a single line" $ do 74 | let field = Field "foo" (Literal "bar") 75 | render_ field `shouldBe` ["foo: bar"] 76 | 77 | it "takes nesting into account" $ do 78 | let field = Field "foo" (Literal "bar") 79 | render defaultRenderSettings 2 field `shouldBe` [" foo: bar"] 80 | 81 | it "takes alignment into account" $ do 82 | let field = Field "foo" (Literal "bar") 83 | render defaultRenderSettings {renderSettingsFieldAlignment = 10} 0 field `shouldBe` ["foo: bar"] 84 | 85 | context "when value is empty" $ do 86 | it "returns an empty list" $ do 87 | let field = Field "foo" (Literal "") 88 | render_ field `shouldBe` [] 89 | 90 | describe "renderValue" $ do 91 | it "renders WordList" $ do 92 | renderValue defaultRenderSettings (WordList ["foo", "bar", "baz"]) `shouldBe` SingleLine "foo bar baz" 93 | 94 | it "renders CommaSeparatedList" $ do 95 | renderValue defaultRenderSettings (CommaSeparatedList ["foo", "bar", "baz"]) `shouldBe` MultipleLines [ 96 | " foo" 97 | , ", bar" 98 | , ", baz" 99 | ] 100 | 101 | it "renders LineSeparatedList" $ do 102 | renderValue defaultRenderSettings (LineSeparatedList ["foo", "bar", "baz"]) `shouldBe` MultipleLines [ 103 | " foo" 104 | , " bar" 105 | , " baz" 106 | ] 107 | 108 | context "when renderSettingsCommaStyle is TrailingCommas" $ do 109 | let settings = defaultRenderSettings{renderSettingsCommaStyle = TrailingCommas} 110 | 111 | it "renders CommaSeparatedList with trailing commas" $ do 112 | renderValue settings (CommaSeparatedList ["foo", "bar", "baz"]) `shouldBe` MultipleLines [ 113 | "foo," 114 | , "bar," 115 | , "baz" 116 | ] 117 | 118 | it "renders LineSeparatedList without padding" $ do 119 | renderValue settings (LineSeparatedList ["foo", "bar", "baz"]) `shouldBe` MultipleLines [ 120 | "foo" 121 | , "bar" 122 | , "baz" 123 | ] 124 | 125 | describe "sortFieldsBy" $ do 126 | let 127 | field name = Field name (Literal $ name ++ " value") 128 | arbitraryFieldNames = sublistOf ["foo", "bar", "baz", "qux", "foobar", "foobaz"] >>= shuffle 129 | 130 | it "sorts fields" $ do 131 | let fields = map field ["baz", "bar", "foo"] 132 | sortFieldsBy ["foo", "bar", "baz"] fields `shouldBe` map field ["foo", "bar", "baz"] 133 | 134 | it "keeps existing field order" $ do 135 | forAll (map field <$> arbitraryFieldNames) $ \fields -> do 136 | forAll arbitraryFieldNames $ \existingFieldOrder -> do 137 | let 138 | existingIndex :: Element -> Maybe Int 139 | existingIndex (Field name _) = name `elemIndex` existingFieldOrder 140 | existingIndex _ = Nothing 141 | 142 | indexes :: [Int] 143 | indexes = mapMaybe existingIndex (sortFieldsBy existingFieldOrder fields) 144 | 145 | sort indexes `shouldBe` indexes 146 | 147 | it "is stable" $ do 148 | forAll arbitraryFieldNames $ \fieldNames -> do 149 | forAll (elements $ subsequences fieldNames) $ \existingFieldOrder -> do 150 | let fields = map field fieldNames 151 | sortFieldsBy existingFieldOrder fields `shouldBe` fields 152 | 153 | describe "addSortKey" $ do 154 | it "adds sort key" $ do 155 | addSortKey [(Nothing, "foo"), (Just 3, "bar"), (Nothing, "baz")] `shouldBe` [((-1, 0), "foo"), ((3, 1), "bar"), ((3, 2), "baz" :: String)] 156 | -------------------------------------------------------------------------------- /test/Hpack/Render/HintsSpec.hs: -------------------------------------------------------------------------------- 1 | module Hpack.Render.HintsSpec (spec) where 2 | 3 | import Test.Hspec 4 | 5 | import Hpack.Render.Hints 6 | import Hpack.Render.Dsl 7 | 8 | spec :: Spec 9 | spec = do 10 | describe "sniffRenderSettings" $ do 11 | context "when sniffed indentation is < default" $ do 12 | it "uses default instead" $ do 13 | let input = [ 14 | "library" 15 | , "exposed-modules:" 16 | , " Foo" 17 | ] 18 | sniffIndentation input `shouldBe` Just 0 19 | renderSettingsIndentation (sniffRenderSettings input) `shouldBe` 2 20 | 21 | describe "extractFieldOrder" $ do 22 | it "extracts field order hints" $ do 23 | let input = [ 24 | "name: hpack" 25 | , "version: 0.0.0" 26 | , "license:" 27 | , "license-file: " 28 | , "build-type: Simple" 29 | ] 30 | extractFieldOrder input `shouldBe` [ 31 | "name" 32 | , "version" 33 | , "license" 34 | , "license-file" 35 | , "build-type" 36 | ] 37 | 38 | describe "extractSectionsFieldOrder" $ do 39 | it "splits input into sections" $ do 40 | let input = [ 41 | "name: hpack" 42 | , "version: 0.0.0" 43 | , "" 44 | , "library" 45 | , " foo: 23" 46 | , " bar: 42" 47 | , "" 48 | , "executable foo" 49 | , " bar: 23" 50 | , " baz: 42" 51 | ] 52 | extractSectionsFieldOrder input `shouldBe` [("library", ["foo", "bar"]), ("executable foo", ["bar", "baz"])] 53 | 54 | describe "sanitize" $ do 55 | it "removes empty lines" $ do 56 | let input = [ 57 | "foo" 58 | , "" 59 | , " " 60 | , " bar " 61 | , " baz" 62 | ] 63 | sanitize input `shouldBe` [ 64 | "foo" 65 | , " bar" 66 | , " baz" 67 | ] 68 | 69 | it "removes trailing whitespace" $ do 70 | sanitize ["foo ", "bar "] `shouldBe` ["foo", "bar"] 71 | 72 | it "removes cabal-version" $ do 73 | sanitize ["cabal-version: 2.2", "bar "] `shouldBe` ["bar"] 74 | 75 | describe "unindent" $ do 76 | it "unindents" $ do 77 | let input = [ 78 | " foo" 79 | , " bar" 80 | , " baz" 81 | ] 82 | unindent input `shouldBe` [ 83 | " foo" 84 | , "bar" 85 | , " baz" 86 | ] 87 | 88 | describe "sniffAlignment" $ do 89 | it "sniffs field alignment from given cabal file" $ do 90 | let input = [ 91 | "name: hpack" 92 | , "version: 0.0.0" 93 | , "license: MIT" 94 | , "license-file: LICENSE" 95 | , "build-type: Simple" 96 | ] 97 | sniffAlignment input `shouldBe` Just 16 98 | 99 | it "ignores fields without a value on the same line" $ do 100 | let input = [ 101 | "name: hpack" 102 | , "version: 0.0.0" 103 | , "description: " 104 | , " foo" 105 | , " bar" 106 | ] 107 | sniffAlignment input `shouldBe` Just 16 108 | 109 | context "when all fields are padded with exactly one space" $ do 110 | it "returns 0" $ do 111 | let input = [ 112 | "name: hpack" 113 | , "version: 0.0.0" 114 | , "license: MIT" 115 | , "license-file: LICENSE" 116 | , "build-type: Simple" 117 | ] 118 | sniffAlignment input `shouldBe` Just 0 119 | 120 | context "with an empty input list" $ do 121 | it "returns Nothing" $ do 122 | let input = [] 123 | sniffAlignment input `shouldBe` Nothing 124 | 125 | describe "splitField" $ do 126 | it "splits fields" $ do 127 | splitField "foo: bar" `shouldBe` Just ("foo", " bar") 128 | 129 | it "accepts fields names with dashes" $ do 130 | splitField "foo-bar: baz" `shouldBe` Just ("foo-bar", " baz") 131 | 132 | it "rejects fields names with spaces" $ do 133 | splitField "foo bar: baz" `shouldBe` Nothing 134 | 135 | it "rejects invalid fields" $ do 136 | splitField "foo bar" `shouldBe` Nothing 137 | 138 | describe "sniffIndentation" $ do 139 | it "sniffs indentation from executable section" $ do 140 | let input = [ 141 | "name: foo" 142 | , "version: 0.0.0" 143 | , "" 144 | , "executable foo" 145 | , " build-depends: bar" 146 | ] 147 | sniffIndentation input `shouldBe` Just 4 148 | 149 | it "sniffs indentation from library section" $ do 150 | let input = [ 151 | "name: foo" 152 | , "version: 0.0.0" 153 | , "" 154 | , "library" 155 | , " build-depends: bar" 156 | ] 157 | sniffIndentation input `shouldBe` Just 4 158 | 159 | it "ignores empty lines" $ do 160 | let input = [ 161 | "executable foo" 162 | , "" 163 | , " build-depends: bar" 164 | ] 165 | sniffIndentation input `shouldBe` Just 4 166 | 167 | it "ignores whitespace lines" $ do 168 | let input = [ 169 | "executable foo" 170 | , " " 171 | , " build-depends: bar" 172 | ] 173 | sniffIndentation input `shouldBe` Just 4 174 | 175 | describe "sniffCommaStyle" $ do 176 | it "detects leading commas" $ do 177 | let input = [ 178 | "executable foo" 179 | , " build-depends:" 180 | , " bar" 181 | , " , baz" 182 | ] 183 | sniffCommaStyle input `shouldBe` Just LeadingCommas 184 | 185 | it "detects trailing commas" $ do 186 | let input = [ 187 | "executable foo" 188 | , " build-depends:" 189 | , " bar, " 190 | , " baz" 191 | ] 192 | sniffCommaStyle input `shouldBe` Just TrailingCommas 193 | 194 | context "when detection fails" $ do 195 | it "returns Nothing" $ do 196 | sniffCommaStyle [] `shouldBe` Nothing 197 | -------------------------------------------------------------------------------- /test/Hpack/RenderSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE OverloadedLists #-} 3 | module Hpack.RenderSpec (spec) where 4 | 5 | import Helper 6 | 7 | import Control.Monad.Reader (runReader) 8 | 9 | import Hpack.Syntax.DependencyVersion 10 | import Hpack.ConfigSpec hiding (spec) 11 | import Hpack.Config hiding (package) 12 | import Hpack.Render.Dsl 13 | import Hpack.Render 14 | 15 | library :: Library 16 | library = Library Nothing Nothing [] [] [] [] [] 17 | 18 | executable :: Section Executable 19 | executable = (section $ Executable (Just "Main.hs") [] []) { 20 | sectionLanguage = Just $ Language "Haskell2010" 21 | } 22 | 23 | renderEmptySection :: Empty -> [Element] 24 | renderEmptySection Empty = [] 25 | 26 | cabalVersion :: CabalVersion 27 | cabalVersion = makeCabalVersion [1,12] 28 | 29 | cabal30 :: CabalVersion 30 | cabal30 = makeCabalVersion [3,0,0] 31 | 32 | spec :: Spec 33 | spec = do 34 | describe "renderPackageWith" $ do 35 | let renderPackage_ = renderPackageWith defaultRenderSettings 0 [] [] 36 | it "renders a package" $ do 37 | renderPackage_ package `shouldBe` unlines [ 38 | "name: foo" 39 | , "version: 0.0.0" 40 | , "build-type: Simple" 41 | ] 42 | 43 | it "aligns fields" $ do 44 | renderPackageWith defaultRenderSettings 16 [] [] package `shouldBe` unlines [ 45 | "name: foo" 46 | , "version: 0.0.0" 47 | , "build-type: Simple" 48 | ] 49 | 50 | it "includes description" $ do 51 | renderPackage_ package {packageDescription = Just "foo\n\nbar\n"} `shouldBe` unlines [ 52 | "name: foo" 53 | , "version: 0.0.0" 54 | , "description: foo" 55 | , " ." 56 | , " bar" 57 | , "build-type: Simple" 58 | ] 59 | 60 | it "aligns description" $ do 61 | renderPackageWith defaultRenderSettings 16 [] [] package {packageDescription = Just "foo\n\nbar\n"} `shouldBe` unlines [ 62 | "name: foo" 63 | , "version: 0.0.0" 64 | , "description: foo" 65 | , " ." 66 | , " bar" 67 | , "build-type: Simple" 68 | ] 69 | 70 | it "includes stability" $ do 71 | renderPackage_ package {packageStability = Just "experimental"} `shouldBe` unlines [ 72 | "name: foo" 73 | , "version: 0.0.0" 74 | , "stability: experimental" 75 | , "build-type: Simple" 76 | ] 77 | 78 | it "includes license-file" $ do 79 | renderPackage_ package {packageLicenseFile = ["FOO"]} `shouldBe` unlines [ 80 | "name: foo" 81 | , "version: 0.0.0" 82 | , "license-file: FOO" 83 | , "build-type: Simple" 84 | ] 85 | 86 | it "aligns license-files" $ do 87 | renderPackageWith defaultRenderSettings 16 [] [] package {packageLicenseFile = ["FOO", "BAR"]} `shouldBe` unlines [ 88 | "name: foo" 89 | , "version: 0.0.0" 90 | , "license-files: FOO," 91 | , " BAR" 92 | , "build-type: Simple" 93 | ] 94 | 95 | it "includes copyright holder" $ do 96 | renderPackage_ package {packageCopyright = ["(c) 2015 Simon Hengel"]} `shouldBe` unlines [ 97 | "name: foo" 98 | , "version: 0.0.0" 99 | , "copyright: (c) 2015 Simon Hengel" 100 | , "build-type: Simple" 101 | ] 102 | 103 | it "aligns copyright holders" $ do 104 | renderPackageWith defaultRenderSettings 16 [] [] package {packageCopyright = ["(c) 2015 Foo", "(c) 2015 Bar"]} `shouldBe` unlines [ 105 | "name: foo" 106 | , "version: 0.0.0" 107 | , "copyright: (c) 2015 Foo," 108 | , " (c) 2015 Bar" 109 | , "build-type: Simple" 110 | ] 111 | 112 | it "includes extra-source-files" $ do 113 | renderPackage_ package {packageExtraSourceFiles = ["foo", "bar"]} `shouldBe` unlines [ 114 | "name: foo" 115 | , "version: 0.0.0" 116 | , "build-type: Simple" 117 | , "extra-source-files:" 118 | , " foo" 119 | , " bar" 120 | ] 121 | 122 | it "includes buildable" $ do 123 | renderPackage_ package {packageLibrary = Just (section library){sectionBuildable = Just False}} `shouldBe` unlines [ 124 | "name: foo" 125 | , "version: 0.0.0" 126 | , "build-type: Simple" 127 | , "" 128 | , "library" 129 | , " buildable: False" 130 | ] 131 | 132 | context "when given list of existing fields" $ do 133 | it "retains field order" $ do 134 | renderPackageWith defaultRenderSettings 16 ["version", "build-type", "name"] [] package `shouldBe` unlines [ 135 | "version: 0.0.0" 136 | , "build-type: Simple" 137 | , "name: foo" 138 | ] 139 | 140 | it "uses default field order for new fields" $ do 141 | renderPackageWith defaultRenderSettings 16 [] [] package `shouldBe` unlines [ 142 | "name: foo" 143 | , "version: 0.0.0" 144 | , "build-type: Simple" 145 | ] 146 | 147 | it "retains section field order" $ do 148 | renderPackageWith defaultRenderSettings 0 [] [("executable foo", ["default-language", "main-is", "ghc-options"])] package {packageExecutables = [("foo", executable {sectionGhcOptions = ["-Wall", "-Werror"]})]} `shouldBe` unlines [ 149 | "name: foo" 150 | , "version: 0.0.0" 151 | , "build-type: Simple" 152 | , "" 153 | , "executable foo" 154 | , " default-language: Haskell2010" 155 | , " main-is: Main.hs" 156 | , " ghc-options: -Wall -Werror" 157 | ] 158 | 159 | context "when rendering executable section" $ do 160 | it "includes dependencies" $ do 161 | let dependencies = Dependencies 162 | [ ("foo", defaultInfo { dependencyInfoVersion = versionRange "== 0.1.0" }) 163 | , ("bar", defaultInfo) 164 | ] 165 | renderPackage_ package {packageExecutables = [("foo", executable {sectionDependencies = dependencies})]} `shouldBe` unlines [ 166 | "name: foo" 167 | , "version: 0.0.0" 168 | , "build-type: Simple" 169 | , "" 170 | , "executable foo" 171 | , " main-is: Main.hs" 172 | , " build-depends:" 173 | , " bar" 174 | , " , foo == 0.1.0" 175 | , " default-language: Haskell2010" 176 | ] 177 | 178 | it "includes GHC options" $ do 179 | renderPackage_ package {packageExecutables = [("foo", executable {sectionGhcOptions = ["-Wall", "-Werror"]})]} `shouldBe` unlines [ 180 | "name: foo" 181 | , "version: 0.0.0" 182 | , "build-type: Simple" 183 | , "" 184 | , "executable foo" 185 | , " main-is: Main.hs" 186 | , " ghc-options: -Wall -Werror" 187 | , " default-language: Haskell2010" 188 | ] 189 | 190 | it "includes frameworks" $ do 191 | renderPackage_ package {packageExecutables = [("foo", executable {sectionFrameworks = ["foo", "bar"]})]} `shouldBe` unlines [ 192 | "name: foo" 193 | , "version: 0.0.0" 194 | , "build-type: Simple" 195 | , "" 196 | , "executable foo" 197 | , " main-is: Main.hs" 198 | , " frameworks:" 199 | , " foo" 200 | , " bar" 201 | , " default-language: Haskell2010" 202 | ] 203 | 204 | it "includes extra-framework-dirs" $ do 205 | renderPackage_ package {packageExecutables = [("foo", executable {sectionExtraFrameworksDirs = ["foo", "bar"]})]} `shouldBe` unlines [ 206 | "name: foo" 207 | , "version: 0.0.0" 208 | , "build-type: Simple" 209 | , "" 210 | , "executable foo" 211 | , " main-is: Main.hs" 212 | , " extra-frameworks-dirs:" 213 | , " foo" 214 | , " bar" 215 | , " default-language: Haskell2010" 216 | ] 217 | 218 | it "includes GHC profiling options" $ do 219 | renderPackage_ package {packageExecutables = [("foo", executable {sectionGhcProfOptions = ["-fprof-auto", "-rtsopts"]})]} `shouldBe` unlines [ 220 | "name: foo" 221 | , "version: 0.0.0" 222 | , "build-type: Simple" 223 | , "" 224 | , "executable foo" 225 | , " main-is: Main.hs" 226 | , " ghc-prof-options: -fprof-auto -rtsopts" 227 | , " default-language: Haskell2010" 228 | ] 229 | 230 | describe "renderConditional" $ do 231 | let run = flip runReader (RenderEnv cabalVersion "foo") 232 | 233 | it "renders conditionals" $ do 234 | let conditional = Conditional "os(windows)" (section Empty) {sectionDependencies = deps ["Win32"]} Nothing 235 | render defaultRenderSettings 0 (run $ renderConditional renderEmptySection conditional) `shouldBe` [ 236 | "if os(windows)" 237 | , " build-depends:" 238 | , " Win32" 239 | ] 240 | 241 | it "renders conditionals with else-branch" $ do 242 | let conditional = Conditional "os(windows)" (section Empty) {sectionDependencies = deps ["Win32"]} (Just $ (section Empty) {sectionDependencies = deps ["unix"]}) 243 | render defaultRenderSettings 0 (run $ renderConditional renderEmptySection conditional) `shouldBe` [ 244 | "if os(windows)" 245 | , " build-depends:" 246 | , " Win32" 247 | , "else" 248 | , " build-depends:" 249 | , " unix" 250 | ] 251 | 252 | it "renders nested conditionals" $ do 253 | let conditional = Conditional "arch(i386)" (section Empty) {sectionGhcOptions = ["-threaded"], sectionConditionals = [innerConditional]} Nothing 254 | innerConditional = Conditional "os(windows)" (section Empty) {sectionDependencies = deps ["Win32"]} Nothing 255 | render defaultRenderSettings 0 (run $ renderConditional renderEmptySection conditional) `shouldBe` [ 256 | "if arch(i386)" 257 | , " ghc-options: -threaded" 258 | , " if os(windows)" 259 | , " build-depends:" 260 | , " Win32" 261 | ] 262 | 263 | it "conditionalises both build-depends and mixins" $ do 264 | let conditional = Conditional "os(windows)" (section Empty) {sectionDependencies = [("Win32", depInfo)]} Nothing 265 | depInfo = defaultInfo { dependencyInfoMixins = ["hiding (Blah)"] } 266 | render defaultRenderSettings 0 (run $ renderConditional renderEmptySection conditional) `shouldBe` [ 267 | "if os(windows)" 268 | , " build-depends:" 269 | , " Win32" 270 | , " mixins:" 271 | , " Win32 hiding (Blah)" 272 | ] 273 | 274 | describe "renderFlag" $ do 275 | it "renders flags" $ do 276 | let flag = (Flag "foo" (Just "some flag") True False) 277 | render defaultRenderSettings 0 (renderFlag flag) `shouldBe` [ 278 | "flag foo" 279 | , " description: some flag" 280 | , " manual: True" 281 | , " default: False" 282 | ] 283 | 284 | describe "formatDescription" $ do 285 | it "formats description" $ do 286 | let description = unlines [ 287 | "foo" 288 | , "bar" 289 | ] 290 | "description: " ++ formatDescription cabalVersion 0 description `shouldBe` intercalate "\n" [ 291 | "description: foo" 292 | , " bar" 293 | ] 294 | 295 | it "takes specified alignment into account" $ do 296 | let description = unlines [ 297 | "foo" 298 | , "bar" 299 | , "baz" 300 | ] 301 | "description: " ++ formatDescription cabalVersion 15 description `shouldBe` intercalate "\n" [ 302 | "description: foo" 303 | , " bar" 304 | , " baz" 305 | ] 306 | 307 | it "formats empty lines" $ do 308 | let description = unlines [ 309 | "foo" 310 | , " " 311 | , "bar" 312 | ] 313 | "description: " ++ formatDescription cabalVersion 0 description `shouldBe` intercalate "\n" [ 314 | "description: foo" 315 | , " ." 316 | , " bar" 317 | ] 318 | 319 | it "correctly handles empty lines at the beginning" $ do 320 | let description = unlines [ 321 | "" 322 | , "foo" 323 | , "bar" 324 | ] 325 | "description: " ++ formatDescription cabalVersion 0 description `shouldBe` intercalate "\n" [ 326 | "description: ." 327 | , " foo" 328 | , " bar" 329 | ] 330 | 331 | context "when cabal-version is >= 3" $ do 332 | it "preserves empty lines" $ do 333 | let description = unlines [ 334 | "foo" 335 | , "" 336 | , "bar" 337 | ] 338 | "description: " ++ formatDescription cabal30 0 description `shouldBe` intercalate "\n" [ 339 | "description: foo" 340 | , "" 341 | , " bar" 342 | ] 343 | 344 | describe "renderSourceRepository" $ do 345 | it "renders source-repository without subdir correctly" $ do 346 | let repository = SourceRepository "https://github.com/hspec/hspec" Nothing 347 | (render defaultRenderSettings 0 $ renderSourceRepository repository) 348 | `shouldBe` [ 349 | "source-repository head" 350 | , " type: git" 351 | , " location: https://github.com/hspec/hspec" 352 | ] 353 | 354 | it "renders source-repository with subdir" $ do 355 | let repository = SourceRepository "https://github.com/hspec/hspec" (Just "hspec-core") 356 | (render defaultRenderSettings 0 $ renderSourceRepository repository) 357 | `shouldBe` [ 358 | "source-repository head" 359 | , " type: git" 360 | , " location: https://github.com/hspec/hspec" 361 | , " subdir: hspec-core" 362 | ] 363 | 364 | describe "renderDirectories" $ do 365 | it "replaces . with ./. (for compatibility with cabal syntax)" $ do 366 | (render defaultRenderSettings 0 $ renderDirectories "name" ["."]) 367 | `shouldBe` [ 368 | "name:" 369 | , " ./" 370 | ] 371 | 372 | describe "renderDependencies" $ do 373 | it "renders build-depends" $ do 374 | let deps_ = 375 | [ ("foo", DependencyInfo [] anyVersion) 376 | ] 377 | renderDependencies "build-depends" deps_ `shouldBe` 378 | [ Field "build-depends" $ CommaSeparatedList 379 | [ "foo" 380 | ] 381 | , Field "mixins" $ CommaSeparatedList [] 382 | ] 383 | 384 | it "renders build-depends with versions" $ do 385 | let deps_ = 386 | [ ("foo", DependencyInfo [] (versionRange ">= 2 && < 3")) 387 | ] 388 | renderDependencies "build-depends" deps_ `shouldBe` 389 | [ Field "build-depends" $ CommaSeparatedList 390 | [ "foo >= 2 && < 3" 391 | ] 392 | , Field "mixins" $ CommaSeparatedList [] 393 | ] 394 | 395 | it "renders mixins and build-depends for multiple modules" $ do 396 | let deps_ = 397 | [ ("foo", DependencyInfo ["(Foo as Foo1)"] anyVersion) 398 | , ("bar", DependencyInfo ["hiding (Spam)", "(Spam as Spam1) requires (Mod as Sig)"] anyVersion) 399 | ] 400 | renderDependencies "build-depends" deps_ `shouldBe` 401 | [ Field "build-depends" $ CommaSeparatedList 402 | [ "bar" 403 | , "foo" 404 | ] 405 | , Field "mixins" $ CommaSeparatedList 406 | [ "bar hiding (Spam)" 407 | , "bar (Spam as Spam1) requires (Mod as Sig)" 408 | , "foo (Foo as Foo1)" 409 | ] 410 | ] 411 | -------------------------------------------------------------------------------- /test/Hpack/Syntax/BuildToolsSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes #-} 2 | {-# LANGUAGE OverloadedLists #-} 3 | module Hpack.Syntax.BuildToolsSpec (spec) where 4 | 5 | import Helper 6 | 7 | import Data.Aeson.Config.FromValueSpec (shouldDecodeTo_) 8 | 9 | import Hpack.Syntax.DependencyVersion 10 | import Hpack.Syntax.BuildTools 11 | 12 | spec :: Spec 13 | spec = do 14 | describe "fromValue" $ do 15 | context "when parsing BuildTools" $ do 16 | context "with a scalar" $ do 17 | it "accepts qualified names" $ do 18 | [yaml| 19 | foo:bar 20 | |] `shouldDecodeTo_` BuildTools [(QualifiedBuildTool "foo" "bar", anyVersion)] 21 | 22 | it "accepts qualified names with a version" $ do 23 | [yaml| 24 | foo:bar >= 0.1.0 25 | |] `shouldDecodeTo_` BuildTools [(QualifiedBuildTool "foo" "bar", versionRange ">=0.1.0")] 26 | 27 | it "accepts unqualified names" $ do 28 | [yaml| 29 | foo 30 | |] `shouldDecodeTo_` BuildTools [(UnqualifiedBuildTool "foo", anyVersion)] 31 | 32 | it "accepts unqualified names with a version" $ do 33 | [yaml| 34 | foo >= 0.1.0 35 | |] `shouldDecodeTo_` BuildTools [(UnqualifiedBuildTool "foo", versionRange ">=0.1.0")] 36 | 37 | context "with a mapping" $ do 38 | it "accepts qualified names" $ do 39 | [yaml| 40 | foo:bar: 0.1.0 41 | |] `shouldDecodeTo_` BuildTools [(QualifiedBuildTool "foo" "bar", versionRange "==0.1.0")] 42 | 43 | it "accepts unqualified names" $ do 44 | [yaml| 45 | foo: 0.1.0 46 | |] `shouldDecodeTo_` BuildTools [(UnqualifiedBuildTool "foo", versionRange "==0.1.0")] 47 | 48 | context "with a list" $ do 49 | it "accepts a list of build tools" $ do 50 | [yaml| 51 | - foo:one 52 | - bar:two >= 0.1.0 53 | - baz == 0.2.0 54 | |] `shouldDecodeTo_` BuildTools [ 55 | (QualifiedBuildTool "foo" "one", anyVersion) 56 | , (QualifiedBuildTool "bar" "two", versionRange ">=0.1.0") 57 | , (UnqualifiedBuildTool "baz", versionRange "==0.2.0") 58 | ] 59 | 60 | it "accepts source dependencies with a qualified name" $ do 61 | let source = Just (GitRef "https://github.com/sol/hpack" "master" Nothing) 62 | [yaml| 63 | - name: hpack:foo 64 | github: sol/hpack 65 | ref: master 66 | |] `shouldDecodeTo_` BuildTools [(QualifiedBuildTool "hpack" "foo", DependencyVersion source AnyVersion)] 67 | 68 | it "accepts source dependencies with an unqualified name" $ do 69 | let source = Just (GitRef "https://github.com/sol/hpack" "master" Nothing) 70 | [yaml| 71 | - name: hpack 72 | github: sol/hpack 73 | ref: master 74 | |] `shouldDecodeTo_` BuildTools [(UnqualifiedBuildTool "hpack", DependencyVersion source AnyVersion)] 75 | 76 | context "when parsing SystemBuildTools" $ do 77 | context "with a scalar" $ do 78 | it "accepts system build tools" $ do 79 | [yaml| 80 | g++ 81 | |] `shouldDecodeTo_` SystemBuildTools [("g++", AnyVersion)] 82 | 83 | it "accepts system build tools with a version" $ do 84 | [yaml| 85 | g++ >= 0.1.0 86 | |] `shouldDecodeTo_` SystemBuildTools [("g++", VersionRange ">=0.1.0")] 87 | 88 | context "with a mapping" $ do 89 | it "accepts system build tools" $ do 90 | [yaml| 91 | g++: 0.1.0 92 | |] `shouldDecodeTo_` SystemBuildTools [("g++", VersionRange "==0.1.0")] 93 | 94 | context "with a list" $ do 95 | it "accepts a list of system build tools" $ do 96 | [yaml| 97 | - foo 98 | - bar >= 0.1.0 99 | |] `shouldDecodeTo_` SystemBuildTools [ 100 | ("foo", AnyVersion) 101 | , ("bar", VersionRange ">=0.1.0") 102 | ] 103 | 104 | it "accepts objects with name and version" $ do 105 | [yaml| 106 | - name: foo 107 | version: 0.1.0 108 | |] `shouldDecodeTo_` SystemBuildTools [ 109 | ("foo", VersionRange "==0.1.0") 110 | ] 111 | -------------------------------------------------------------------------------- /test/Hpack/Syntax/DefaultsSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes #-} 2 | module Hpack.Syntax.DefaultsSpec (spec) where 3 | 4 | import Helper 5 | 6 | import Data.Aeson.Config.FromValueSpec hiding (spec) 7 | 8 | import Data.Aeson.Config.FromValue 9 | import Hpack.Syntax.Defaults 10 | 11 | defaultsGithub :: String -> String -> String -> [FilePath] -> Defaults 12 | defaultsGithub owner repo ref path = DefaultsGithub $ Github owner repo ref path 13 | 14 | spec :: Spec 15 | spec = do 16 | describe "isValidOwner" $ do 17 | it "rejects the empty string" $ do 18 | isValidOwner "" `shouldBe` False 19 | 20 | it "accepts valid owner names" $ do 21 | isValidOwner "Foo-Bar-23" `shouldBe` True 22 | 23 | it "rejects dots" $ do 24 | isValidOwner "foo.bar" `shouldBe` False 25 | 26 | it "rejects multiple consecutive hyphens" $ do 27 | isValidOwner "foo--bar" `shouldBe` False 28 | 29 | it "rejects hyphens at the beginning" $ do 30 | isValidOwner "-foo" `shouldBe` False 31 | 32 | it "rejects hyphens at the end" $ do 33 | isValidOwner "foo-" `shouldBe` False 34 | 35 | describe "isValidRepo" $ do 36 | it "rejects the empty string" $ do 37 | isValidRepo "" `shouldBe` False 38 | 39 | it "rejects ." $ do 40 | isValidRepo "." `shouldBe` False 41 | 42 | it "rejects .." $ do 43 | isValidRepo ".." `shouldBe` False 44 | 45 | it "accepts underscores" $ do 46 | isValidRepo "foo_bar" `shouldBe` True 47 | 48 | it "accepts dots" $ do 49 | isValidRepo "foo.bar" `shouldBe` True 50 | 51 | it "accepts hyphens" $ do 52 | isValidRepo "foo-bar" `shouldBe` True 53 | 54 | describe "fromValue" $ do 55 | context "when parsing Defaults" $ do 56 | let 57 | left :: String -> Result Defaults 58 | left = Left 59 | context "with Object" $ do 60 | it "fails when neither github nor local is present" $ do 61 | [yaml| 62 | defaults: 63 | foo: one 64 | bar: two 65 | library: {} 66 | |] `shouldDecodeTo` left "Error while parsing $ - neither key \"github\" nor key \"local\" present" 67 | 68 | it "accepts Defaults from GitHub" $ do 69 | [yaml| 70 | github: sol/hpack 71 | ref: 0.1.0 72 | path: defaults.yaml 73 | |] `shouldDecodeTo_` defaultsGithub "sol" "hpack" "0.1.0" ["defaults.yaml"] 74 | 75 | it "rejects invalid owner names" $ do 76 | [yaml| 77 | github: ../hpack 78 | ref: 0.1.0 79 | path: defaults.yaml 80 | |] `shouldDecodeTo` left "Error while parsing $.github - invalid owner name \"..\"" 81 | 82 | it "rejects invalid repository names" $ do 83 | [yaml| 84 | github: sol/.. 85 | ref: 0.1.0 86 | path: defaults.yaml 87 | |] `shouldDecodeTo` left "Error while parsing $.github - invalid repository name \"..\"" 88 | 89 | it "rejects invalid Git references" $ do 90 | [yaml| 91 | github: sol/hpack 92 | ref: ../foo/bar 93 | path: defaults.yaml 94 | |] `shouldDecodeTo` left "Error while parsing $.ref - invalid Git reference \"../foo/bar\"" 95 | 96 | it "rejects \\ in path" $ do 97 | [yaml| 98 | github: sol/hpack 99 | ref: 0.1.0 100 | path: hpack\defaults.yaml 101 | |] `shouldDecodeTo` left "Error while parsing $.path - rejecting '\\' in \"hpack\\\\defaults.yaml\", please use '/' to separate path components" 102 | 103 | it "rejects : in path" $ do 104 | [yaml| 105 | github: sol/hpack 106 | ref: 0.1.0 107 | path: foo:bar.yaml 108 | |] `shouldDecodeTo` left "Error while parsing $.path - rejecting ':' in \"foo:bar.yaml\"" 109 | 110 | it "rejects absolute paths" $ do 111 | [yaml| 112 | github: sol/hpack 113 | ref: 0.1.0 114 | path: /defaults.yaml 115 | |] `shouldDecodeTo` left "Error while parsing $.path - rejecting absolute path \"/defaults.yaml\"" 116 | 117 | it "rejects .. in path" $ do 118 | [yaml| 119 | github: sol/hpack 120 | ref: 0.1.0 121 | path: ../../defaults.yaml 122 | |] `shouldDecodeTo` left "Error while parsing $.path - rejecting \"..\" in \"../../defaults.yaml\"" 123 | 124 | context "with String" $ do 125 | it "accepts Defaults from GitHub" $ do 126 | [yaml| 127 | sol/hpack@0.1.0 128 | |] `shouldDecodeTo_` defaultsGithub "sol" "hpack" "0.1.0" [".hpack", "defaults.yaml"] 129 | 130 | it "rejects invalid owner names" $ do 131 | [yaml| 132 | ../hpack@0.1.0 133 | |] `shouldDecodeTo` left "Error while parsing $ - invalid owner name \"..\"" 134 | 135 | it "rejects invalid repository names" $ do 136 | [yaml| 137 | sol/..@0.1.0 138 | |] `shouldDecodeTo` left "Error while parsing $ - invalid repository name \"..\"" 139 | 140 | it "rejects invalid Git references" $ do 141 | [yaml| 142 | sol/pack@../foo/bar 143 | |] `shouldDecodeTo` left "Error while parsing $ - invalid Git reference \"../foo/bar\"" 144 | 145 | it "rejects missing Git reference" $ do 146 | [yaml| 147 | sol/hpack 148 | |] `shouldDecodeTo` left "Error while parsing $ - missing Git reference for \"sol/hpack\", the expected format is owner/repo@ref" 149 | 150 | context "with neither Object nor String" $ do 151 | it "fails" $ do 152 | [yaml| 153 | 10 154 | |] `shouldDecodeTo` left "Error while parsing $ - expected Object or String, but encountered Number" 155 | -------------------------------------------------------------------------------- /test/Hpack/Syntax/DependenciesSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes #-} 2 | {-# LANGUAGE OverloadedLists #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | module Hpack.Syntax.DependenciesSpec (spec) where 5 | 6 | import Helper 7 | 8 | import Data.Aeson.Config.FromValueSpec (shouldDecodeTo, shouldDecodeTo_) 9 | 10 | import Data.Aeson.Config.FromValue 11 | import Hpack.Syntax.DependencyVersion 12 | import Hpack.Syntax.Dependencies 13 | 14 | left :: String -> Result Dependencies 15 | left = Left 16 | 17 | defaultInfo :: DependencyInfo 18 | defaultInfo = DependencyInfo [] anyVersion 19 | 20 | spec :: Spec 21 | spec = do 22 | describe "parseDependency" $ do 23 | it "accepts dependencies" $ do 24 | parseDependency "dependency" "foo" `shouldReturn` ("foo", DependencyVersion Nothing AnyVersion) 25 | 26 | it "accepts dependencies with a subcomponent" $ do 27 | parseDependency "dependency" "foo:bar" `shouldReturn` ("foo:bar", DependencyVersion Nothing AnyVersion) 28 | 29 | it "accepts dependencies with multiple subcomponents" $ do 30 | parseDependency "dependency" "foo:{bar,baz}" `shouldReturn` ("foo:{bar,baz}", DependencyVersion Nothing AnyVersion) 31 | 32 | describe "fromValue" $ do 33 | context "when parsing Dependencies" $ do 34 | context "with a scalar" $ do 35 | it "accepts dependencies without constraints" $ do 36 | [yaml| 37 | hpack 38 | |] `shouldDecodeTo_` Dependencies [("hpack", defaultInfo)] 39 | 40 | it "accepts dependencies with constraints" $ do 41 | [yaml| 42 | hpack >= 2 && < 4 43 | |] `shouldDecodeTo_` Dependencies [("hpack", defaultInfo { dependencyInfoVersion = versionRange ">=2 && <4" })] 44 | 45 | context "with invalid constraint" $ do 46 | it "returns an error message" $ do 47 | [yaml| 48 | hpack == 49 | |] `shouldDecodeTo` left "Error while parsing $ - invalid dependency \"hpack ==\"" 50 | 51 | context "with a list" $ do 52 | it "accepts dependencies without constraints" $ do 53 | [yaml| 54 | - hpack 55 | |] `shouldDecodeTo_` Dependencies [("hpack", defaultInfo)] 56 | 57 | it "accepts dependencies with constraints" $ do 58 | [yaml| 59 | - hpack >= 2 && < 4 60 | |] `shouldDecodeTo_` Dependencies [("hpack", defaultInfo { dependencyInfoVersion = versionRange ">=2 && <4" })] 61 | 62 | it "accepts ^>=" $ do 63 | [yaml| 64 | - hpack ^>= 1.2.3.4 65 | |] `shouldDecodeTo_` Dependencies [("hpack", defaultInfo { dependencyInfoVersion = versionRange ">=1.2.3.4 && <1.3" })] 66 | 67 | it "accepts objects with name and version" $ do 68 | [yaml| 69 | - name: hpack 70 | version: 0.1.0 71 | |] `shouldDecodeTo_` Dependencies [("hpack", defaultInfo { dependencyInfoVersion = versionRange "==0.1.0" })] 72 | 73 | it "accepts git dependencies with version" $ do 74 | let source = Just (GitRef "https://github.com/sol/hpack" "master" Nothing) 75 | [yaml| 76 | - name: hpack 77 | version: 0.1.0 78 | git: https://github.com/sol/hpack 79 | ref: master 80 | |] `shouldDecodeTo_` Dependencies [("hpack", defaultInfo { dependencyInfoVersion = DependencyVersion source (VersionRange "==0.1.0") })] 81 | 82 | it "accepts git dependencies" $ do 83 | let source = Just (GitRef "https://github.com/sol/hpack" "master" Nothing) 84 | [yaml| 85 | - name: hpack 86 | git: https://github.com/sol/hpack 87 | ref: master 88 | |] `shouldDecodeTo_` Dependencies [("hpack", defaultInfo { dependencyInfoVersion = DependencyVersion source AnyVersion })] 89 | 90 | it "accepts github dependencies" $ do 91 | let source = Just (GitRef "https://github.com/sol/hpack" "master" Nothing) 92 | [yaml| 93 | - name: hpack 94 | github: sol/hpack 95 | ref: master 96 | |] `shouldDecodeTo_` Dependencies [("hpack", defaultInfo { dependencyInfoVersion = DependencyVersion source AnyVersion })] 97 | 98 | it "accepts an optional subdirectory for git dependencies" $ do 99 | let source = Just (GitRef "https://github.com/yesodweb/wai" "master" (Just "warp")) 100 | [yaml| 101 | - name: warp 102 | github: yesodweb/wai 103 | ref: master 104 | subdir: warp 105 | |] `shouldDecodeTo_` Dependencies [("warp", defaultInfo { dependencyInfoVersion = DependencyVersion source AnyVersion })] 106 | 107 | it "accepts local dependencies" $ do 108 | let source = Just (Local "../hpack") 109 | [yaml| 110 | - name: hpack 111 | path: ../hpack 112 | |] `shouldDecodeTo_` Dependencies [("hpack", defaultInfo {dependencyInfoVersion = DependencyVersion source AnyVersion })] 113 | 114 | context "when ref is missing" $ do 115 | it "produces accurate error messages" $ do 116 | [yaml| 117 | - name: hpack 118 | git: sol/hpack 119 | ef: master 120 | |] `shouldDecodeTo` left "Error while parsing $[0] - key \"ref\" not present" 121 | 122 | context "when both git and github are missing" $ do 123 | it "produces accurate error messages" $ do 124 | [yaml| 125 | - name: hpack 126 | gi: sol/hpack 127 | ref: master 128 | |] `shouldDecodeTo` left "Error while parsing $[0] - neither key \"git\" nor key \"github\" present" 129 | 130 | context "with a mapping from dependency names to constraints" $ do 131 | it "accepts dependencies without constraints" $ do 132 | [yaml| 133 | array: 134 | |] `shouldDecodeTo_` Dependencies [("array", defaultInfo)] 135 | 136 | it "rejects invalid values" $ do 137 | [yaml| 138 | hpack: [] 139 | |] `shouldDecodeTo` left "Error while parsing $.hpack - expected Null, Object, Number, or String, but encountered Array" 140 | 141 | context "when the constraint is a Number" $ do 142 | it "accepts 1" $ do 143 | [yaml| 144 | hpack: 1 145 | |] `shouldDecodeTo_` Dependencies [("hpack", defaultInfo { dependencyInfoVersion = versionRange "==1" })] 146 | 147 | it "accepts 1.0" $ do 148 | [yaml| 149 | hpack: 1.0 150 | |] `shouldDecodeTo_` Dependencies [("hpack", defaultInfo { dependencyInfoVersion = versionRange "==1.0" })] 151 | 152 | it "accepts 0.11" $ do 153 | [yaml| 154 | hpack: 0.11 155 | |] `shouldDecodeTo_` Dependencies [("hpack", defaultInfo { dependencyInfoVersion = versionRange "==0.11" })] 156 | 157 | it "accepts 0.110" $ do 158 | [yaml| 159 | hpack: 0.110 160 | |] `shouldDecodeTo_` Dependencies [("hpack", defaultInfo { dependencyInfoVersion = versionRange "==0.110" })] 161 | 162 | it "accepts 1e2" $ do 163 | [yaml| 164 | hpack: 1e2 165 | |] `shouldDecodeTo_` Dependencies [("hpack", defaultInfo { dependencyInfoVersion = versionRange "==100" })] 166 | 167 | context "when the constraint is a String" $ do 168 | it "accepts version ranges" $ do 169 | [yaml| 170 | hpack: '>=2' 171 | |] `shouldDecodeTo_` Dependencies [("hpack", defaultInfo { dependencyInfoVersion = versionRange ">=2" })] 172 | 173 | it "accepts specific versions" $ do 174 | [yaml| 175 | hpack: 0.10.8.2 176 | |] `shouldDecodeTo_` Dependencies [("hpack", defaultInfo { dependencyInfoVersion = versionRange "==0.10.8.2" })] 177 | 178 | it "accepts wildcard versions" $ do 179 | [yaml| 180 | hpack: 2.* 181 | |] `shouldDecodeTo_` Dependencies [("hpack", defaultInfo { dependencyInfoVersion = versionRange "==2.*" })] 182 | 183 | it "accepts ^>=" $ do 184 | [yaml| 185 | hpack: ^>= 1.2.3.4 186 | |] `shouldDecodeTo_` Dependencies [("hpack", defaultInfo { dependencyInfoVersion = versionRange ">=1.2.3.4 && <1.3" })] 187 | 188 | it "reports parse errors" $ do 189 | [yaml| 190 | hpack: foo 191 | |] `shouldDecodeTo` left "Error while parsing $.hpack - invalid constraint \"foo\"" 192 | 193 | context "when the constraint is an Object" $ do 194 | it "accepts explicit version field" $ do 195 | [yaml| 196 | hpack: 197 | version: 0.1.0 198 | |] `shouldDecodeTo_` Dependencies [("hpack", defaultInfo { dependencyInfoVersion = versionRange "==0.1.0" })] 199 | 200 | it "accepts github dependencies" $ do 201 | let source = Just (GitRef "https://github.com/haskell/cabal" "d53b6e0d908dfedfdf4337b2935519fb1d689e76" (Just "Cabal")) 202 | [yaml| 203 | Cabal: 204 | github: haskell/cabal 205 | ref: d53b6e0d908dfedfdf4337b2935519fb1d689e76 206 | subdir: Cabal 207 | |] `shouldDecodeTo_` Dependencies [("Cabal", defaultInfo { dependencyInfoVersion = DependencyVersion source AnyVersion })] 208 | 209 | it "ignores names in nested hashes" $ do 210 | let source = Just (Local "somewhere") 211 | [yaml| 212 | outer-name: 213 | name: inner-name 214 | path: somewhere 215 | |] `shouldDecodeTo` Right (Dependencies [("outer-name", defaultInfo { dependencyInfoVersion = DependencyVersion source AnyVersion })], ["$.outer-name.name"], []) 216 | 217 | it "defaults to any version" $ do 218 | [yaml| 219 | foo: {} 220 | |] `shouldDecodeTo_` Dependencies [("foo", defaultInfo)] 221 | 222 | context "with a version key" $ do 223 | it "rejects objects" $ do 224 | [yaml| 225 | foo: 226 | version: {} 227 | |] `shouldDecodeTo` left "Error while parsing $.foo.version - expected Null, Number, or String, but encountered Object" 228 | 229 | it "accepts a string" $ do 230 | [yaml| 231 | foo: 232 | version: ">= 3.2.5 && < 3.3" 233 | |] `shouldDecodeTo_` Dependencies [("foo", defaultInfo { dependencyInfoVersion = versionRange ">=3.2.5 && <3.3" })] 234 | 235 | it "accepts a specific version as a number" $ do 236 | [yaml| 237 | foo: 238 | version: 3.0 239 | |] `shouldDecodeTo_` Dependencies [("foo", defaultInfo { dependencyInfoVersion = versionRange "==3.0" })] 240 | 241 | it "accepts a specific version as a string" $ do 242 | [yaml| 243 | foo: 244 | version: 3.0.2 245 | |] `shouldDecodeTo_` Dependencies [("foo", defaultInfo { dependencyInfoVersion = versionRange "==3.0.2" })] 246 | 247 | context "with mixin" $ do 248 | it "accepts a single value" $ do 249 | [yaml| 250 | foo: 251 | mixin: (Foo as Bar) 252 | |] `shouldDecodeTo_` Dependencies [("foo", defaultInfo { dependencyInfoMixins = ["(Foo as Bar)"] })] 253 | 254 | it "accepts a list" $ do 255 | [yaml| 256 | foo: 257 | mixin: 258 | - (Foo as Bar) 259 | - hiding (Spam) 260 | |] `shouldDecodeTo_` Dependencies [("foo", defaultInfo { dependencyInfoMixins = ["(Foo as Bar)", "hiding (Spam)"] })] 261 | -------------------------------------------------------------------------------- /test/Hpack/Syntax/GitSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes #-} 2 | module Hpack.Syntax.GitSpec (spec) where 3 | 4 | import Helper 5 | import Data.String.Interpolate 6 | 7 | import Hpack.Syntax.Git 8 | 9 | spec :: Spec 10 | spec = do 11 | describe "isValidRef" $ do 12 | it "accepts slashes" $ do 13 | isValidRef "foo/bar" `shouldBe` True 14 | 15 | it "rejects the empty string" $ do 16 | isValidRef "" `shouldBe` False 17 | 18 | it "accepts .lock as a substring" $ do 19 | isValidRef "foo.locking" `shouldBe` True 20 | 21 | it "rejects .lock at the end of a component" $ do 22 | isValidRef "foo/bar.lock/baz" `shouldBe` False 23 | 24 | it "rejects . at the biginning of a component" $ do 25 | isValidRef "foo/.bar/baz" `shouldBe` False 26 | 27 | it "rejects two consecutive dots .." $ do 28 | isValidRef "foo..bar" `shouldBe` False 29 | 30 | it "rejects ASCII control characters" $ do 31 | isValidRef "foo\10bar" `shouldBe` False 32 | 33 | it "rejects space" $ do 34 | isValidRef "foo bar" `shouldBe` False 35 | 36 | forM_ ["~", "^", ":", "?", "*", "[", "\\"] $ \ xs -> do 37 | it [i|rejects #{xs}|] $ do 38 | isValidRef [i|foo#{xs}bar|] `shouldBe` False 39 | 40 | it "rejects multiple consecutive slashes" $ do 41 | isValidRef "foo//bar" `shouldBe` False 42 | 43 | it "rejects slash at beginning" $ do 44 | isValidRef "/foo" `shouldBe` False 45 | 46 | it "rejects slash at end" $ do 47 | isValidRef "foo/" `shouldBe` False 48 | 49 | it "rejects . at end" $ do 50 | isValidRef "foo." `shouldBe` False 51 | 52 | it "rejects @{" $ do 53 | isValidRef "foo@{bar" `shouldBe` False 54 | 55 | it "rejects the single character @" $ do 56 | isValidRef "@" `shouldBe` False 57 | -------------------------------------------------------------------------------- /test/Hpack/Utf8Spec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Hpack.Utf8Spec (spec) where 3 | 4 | import Helper 5 | 6 | import qualified Data.ByteString as B 7 | 8 | import qualified Hpack.Utf8 as Utf8 9 | 10 | spec :: Spec 11 | spec = do 12 | describe "readFile" $ do 13 | context "with a file that uses CRLF newlines" $ do 14 | it "applies newline conversion" $ do 15 | inTempDirectory $ do 16 | let 17 | name = "foo.txt" 18 | B.writeFile name "foo\r\nbar" 19 | Utf8.readFile name `shouldReturn` "foo\nbar" 20 | 21 | describe "ensureFile" $ do 22 | it "uses system specific newline encoding" $ do 23 | inTempDirectory $ do 24 | let 25 | name = "foo.txt" 26 | c = "foo\nbar" 27 | 28 | writeFile name c 29 | systemSpecific <- B.readFile name 30 | 31 | Utf8.ensureFile name c 32 | B.readFile name `shouldReturn` systemSpecific 33 | -------------------------------------------------------------------------------- /test/Hpack/UtilSpec.hs: -------------------------------------------------------------------------------- 1 | module Hpack.UtilSpec (main, spec) where 2 | 3 | import Helper 4 | import System.Directory 5 | 6 | import Hpack.Util 7 | 8 | main :: IO () 9 | main = hspec spec 10 | 11 | spec :: Spec 12 | spec = do 13 | describe "sort" $ do 14 | it "sorts lexicographically" $ do 15 | sort ["foo", "Foo"] `shouldBe` ["Foo", "foo" :: String] 16 | 17 | describe "parseMain" $ do 18 | it "accepts source file" $ do 19 | parseMain "Main.hs" `shouldBe` ("Main.hs", []) 20 | 21 | it "accepts literate source file" $ do 22 | parseMain "Main.lhs" `shouldBe` ("Main.lhs", []) 23 | 24 | it "accepts module" $ do 25 | parseMain "Foo" `shouldBe` ("Foo.hs", ["-main-is Foo"]) 26 | 27 | it "accepts hierarchical module" $ do 28 | parseMain "Foo.Bar.Baz" `shouldBe` ("Foo/Bar/Baz.hs", ["-main-is Foo.Bar.Baz"]) 29 | 30 | it "accepts qualified identifier" $ do 31 | parseMain "Foo.bar" `shouldBe` ("Foo.hs", ["-main-is Foo.bar"]) 32 | 33 | describe "tryReadFile" $ do 34 | it "reads file" $ do 35 | inTempDirectory $ do 36 | writeFile "foo" "bar" 37 | tryReadFile "foo" `shouldReturn` Just "bar" 38 | 39 | it "returns Nothing if file does not exist" $ do 40 | inTempDirectory $ do 41 | tryReadFile "foo" `shouldReturn` Nothing 42 | 43 | describe "expandGlobs" $ around withTempDirectory $ do 44 | it "accepts literal files" $ \dir -> do 45 | touch (dir "foo.js") 46 | expandGlobs "field-name" dir ["foo.js"] `shouldReturn` ([], ["foo.js"]) 47 | 48 | it "keeps declaration order for literal files" $ \dir -> do 49 | touch (dir "foo.js") 50 | touch (dir "bar.js") 51 | expandGlobs "field-name" dir ["foo.js", "bar.js"] `shouldReturn` ([], ["foo.js", "bar.js"]) 52 | 53 | it "removes duplicates" $ \dir -> do 54 | touch (dir "foo.js") 55 | expandGlobs "field-name" dir ["foo.js", "*.js"] `shouldReturn` ([], ["foo.js"]) 56 | 57 | it "rejects directories" $ \dir -> do 58 | touch (dir "foo") 59 | createDirectory (dir "bar") 60 | expandGlobs "field-name" dir ["*"] `shouldReturn` ([], ["foo"]) 61 | 62 | it "rejects character ranges" $ \dir -> do 63 | touch (dir "foo1") 64 | touch (dir "foo2") 65 | touch (dir "foo[1,2]") 66 | expandGlobs "field-name" dir ["foo[1,2]"] `shouldReturn` ([], ["foo[1,2]"]) 67 | 68 | context "when expanding *" $ do 69 | it "expands by extension" $ \dir -> do 70 | let files = [ 71 | "files/foo.js" 72 | , "files/bar.js" 73 | , "files/baz.js"] 74 | mapM_ (touch . (dir )) files 75 | touch (dir "files/foo.hs") 76 | expandGlobs "field-name" dir ["files/*.js"] `shouldReturn` ([], sort files) 77 | 78 | it "rejects dot-files" $ \dir -> do 79 | touch (dir "foo/bar") 80 | touch (dir "foo/.baz") 81 | expandGlobs "field-name" dir ["foo/*"] `shouldReturn` ([], ["foo/bar"]) 82 | 83 | it "accepts dot-files when explicitly asked to" $ \dir -> do 84 | touch (dir "foo/bar") 85 | touch (dir "foo/.baz") 86 | expandGlobs "field-name" dir ["foo/.*"] `shouldReturn` ([], ["foo/.baz"]) 87 | 88 | it "matches at most one directory component" $ \dir -> do 89 | touch (dir "foo/bar/baz.js") 90 | touch (dir "foo/bar.js") 91 | expandGlobs "field-name" dir ["*/*.js"] `shouldReturn` ([], ["foo/bar.js"]) 92 | 93 | context "when expanding **" $ do 94 | it "matches arbitrary many directory components" $ \dir -> do 95 | let file = "foo/bar/baz.js" 96 | touch (dir file) 97 | expandGlobs "field-name" dir ["**/*.js"] `shouldReturn` ([], [file]) 98 | 99 | context "when a pattern does not match anything" $ do 100 | it "warns" $ \dir -> do 101 | expandGlobs "field-name" dir ["*.foo"] `shouldReturn` 102 | (["Specified pattern \"*.foo\" for field-name does not match any files"], []) 103 | 104 | context "when a pattern only matches a directory" $ do 105 | it "warns" $ \dir -> do 106 | createDirectory (dir "foo") 107 | expandGlobs "field-name" dir ["fo?"] `shouldReturn` 108 | (["Specified pattern \"fo?\" for field-name does not match any files"], []) 109 | 110 | context "when a literal file does not exist" $ do 111 | it "warns and keeps the file" $ \dir -> do 112 | expandGlobs "field-name" dir ["foo.js"] `shouldReturn` (["Specified file \"foo.js\" for field-name does not exist"], ["foo.js"]) 113 | -------------------------------------------------------------------------------- /test/HpackSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module HpackSpec (spec) where 3 | 4 | import Helper 5 | 6 | import Prelude hiding (readFile) 7 | import qualified Prelude as Prelude 8 | import System.Exit (die) 9 | 10 | import Control.DeepSeq 11 | 12 | import Hpack.Config 13 | import Hpack.CabalFile 14 | import Hpack.Error (formatHpackError) 15 | import Hpack 16 | 17 | readFile :: FilePath -> IO String 18 | readFile name = Prelude.readFile name >>= (return $!!) 19 | 20 | spec :: Spec 21 | spec = do 22 | describe "header" $ do 23 | it "generates header" $ do 24 | header "foo.yaml" Nothing Nothing `shouldBe` [ 25 | "-- This file has been generated from foo.yaml by hpack." 26 | , "--" 27 | , "-- see: https://github.com/sol/hpack" 28 | , "" 29 | ] 30 | 31 | context "with hpack version" $ do 32 | it "includes hpack version" $ do 33 | header "foo.yaml" (Just $ makeVersion [0,34,0]) Nothing `shouldBe` [ 34 | "-- This file has been generated from foo.yaml by hpack version 0.34.0." 35 | , "--" 36 | , "-- see: https://github.com/sol/hpack" 37 | , "" 38 | ] 39 | 40 | context "with hash" $ do 41 | it "includes hash" $ do 42 | header "foo.yaml" Nothing (Just "some-hash") `shouldBe` [ 43 | "-- This file has been generated from foo.yaml by hpack." 44 | , "--" 45 | , "-- see: https://github.com/sol/hpack" 46 | , "--" 47 | , "-- hash: some-hash" 48 | , "" 49 | ] 50 | 51 | describe "renderCabalFile" $ do 52 | it "is inverse to readCabalFile" $ do 53 | expected <- lines <$> readFile "resources/test/hpack.cabal" 54 | Just c <- readCabalFile "resources/test/hpack.cabal" 55 | renderCabalFile "package.yaml" c {cabalFileGitConflictMarkers = ()} `shouldBe` expected 56 | 57 | describe "hpackResult" $ around_ inTempDirectory $ before_ (writeFile packageConfig "name: foo") $ do 58 | let 59 | file = "foo.cabal" 60 | 61 | hpackWithVersion v = hpackResultWithVersion (makeVersion v) defaultOptions >>= either (die . formatHpackError "hpack") return 62 | hpackWithStrategy strategy = hpackResult defaultOptions { optionsGenerateHashStrategy = strategy } 63 | hpackForce = hpackResult defaultOptions {optionsForce = Force} 64 | 65 | generated = Result [] file Generated 66 | modifiedManually = Result [] file ExistingCabalFileWasModifiedManually 67 | outputUnchanged = Result [] file OutputUnchanged 68 | alreadyGeneratedByNewerHpack = Result [] file AlreadyGeneratedByNewerHpack 69 | 70 | modifyPackageConfig = writeFile packageConfig $ unlines [ 71 | "name: foo" 72 | , "version: 0.1.0" 73 | ] 74 | 75 | modifyCabalFile = do 76 | xs <- readFile file 77 | writeFile file $ xs ++ "foo\n" 78 | 79 | manuallyCreateCabalFile = do 80 | writeFile file "some existing cabal file" 81 | 82 | doesNotGenerateHash :: HasCallStack => GenerateHashStrategy -> Spec 83 | doesNotGenerateHash strategy = do 84 | it "does not generate hash" $ do 85 | hpackWithStrategy strategy `shouldReturn` generated 86 | readFile file >>= (`shouldNotContain` "hash") 87 | 88 | generatesHash :: HasCallStack => GenerateHashStrategy -> Spec 89 | generatesHash strategy = do 90 | it "generates hash" $ do 91 | hpackWithStrategy strategy `shouldReturn` generated 92 | readFile file >>= (`shouldContain` "hash") 93 | 94 | doesNotOverwrite :: HasCallStack => GenerateHashStrategy -> Spec 95 | doesNotOverwrite strategy = do 96 | it "does not overwrite cabal file" $ do 97 | existing <- readFile file 98 | hpackWithStrategy strategy `shouldReturn` modifiedManually 99 | readFile file `shouldReturn` existing 100 | 101 | with strategy item = context ("with " ++ show strategy) $ item strategy 102 | 103 | context "without an existing cabal file" $ do 104 | with ForceHash generatesHash 105 | with PreferHash generatesHash 106 | with ForceNoHash doesNotGenerateHash 107 | with PreferNoHash doesNotGenerateHash 108 | 109 | context "with an existing cabal file" $ do 110 | context "without a hash" $ before_ (hpackWithStrategy ForceNoHash >> modifyPackageConfig) $ do 111 | with ForceHash generatesHash 112 | with PreferHash doesNotGenerateHash 113 | with ForceNoHash doesNotGenerateHash 114 | with PreferNoHash doesNotGenerateHash 115 | 116 | context "with a hash" $ before_ (hpackWithStrategy ForceHash >> modifyPackageConfig) $ do 117 | with ForceHash generatesHash 118 | with PreferHash generatesHash 119 | with ForceNoHash doesNotGenerateHash 120 | with PreferNoHash generatesHash 121 | 122 | context "with manual modifications" $ before_ modifyCabalFile $ do 123 | with ForceHash doesNotOverwrite 124 | with PreferHash doesNotOverwrite 125 | with ForceNoHash doesNotGenerateHash 126 | with PreferNoHash doesNotOverwrite 127 | 128 | context "when created manually" $ before_ manuallyCreateCabalFile $ do 129 | with ForceHash doesNotOverwrite 130 | with PreferHash doesNotOverwrite 131 | with ForceNoHash doesNotOverwrite 132 | with PreferNoHash doesNotOverwrite 133 | 134 | context "with --force" $ do 135 | it "overwrites cabal file" $ do 136 | hpackForce `shouldReturn` generated 137 | 138 | context "when generated with a newer version of hpack" $ do 139 | it "does not overwrite cabal file" $ do 140 | _ <- hpackWithVersion [0,22,0] 141 | old <- readFile file 142 | modifyPackageConfig 143 | hpackWithVersion [0,20,0] `shouldReturn` alreadyGeneratedByNewerHpack 144 | readFile file `shouldReturn` old 145 | 146 | context "when only the hpack version in the cabal file header changed" $ do 147 | it "does not overwrite cabal file" $ do 148 | _ <- hpackWithVersion [0,22,0] 149 | old <- readFile file 150 | hpackWithVersion [0,30,0] `shouldReturn` outputUnchanged 151 | readFile file `shouldReturn` old 152 | 153 | it "does not complain if it's newer" $ do 154 | _ <- hpackWithVersion [0,22,0] 155 | old <- readFile file 156 | hpackWithVersion [0,20,0] `shouldReturn` outputUnchanged 157 | readFile file `shouldReturn` old 158 | 159 | context "with git conflict markers" $ do 160 | context "when the new and the existing .cabal file are essentially the same" $ do 161 | it "still removes the conflict markers" $ do 162 | writeFile file $ unlines [ 163 | "--" 164 | , "name: foo" 165 | ] 166 | hpack NoVerbose defaultOptions {optionsForce = Force} 167 | old <- readFile file 168 | let 169 | modified :: String 170 | modified = unlines $ case break (== "version: 0.0.0") $ lines old of 171 | (xs, v : ys) -> xs ++ 172 | "<<<<<<< ours" : 173 | v : 174 | "=======" : 175 | "version: 0.1.0" : 176 | ">>>>>>> theirs" : ys 177 | _ -> undefined 178 | writeFile file modified 179 | hpack NoVerbose defaultOptions 180 | readFile file `shouldReturn` old 181 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | -------------------------------------------------------------------------------- /test/SpecHook.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module SpecHook where 3 | 4 | import Test.Hspec 5 | import qualified VCR 6 | 7 | hook :: Spec -> Spec 8 | hook = aroundAll_ (VCR.with "test/fixtures/vcr-tape.yaml") 9 | -------------------------------------------------------------------------------- /test/fixtures/vcr-tape.yaml: -------------------------------------------------------------------------------- 1 | - request: 2 | method: GET 3 | url: https://raw.githubusercontent.com/sol/foo/bar/.hpack/defaults.yaml 4 | headers: [] 5 | body: '' 6 | response: 7 | status: 8 | code: 404 9 | message: Not Found 10 | headers: 11 | - name: Connection 12 | value: keep-alive 13 | - name: Content-Length 14 | value: '14' 15 | - name: Content-Security-Policy 16 | value: default-src 'none'; style-src 'unsafe-inline'; sandbox 17 | - name: Strict-Transport-Security 18 | value: max-age=31536000 19 | - name: X-Content-Type-Options 20 | value: nosniff 21 | - name: X-Frame-Options 22 | value: deny 23 | - name: X-XSS-Protection 24 | value: 1; mode=block 25 | - name: Content-Type 26 | value: text/plain; charset=utf-8 27 | - name: X-GitHub-Request-Id 28 | value: EB86:89B15:32F6A:BB26F:67E34432 29 | - name: Accept-Ranges 30 | value: bytes 31 | - name: Date 32 | value: Wed, 26 Mar 2025 00:02:58 GMT 33 | - name: Via 34 | value: 1.1 varnish 35 | - name: X-Served-By 36 | value: cache-bkk2310024-BKK 37 | - name: X-Cache 38 | value: MISS 39 | - name: X-Cache-Hits 40 | value: '0' 41 | - name: X-Timer 42 | value: S1742947379.520472,VS0,VE307 43 | - name: Vary 44 | value: Authorization,Accept-Encoding,Origin 45 | - name: Access-Control-Allow-Origin 46 | value: '*' 47 | - name: Cross-Origin-Resource-Policy 48 | value: cross-origin 49 | - name: X-Fastly-Request-ID 50 | value: 2429a59a030eea6929163ebb108303c479ebd96a 51 | - name: Expires 52 | value: Wed, 26 Mar 2025 00:07:58 GMT 53 | - name: Source-Age 54 | value: '0' 55 | body: '404: Not Found' 56 | - request: 57 | method: GET 58 | url: https://raw.githubusercontent.com/sol/hpack/master/Setup.lhs 59 | headers: [] 60 | body: '' 61 | response: 62 | status: 63 | code: 200 64 | message: OK 65 | headers: 66 | - name: Connection 67 | value: keep-alive 68 | - name: Content-Length 69 | value: '92' 70 | - name: Cache-Control 71 | value: max-age=300 72 | - name: Content-Security-Policy 73 | value: default-src 'none'; style-src 'unsafe-inline'; sandbox 74 | - name: Content-Type 75 | value: text/plain; charset=utf-8 76 | - name: ETag 77 | value: W/"48b58800a4ac7f29a4c73b1ff4d85f928c02a21f031909cceb27df4781e4c72e" 78 | - name: Strict-Transport-Security 79 | value: max-age=31536000 80 | - name: X-Content-Type-Options 81 | value: nosniff 82 | - name: X-Frame-Options 83 | value: deny 84 | - name: X-XSS-Protection 85 | value: 1; mode=block 86 | - name: X-GitHub-Request-Id 87 | value: 9FD1:1BDD62:15A3C:59762:67E33FF8 88 | - name: Content-Encoding 89 | value: gzip 90 | - name: Accept-Ranges 91 | value: bytes 92 | - name: Date 93 | value: Wed, 26 Mar 2025 00:02:59 GMT 94 | - name: Via 95 | value: 1.1 varnish 96 | - name: X-Served-By 97 | value: cache-bkk2310026-BKK 98 | - name: X-Cache 99 | value: HIT 100 | - name: X-Cache-Hits 101 | value: '0' 102 | - name: X-Timer 103 | value: S1742947379.147110,VS0,VE366 104 | - name: Vary 105 | value: Authorization,Accept-Encoding,Origin 106 | - name: Access-Control-Allow-Origin 107 | value: '*' 108 | - name: Cross-Origin-Resource-Policy 109 | value: cross-origin 110 | - name: X-Fastly-Request-ID 111 | value: ac6c3a3e70d21c933163202c8dde1ba0e404e115 112 | - name: Expires 113 | value: Wed, 26 Mar 2025 00:07:59 GMT 114 | - name: Source-Age 115 | value: '0' 116 | body: | 117 | #!/usr/bin/env runhaskell 118 | > import Distribution.Simple 119 | > main = defaultMain 120 | - request: 121 | method: GET 122 | url: https://raw.githubusercontent.com/sol/hpack/master/Setup.foo 123 | headers: [] 124 | body: '' 125 | response: 126 | status: 127 | code: 404 128 | message: Not Found 129 | headers: 130 | - name: Connection 131 | value: keep-alive 132 | - name: Content-Length 133 | value: '14' 134 | - name: Content-Security-Policy 135 | value: default-src 'none'; style-src 'unsafe-inline'; sandbox 136 | - name: Strict-Transport-Security 137 | value: max-age=31536000 138 | - name: X-Content-Type-Options 139 | value: nosniff 140 | - name: X-Frame-Options 141 | value: deny 142 | - name: X-XSS-Protection 143 | value: 1; mode=block 144 | - name: Content-Type 145 | value: text/plain; charset=utf-8 146 | - name: X-GitHub-Request-Id 147 | value: CCDF:1746CE:189606:474B01:67E34433 148 | - name: Accept-Ranges 149 | value: bytes 150 | - name: Date 151 | value: Wed, 26 Mar 2025 00:02:59 GMT 152 | - name: Via 153 | value: 1.1 varnish 154 | - name: X-Served-By 155 | value: cache-bkk2310022-BKK 156 | - name: X-Cache 157 | value: MISS 158 | - name: X-Cache-Hits 159 | value: '0' 160 | - name: X-Timer 161 | value: S1742947380.617003,VS0,VE374 162 | - name: Vary 163 | value: Authorization,Accept-Encoding,Origin 164 | - name: Access-Control-Allow-Origin 165 | value: '*' 166 | - name: Cross-Origin-Resource-Policy 167 | value: cross-origin 168 | - name: X-Fastly-Request-ID 169 | value: 9ce61163b75a9ebdd3c9e418c0379cffc6db5600 170 | - name: Expires 171 | value: Wed, 26 Mar 2025 00:07:59 GMT 172 | - name: Source-Age 173 | value: '0' 174 | body: '404: Not Found' 175 | -------------------------------------------------------------------------------- /util/gh-md-toc: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | # 4 | # Steps: 5 | # 6 | # 1. Download corresponding html file for some README.md: 7 | # curl -s $1 8 | # 9 | # 2. Discard rows where no substring 'user-content-' (github's markup): 10 | # awk '/user-content-/ { ... 11 | # 12 | # 3.1 Get last number in each row like ' ... sitemap.js.*<\/h/)+2, RLENGTH-5) 21 | # 22 | # 5. Find anchor and insert it inside "(...)": 23 | # substr($0, match($0, "href=\"[^\"]+?\" ")+6, RLENGTH-8) 24 | # 25 | 26 | gh_toc_version="0.7.0" 27 | 28 | gh_user_agent="gh-md-toc v$gh_toc_version" 29 | 30 | # 31 | # Download rendered into html README.md by its url. 32 | # 33 | # 34 | gh_toc_load() { 35 | local gh_url=$1 36 | 37 | if type curl &>/dev/null; then 38 | curl --user-agent "$gh_user_agent" -s "$gh_url" 39 | elif type wget &>/dev/null; then 40 | wget --user-agent="$gh_user_agent" -qO- "$gh_url" 41 | else 42 | echo "Please, install 'curl' or 'wget' and try again." 43 | exit 1 44 | fi 45 | } 46 | 47 | # 48 | # Converts local md file into html by GitHub 49 | # 50 | # -> curl -X POST --data '{"text": "Hello world github/linguist#1 **cool**, and #1!"}' https://api.github.com/markdown 51 | #

Hello world github/linguist#1 cool, and #1!

'" 52 | gh_toc_md2html() { 53 | local gh_file_md=$1 54 | URL=https://api.github.com/markdown/raw 55 | 56 | if [ ! -z "$GH_TOC_TOKEN" ]; then 57 | TOKEN=$GH_TOC_TOKEN 58 | else 59 | TOKEN_FILE="$(cd "$(dirname "${BASH_SOURCE[0]}")" && pwd)/token.txt" 60 | if [ -f "$TOKEN_FILE" ]; then 61 | TOKEN="$(cat $TOKEN_FILE)" 62 | fi 63 | fi 64 | if [ ! -z "${TOKEN}" ]; then 65 | AUTHORIZATION="Authorization: token ${TOKEN}" 66 | fi 67 | 68 | # echo $URL 1>&2 69 | OUTPUT=$(curl -s \ 70 | --user-agent "$gh_user_agent" \ 71 | --data-binary @"$gh_file_md" \ 72 | -H "Content-Type:text/plain" \ 73 | -H "$AUTHORIZATION" \ 74 | "$URL") 75 | 76 | if [ "$?" != "0" ]; then 77 | echo "XXNetworkErrorXX" 78 | fi 79 | if [ "$(echo "${OUTPUT}" | awk '/API rate limit exceeded/')" != "" ]; then 80 | echo "XXRateLimitXX" 81 | else 82 | echo "${OUTPUT}" 83 | fi 84 | } 85 | 86 | 87 | # 88 | # Is passed string url 89 | # 90 | gh_is_url() { 91 | case $1 in 92 | https* | http*) 93 | echo "yes";; 94 | *) 95 | echo "no";; 96 | esac 97 | } 98 | 99 | # 100 | # TOC generator 101 | # 102 | gh_toc(){ 103 | local gh_src=$1 104 | local gh_src_copy=$1 105 | local gh_ttl_docs=$2 106 | local need_replace=$3 107 | local no_backup=$4 108 | 109 | if [ "$gh_src" = "" ]; then 110 | echo "Please, enter URL or local path for a README.md" 111 | exit 1 112 | fi 113 | 114 | 115 | # Show "TOC" string only if working with one document 116 | if [ "$gh_ttl_docs" = "1" ]; then 117 | 118 | echo "Table of Contents" 119 | echo "=================" 120 | echo "" 121 | gh_src_copy="" 122 | 123 | fi 124 | 125 | if [ "$(gh_is_url "$gh_src")" == "yes" ]; then 126 | gh_toc_load "$gh_src" | gh_toc_grab "$gh_src_copy" 127 | if [ "${PIPESTATUS[0]}" != "0" ]; then 128 | echo "Could not load remote document." 129 | echo "Please check your url or network connectivity" 130 | exit 1 131 | fi 132 | if [ "$need_replace" = "yes" ]; then 133 | echo 134 | echo "!! '$gh_src' is not a local file" 135 | echo "!! Can't insert the TOC into it." 136 | echo 137 | fi 138 | else 139 | local rawhtml=$(gh_toc_md2html "$gh_src") 140 | if [ "$rawhtml" == "XXNetworkErrorXX" ]; then 141 | echo "Parsing local markdown file requires access to github API" 142 | echo "Please make sure curl is installed and check your network connectivity" 143 | exit 1 144 | fi 145 | if [ "$rawhtml" == "XXRateLimitXX" ]; then 146 | echo "Parsing local markdown file requires access to github API" 147 | echo "Error: You exceeded the hourly limit. See: https://developer.github.com/v3/#rate-limiting" 148 | TOKEN_FILE="$(cd "$(dirname "${BASH_SOURCE[0]}")" && pwd)/token.txt" 149 | echo "or place GitHub auth token here: ${TOKEN_FILE}" 150 | exit 1 151 | fi 152 | local toc=`echo "$rawhtml" | gh_toc_grab "$gh_src_copy"` 153 | echo "$toc" 154 | if [ "$need_replace" = "yes" ]; then 155 | if grep -Fxq "" $gh_src && grep -Fxq "" $gh_src; then 156 | echo "Found markers" 157 | else 158 | echo "You don't have or in your file...exiting" 159 | exit 1 160 | fi 161 | local ts="<\!--ts-->" 162 | local te="<\!--te-->" 163 | local dt=`date +'%F_%H%M%S'` 164 | local ext=".orig.${dt}" 165 | local toc_path="${gh_src}.toc.${dt}" 166 | local toc_footer="" 167 | # http://fahdshariff.blogspot.ru/2012/12/sed-mutli-line-replacement-between-two.html 168 | # clear old TOC 169 | sed -i${ext} "/${ts}/,/${te}/{//!d;}" "$gh_src" 170 | # create toc file 171 | echo "${toc}" > "${toc_path}" 172 | echo -e "\n${toc_footer}\n" >> "$toc_path" 173 | # insert toc file 174 | if [[ "`uname`" == "Darwin" ]]; then 175 | sed -i "" "/${ts}/r ${toc_path}" "$gh_src" 176 | else 177 | sed -i "/${ts}/r ${toc_path}" "$gh_src" 178 | fi 179 | echo 180 | if [ "${no_backup}" = "yes" ]; then 181 | rm ${toc_path} ${gh_src}${ext} 182 | fi 183 | echo "!! TOC was added into: '$gh_src'" 184 | if [ -z "${no_backup}" ]; then 185 | echo "!! Origin version of the file: '${gh_src}${ext}'" 186 | echo "!! TOC added into a separate file: '${toc_path}'" 187 | fi 188 | echo 189 | fi 190 | fi 191 | } 192 | 193 | # 194 | # Grabber of the TOC from rendered html 195 | # 196 | # $1 - a source url of document. 197 | # It's need if TOC is generated for multiple documents. 198 | # 199 | gh_toc_grab() { 200 | common_awk_script=' 201 | modified_href = "" 202 | split(href, chars, "") 203 | for (i=1;i <= length(href); i++) { 204 | c = chars[i] 205 | res = "" 206 | if (c == "+") { 207 | res = " " 208 | } else { 209 | if (c == "%") { 210 | res = "\\x" 211 | } else { 212 | res = c "" 213 | } 214 | } 215 | modified_href = modified_href res 216 | } 217 | print sprintf("%*s", level*3, " ") "* [" text "](" gh_url modified_href ")" 218 | ' 219 | if [ `uname -s` == "OS/390" ]; then 220 | grepcmd="pcregrep -o" 221 | echoargs="" 222 | awkscript='{ 223 | level = substr($0, length($0), 1) 224 | text = substr($0, match($0, /a>.*<\/h/)+2, RLENGTH-5) 225 | href = substr($0, match($0, "href=\"([^\"]+)?\"")+6, RLENGTH-7) 226 | '"$common_awk_script"' 227 | }' 228 | else 229 | grepcmd="grep -Eo" 230 | echoargs="-e" 231 | awkscript='{ 232 | level = substr($0, length($0), 1) 233 | text = substr($0, match($0, /a>.*<\/h/)+2, RLENGTH-5) 234 | href = substr($0, match($0, "href=\"[^\"]+?\"")+6, RLENGTH-7) 235 | '"$common_awk_script"' 236 | }' 237 | fi 238 | href_regex='href=\"[^\"]+?\"' 239 | 240 | # if closed is on the new line, then move it on the prev line 241 | # for example: 242 | # was: The command foo1 243 | # 244 | # became: The command foo1 245 | sed -e ':a' -e 'N' -e '$!ba' -e 's/\n<\/h/<\/h/g' | 246 | 247 | # find strings that corresponds to template 248 | $grepcmd '//g' | sed 's/<\/code>//g' | 252 | 253 | # remove g-emoji 254 | sed 's/]*[^<]*<\/g-emoji> //g' | 255 | 256 | # now all rows are like: 257 | # ... / placeholders" 286 | echo " $app_name - Create TOC for markdown from STDIN" 287 | echo " $app_name --help Show help" 288 | echo " $app_name --version Show version" 289 | return 290 | fi 291 | 292 | if [ "$1" = '--version' ]; then 293 | echo "$gh_toc_version" 294 | echo 295 | echo "os: `lsb_release -d | cut -f 2`" 296 | echo "kernel: `cat /proc/version`" 297 | echo "shell: `$SHELL --version`" 298 | echo 299 | for tool in curl wget grep awk sed; do 300 | printf "%-5s: " $tool 301 | echo `$tool --version | head -n 1` 302 | done 303 | return 304 | fi 305 | 306 | if [ "$1" = "-" ]; then 307 | if [ -z "$TMPDIR" ]; then 308 | TMPDIR="/tmp" 309 | elif [ -n "$TMPDIR" -a ! -d "$TMPDIR" ]; then 310 | mkdir -p "$TMPDIR" 311 | fi 312 | local gh_tmp_md 313 | if [ `uname -s` == "OS/390" ]; then 314 | local timestamp=$(date +%m%d%Y%H%M%S) 315 | gh_tmp_md="$TMPDIR/tmp.$timestamp" 316 | else 317 | gh_tmp_md=$(mktemp $TMPDIR/tmp.XXXXXX) 318 | fi 319 | while read input; do 320 | echo "$input" >> "$gh_tmp_md" 321 | done 322 | gh_toc_md2html "$gh_tmp_md" | gh_toc_grab "" 323 | return 324 | fi 325 | 326 | if [ "$1" = '--insert' ]; then 327 | need_replace="yes" 328 | shift 329 | fi 330 | 331 | if [ "$1" = '--no-backup' ]; then 332 | need_replace="yes" 333 | no_backup="yes" 334 | shift 335 | fi 336 | for md in "$@" 337 | do 338 | echo "" 339 | gh_toc "$md" "$#" "$need_replace" "$no_backup" 340 | done 341 | 342 | echo "" 343 | echo "Created by [gh-md-toc](https://github.com/ekalinin/github-markdown-toc)" 344 | } 345 | 346 | # 347 | # Entry point 348 | # 349 | gh_toc_app "$@" 350 | 351 | -------------------------------------------------------------------------------- /util/update-toc: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | util/gh-md-toc --insert --no-backup README.md 3 | --------------------------------------------------------------------------------