hpack-0.34.2/0000755000000000000000000000000013665434154011067 5ustar0000000000000000hpack-0.34.2/Setup.lhs0000644000000000000000000000011413665434154012673 0ustar0000000000000000#!/usr/bin/env runhaskell > import Distribution.Simple > main = defaultMain hpack-0.34.2/hpack.cabal0000644000000000000000000001036513665434154013146 0ustar0000000000000000cabal-version: 1.12 -- This file has been generated from package.yaml by hpack version 0.34.2. -- -- see: https://github.com/sol/hpack name: hpack version: 0.34.2 synopsis: A modern format for Haskell packages description: See README at category: Development homepage: https://github.com/sol/hpack#readme bug-reports: https://github.com/sol/hpack/issues maintainer: Simon Hengel license: MIT license-file: LICENSE build-type: Simple extra-source-files: CHANGELOG.md source-repository head type: git location: https://github.com/sol/hpack library hs-source-dirs: src ghc-options: -Wall build-depends: Cabal >=3.0.0.0 , Glob >=0.9.0 , aeson >=1.4.3.0 , base >=4.9 && <5 , bifunctors , bytestring , containers , cryptonite , deepseq , directory , filepath , http-client , http-client-tls , http-types , infer-license >=0.2.0 && <0.3 , pretty , scientific , text , transformers , unordered-containers , vector , yaml >=0.10.0 exposed-modules: Hpack Hpack.Config Hpack.Render Hpack.Yaml other-modules: Data.Aeson.Config.FromValue Data.Aeson.Config.Parser Data.Aeson.Config.Types Data.Aeson.Config.Util Hpack.CabalFile Hpack.Defaults Hpack.Haskell Hpack.License Hpack.Options Hpack.Render.Dsl Hpack.Render.Hints Hpack.Syntax.BuildTools Hpack.Syntax.Defaults Hpack.Syntax.Dependencies Hpack.Syntax.DependencyVersion Hpack.Syntax.Git Hpack.Syntax.ParseDependencies Hpack.Utf8 Hpack.Util Paths_hpack default-language: Haskell2010 executable hpack main-is: Main.hs hs-source-dirs: driver ghc-options: -Wall build-depends: Cabal >=3.0.0.0 , Glob >=0.9.0 , aeson >=1.4.3.0 , base >=4.9 && <5 , bifunctors , bytestring , containers , cryptonite , deepseq , directory , filepath , hpack , http-client , http-client-tls , http-types , infer-license >=0.2.0 && <0.3 , pretty , scientific , text , transformers , unordered-containers , vector , yaml >=0.10.0 other-modules: Paths_hpack default-language: Haskell2010 test-suite spec type: exitcode-stdio-1.0 main-is: Spec.hs hs-source-dirs: test src ghc-options: -Wall cpp-options: -DTEST build-depends: Cabal >=3.0.0.0 , Glob >=0.9.0 , HUnit >=1.6.0.0 , QuickCheck , aeson >=1.4.3.0 , base >=4.9 && <5 , bifunctors , bytestring , containers , cryptonite , deepseq , directory , filepath , hspec ==2.* , http-client , http-client-tls , http-types , infer-license >=0.2.0 && <0.3 , interpolate , mockery >=0.3 , pretty , scientific , template-haskell , temporary , text , transformers , unordered-containers , vector , yaml >=0.10.0 build-tool-depends: hspec-discover:hspec-discover other-modules: Data.Aeson.Config.FromValueSpec Data.Aeson.Config.TypesSpec Data.Aeson.Config.UtilSpec EndToEndSpec Helper Hpack.CabalFileSpec Hpack.ConfigSpec Hpack.DefaultsSpec Hpack.HaskellSpec Hpack.LicenseSpec Hpack.OptionsSpec Hpack.Render.DslSpec Hpack.Render.HintsSpec Hpack.RenderSpec Hpack.Syntax.BuildToolsSpec Hpack.Syntax.DefaultsSpec Hpack.Syntax.DependenciesSpec Hpack.Syntax.GitSpec Hpack.Utf8Spec Hpack.UtilSpec HpackSpec Data.Aeson.Config.FromValue Data.Aeson.Config.Parser Data.Aeson.Config.Types Data.Aeson.Config.Util Hpack Hpack.CabalFile Hpack.Config Hpack.Defaults Hpack.Haskell Hpack.License Hpack.Options Hpack.Render Hpack.Render.Dsl Hpack.Render.Hints Hpack.Syntax.BuildTools Hpack.Syntax.Defaults Hpack.Syntax.Dependencies Hpack.Syntax.DependencyVersion Hpack.Syntax.Git Hpack.Syntax.ParseDependencies Hpack.Utf8 Hpack.Util Hpack.Yaml Paths_hpack default-language: Haskell2010 hpack-0.34.2/CHANGELOG.md0000644000000000000000000001557413665434154012714 0ustar0000000000000000## Changes in 0.34.2 - Accept subcomponents as dependencies (close #382) ## Changes in 0.34.1 - Fix a bug in `github: ...` introduced with `0.34.0` (f63eb19b956517b4dd8e28dc5785be5889a99298) ## Changes in 0.34.0 (deprecated) - Use `PreferNoHash` as default `GenerateHashStrategy` - Add support for library `visibility` (see #382) - Reject URLs for `github` ## Changes in 0.33.1 - Add `GenerateHashStrategy`. The default is `PreferHash` for `0.33.0` and will change to `PreferNoHash` with `0.34.0`. See https://github.com/sol/hpack/pull/390) for details. - Add command-line options `--hash` and `--no-hash` ## Changes in 0.33.0.1 - Silently ignore missing hash when the cabal file content didn't change at all (for forward compatibility with #390) ## Changes in 0.33.0 - Support GHC 8.8.1: `fail` is no longer a part of `Monad`. Instead, it lives in the `MonadFail` class. Adapting our code to this change meant changing the types of exporting functions, unfortunately, hence the major version bump. ## Changes in 0.32.0 - Support Cabal 3.0 - Switch reexported-modules to comma-separated list ## Changes in 0.31.2 - Add default value for maintainer (see #339) - Escape commas and spaces in filenames when generating cabal files ## Changes in 0.31.1 - Show the header when printing to stdout (see #331) - Add help for `--numeric-version`(see #337) ## Changes in 0.31.0 - Add `mixin` to the fields read by dependencies when they are objects (see #318) - `hpack` now returns with a successful exit code if the `.cabal` file is up to date, even if it was generated by a newer version of `hpack`. ## Changes in 0.30.0 - Warn on duplicate fields (see #283) - Always render `cabal-version` as `x.y` instead of `>= x.y` so that `cabal check` does not complain (see #322) - Extend `build-tools` so that it subsumes Cabal's `build-tools` and `build-tool-depends` (see #254) - Add support for `system-build-tools` - Keep declaration order for literal files in c-sources (and other fields that accept glob patterns). This is crucial as a workaround for https://ghc.haskell.org/trac/ghc/ticket/13786 (see #324) ## Changes in 0.29.7 - Expose more stuff from `Hpack.Yaml` so that it can be used by third parties ## Changes in 0.29.6 - Add `spec-version` (see #300) ## Changes in 0.29.5 - Fix a regression related to indentation sniffing (close #310) ## Changes in 0.29.4 - Desugar ^>= when dependency is a string (see #309) - Add support for Apache, MPL and ISC when inferring `license` (see #305) ## Changes in 0.29.3 - Desugar `^>=` for compatibility with `Cabal < 2` (see #213) - Add support for GPL, LGPL and AGPL when inferring `license` (see #305) ## Changes in 0.29.2 - Add missing `extra-source-files` (see #302) ## Changes in 0.29.1 - Infer `license` from `license-file` ## Changes in 0.29.0 - Put the `cabal-version` at the beginning of the generated file. This Is required with `cabal-version: 2.1` and higher. (see #292) - With `cabal-version: 2.1` or higher omit `>=` when rendering (see #292) - Require `cabal-version: 2.2` when SPDX license identifiers are used (see #292) - Map cabal-style licenses to SPDX license identifiers when `cabal-version` is 2.2 or higher (see #292) ## Changes in 0.28.2 - Exit with `exitFailure` on `AlreadyGeneratedByNewerHpack` or `ExistingCabalFileWasModifiedManually` in `Hpack.printResult` ## Changes in 0.28.1 - GHC 8.4.1 compatibility ## Changes in 0.28.0 - Add support for `cxx-options` and `cxx-sources` (see #205) - Add support for `data-dir` (see #100) - Generate valid `.cabal` files when `verbatim` is used top-level (see #280) ## Changes in 0.27.0 - Local defaults are now resolved relative to the file they are mentioned in, not the CWD that hpack is invoked from. ## Changes in 0.26.0 - Major refactoring of the exposed API (much cleaner now, but lot's of breaking changes!) - Remove Git conflict markers before checking the hash of any existing `.cabal` files (equivalent to `git checkout --ours`). This allows to regenerate the `.cabal` file on conflicts when rebasing without passing `-f` in some cases and helps with preserving the formatting. - Allow local files to be used as defaults (#248) ## Changes in 0.25.0 - Keep non-existing literal files on glob expansion (see #101) ## Changes in 0.24.0 - Add support for `verbatim` Cabal escape hatch - Allow `version` be a numbers - Ignore fields that start with an underscore everywhere, not just globally ## Changes in 0.23.0 - Add support for custom decoders to allow for alternate syntax (e.g. Dhall) - `generated-exposed-modules` and `generated-other-modules`, for populating the `autogen-modules` field (#207). - Corrected `cabal-version` setting for `reexported-modules` inside a conditional. ## Changes in 0.22.0 - Add support for `defaults` - Add `--numeric-version` - Add support for `signatures` - `extra-doc-files` requires setting `cabal-version` to at least 1.18; this is now done properly. - Accept bool for `condition` (see #230) ## Changes in 0.21.2 - Fix a bug in module inference for conditionals (see #236) - Add support for `extra-doc-files`. - Add support for `pkg-config-dependencies` ## Changes in 0.21.1 - Allow dependency constraints to be numbers (see #234) ## Changes in 0.21.0 - Accept section-specific fields in conditionals (see #175, thanks to Scott Fleischman) - New section: `internal-libraries`, for Cabal 2's internal libraries (see #200). ## Changes in 0.20.0 - Do not overwrite any existing cabal file if it has been modified manually ## Changes in 0.19.3 - Add support for `frameworks` and `extra-frameworks-dirs` ## Changes in 0.19.2 - Compatibility with `Glob >= 0.9.0` ## Changes in 0.19.1 - Add `IsList` instance for `Dependencies` ## Changes in 0.19.0 - Add Paths_* module to executables (see #195, for GHC 8.2.1 compatibility) - Allow specifying dependencies as a hash (see #198) ## Changes in 0.18.1 - Output generated cabal file to `stdout` when `-` is given as a command-line option (see #113) - Recognize `.chs`, `.y`, `.ly` and `.x` as Haskell modules when inferring modules for ## Changes in 0.18.0 - Make `executable` a shortcut of `executables: { package-name: ... }` - Add support for `ghcjs-options` and `js-sources` (see #161) - Allow `license-file` to be a list - Accept input file on command-line (see #106) - Add Paths_* when no modules are specified (see #86) ## Changes in 0.17.1 - Do not descend into irrelevant directories when inferring modules (see #165) ## Changes in 0.17.0 - Added custom-setup section - Add support for `!include` directives ## Changes in 0.16.0 - Warn when `name` is missing - Support globs in `c-sources` - Use binary I/O for cabal files avoiding problems with non-UTF-8 locales - Fix rendering of `.` as directory (cabal syntax issue) hpack-0.34.2/LICENSE0000644000000000000000000000206713665434154012101 0ustar0000000000000000Copyright (c) 2014-2018 Simon Hengel Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. hpack-0.34.2/driver/0000755000000000000000000000000013665434154012362 5ustar0000000000000000hpack-0.34.2/driver/Main.hs0000644000000000000000000000034413665434154013603 0ustar0000000000000000module Main (main) where import System.Environment import qualified Hpack import qualified Hpack.Config as Hpack main :: IO () main = getArgs >>= Hpack.getOptions Hpack.packageConfig >>= mapM_ (uncurry Hpack.hpack) hpack-0.34.2/test/0000755000000000000000000000000013665434154012046 5ustar0000000000000000hpack-0.34.2/test/HpackSpec.hs0000644000000000000000000001313313665434154014244 0ustar0000000000000000module HpackSpec (spec) where import Helper import Prelude hiding (readFile) import qualified Prelude as Prelude import Control.DeepSeq import Hpack.Config import Hpack.CabalFile import Hpack hiding (hpack) readFile :: FilePath -> IO String readFile name = Prelude.readFile name >>= (return $!!) spec :: Spec spec = do describe "header" $ do it "generates header" $ do header "foo.yaml" Nothing Nothing `shouldBe` [ "-- This file has been generated from foo.yaml by hpack." , "--" , "-- see: https://github.com/sol/hpack" , "" ] context "with hpack version" $ do it "includes hpack version" $ do header "foo.yaml" (Just $ makeVersion [0,34,0]) Nothing `shouldBe` [ "-- This file has been generated from foo.yaml by hpack version 0.34.0." , "--" , "-- see: https://github.com/sol/hpack" , "" ] context "with hash" $ do it "includes hash" $ do header "foo.yaml" Nothing (Just "some-hash") `shouldBe` [ "-- This file has been generated from foo.yaml by hpack." , "--" , "-- see: https://github.com/sol/hpack" , "--" , "-- hash: some-hash" , "" ] describe "renderCabalFile" $ do it "is inverse to readCabalFile" $ do expected <- lines <$> readFile "hpack.cabal" Just c <- readCabalFile "hpack.cabal" renderCabalFile "package.yaml" c `shouldBe` expected describe "hpackResult" $ around_ inTempDirectory $ before_ (writeFile packageConfig "name: foo") $ do let file = "foo.cabal" hpackWithVersion v = hpackResultWithVersion (makeVersion v) defaultOptions hpackWithStrategy strategy = hpackResult defaultOptions { optionsGenerateHashStrategy = strategy } hpackForce = hpackResult defaultOptions {optionsForce = Force} generated = Result [] file Generated modifiedManually = Result [] file ExistingCabalFileWasModifiedManually outputUnchanged = Result [] file OutputUnchanged alreadyGeneratedByNewerHpack = Result [] file AlreadyGeneratedByNewerHpack modifyPackageConfig = writeFile packageConfig $ unlines [ "name: foo" , "version: 0.1.0" ] modifyCabalFile = do xs <- readFile file writeFile file $ xs ++ "foo\n" manuallyCreateCabalFile = do writeFile file "some existing cabal file" doesNotGenerateHash :: HasCallStack => GenerateHashStrategy -> Spec doesNotGenerateHash strategy = do it "does not generate hash" $ do hpackWithStrategy strategy `shouldReturn` generated readFile file >>= (`shouldNotContain` "hash") generatesHash :: HasCallStack => GenerateHashStrategy -> Spec generatesHash strategy = do it "generates hash" $ do hpackWithStrategy strategy `shouldReturn` generated readFile file >>= (`shouldContain` "hash") doesNotOverwrite :: HasCallStack => GenerateHashStrategy -> Spec doesNotOverwrite strategy = do it "does not overwrite cabal file" $ do existing <- readFile file hpackWithStrategy strategy `shouldReturn` modifiedManually readFile file `shouldReturn` existing with strategy item = context ("with " ++ show strategy) $ item strategy context "without an existing cabal file" $ do with ForceHash generatesHash with PreferHash generatesHash with ForceNoHash doesNotGenerateHash with PreferNoHash doesNotGenerateHash context "with an existing cabal file" $ do context "without a hash" $ before_ (hpackWithStrategy ForceNoHash >> modifyPackageConfig) $ do with ForceHash generatesHash with PreferHash doesNotGenerateHash with ForceNoHash doesNotGenerateHash with PreferNoHash doesNotGenerateHash context "with a hash" $ before_ (hpackWithStrategy ForceHash >> modifyPackageConfig) $ do with ForceHash generatesHash with PreferHash generatesHash with ForceNoHash doesNotGenerateHash with PreferNoHash generatesHash context "with manual modifications" $ before_ modifyCabalFile $ do with ForceHash doesNotOverwrite with PreferHash doesNotOverwrite with ForceNoHash doesNotGenerateHash with PreferNoHash doesNotOverwrite context "when created manually" $ before_ manuallyCreateCabalFile $ do with ForceHash doesNotOverwrite with PreferHash doesNotOverwrite with ForceNoHash doesNotOverwrite with PreferNoHash doesNotOverwrite context "with --force" $ do it "overwrites cabal file" $ do hpackForce `shouldReturn` generated context "when generated with a newer version of hpack" $ do it "does not overwrite cabal file" $ do _ <- hpackWithVersion [0,22,0] old <- readFile file modifyPackageConfig hpackWithVersion [0,20,0] `shouldReturn` alreadyGeneratedByNewerHpack readFile file `shouldReturn` old context "when only the hpack version in the cabal file header changed" $ do it "does not overwrite cabal file" $ do _ <- hpackWithVersion [0,22,0] old <- readFile file hpackWithVersion [0,30,0] `shouldReturn` outputUnchanged readFile file `shouldReturn` old it "does not complain if it's newer" $ do _ <- hpackWithVersion [0,22,0] old <- readFile file hpackWithVersion [0,20,0] `shouldReturn` outputUnchanged readFile file `shouldReturn` old hpack-0.34.2/test/Spec.hs0000644000000000000000000000005413665434154013273 0ustar0000000000000000{-# OPTIONS_GHC -F -pgmF hspec-discover #-} hpack-0.34.2/test/EndToEndSpec.hs0000644000000000000000000013711613665434154014666 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ConstraintKinds #-} module EndToEndSpec (spec) where import Prelude hiding (writeFile) import qualified Prelude import Helper import Test.HUnit import System.Directory (canonicalizePath, createDirectory) import Data.Maybe import Data.List import Data.String.Interpolate import Data.String.Interpolate.Util import Data.Version (showVersion) import qualified Hpack.Render as Hpack import Hpack.Config (packageConfig, readPackageConfig, DecodeOptions(..), DecodeResult(..), defaultDecodeOptions) import Hpack.Render.Hints (FormattingHints(..), sniffFormattingHints) import qualified Paths_hpack as Hpack (version) writeFile :: FilePath -> String -> IO () writeFile file c = touch file >> Prelude.writeFile file c spec :: Spec spec = around_ (inTempDirectoryNamed "foo") $ do describe "hpack" $ do it "ignores fields that start with an underscore" $ do [i| _foo: bar: 23 library: {} |] `shouldRenderTo` library [i| other-modules: Paths_foo |] it "warns on duplicate fields" $ do [i| name: foo name: foo |] `shouldWarn` [ "package.yaml: Duplicate field $.name" ] describe "spec-version" $ do it "accepts spec-version" $ do [i| spec-version: 0.29.5 |] `shouldRenderTo` package [i| |] it "fails on malformed spec-version" $ do [i| spec-version: foo |] `shouldFailWith` "package.yaml: Error while parsing $.spec-version - invalid value \"foo\"" it "fails on unsupported spec-version" $ do [i| spec-version: 25.0 |] `shouldFailWith` ("The file package.yaml requires version 25.0 of the Hpack package specification, however this version of hpack only supports versions up to " ++ showVersion Hpack.version ++ ". Upgrading to the latest version of hpack may resolve this issue.") it "fails on unsupported spec-version from defaults" $ do let file = joinPath ["defaults", "sol", "hpack-template", "2017", "defaults.yaml"] writeFile file [i| spec-version: 25.0 |] [i| defaults: github: sol/hpack-template path: defaults.yaml ref: "2017" library: {} |] `shouldFailWith` ("The file " ++ file ++ " requires version 25.0 of the Hpack package specification, however this version of hpack only supports versions up to " ++ showVersion Hpack.version ++ ". Upgrading to the latest version of hpack may resolve this issue.") describe "data-files" $ do it "accepts data-files" $ do touch "data/foo/index.html" touch "data/bar/index.html" [i| data-files: - data/**/*.html |] `shouldRenderTo` package [i| data-files: data/bar/index.html data/foo/index.html |] describe "data-dir" $ do it "accepts data-dir" $ do touch "data/foo.html" touch "data/bar.html" [i| data-dir: data data-files: - "*.html" |] `shouldRenderTo` package [i| data-files: bar.html foo.html data-dir: data |] describe "github" $ do it "accepts owner/repo" $ do [i| github: sol/hpack |] `shouldRenderTo` package [i| homepage: https://github.com/sol/hpack#readme bug-reports: https://github.com/sol/hpack/issues source-repository head type: git location: https://github.com/sol/hpack |] it "accepts owner/repo/path" $ do [i| github: hspec/hspec/hspec-core |] `shouldRenderTo` package [i| homepage: https://github.com/hspec/hspec#readme bug-reports: https://github.com/hspec/hspec/issues source-repository head type: git location: https://github.com/hspec/hspec subdir: hspec-core |] it "rejects URLs" $ do [i| github: https://github.com/sol/hpack/issues/365 |] `shouldFailWith` "package.yaml: Error while parsing $.github - expected owner/repo or owner/repo/subdir, but encountered \"https://github.com/sol/hpack/issues/365\"" describe "homepage" $ do it "accepts homepage URL" $ do [i| homepage: https://example.com/ |] `shouldRenderTo` package [i| homepage: https://example.com/ |] context "with github" $ do it "gives homepage URL precedence" $ do [i| github: hspec/hspec homepage: https://example.com/ |] `shouldRenderTo` package [i| homepage: https://example.com/ bug-reports: https://github.com/hspec/hspec/issues source-repository head type: git location: https://github.com/hspec/hspec |] it "omits homepage URL if it is null" $ do [i| github: hspec/hspec homepage: null |] `shouldRenderTo` package [i| bug-reports: https://github.com/hspec/hspec/issues source-repository head type: git location: https://github.com/hspec/hspec |] describe "bug-reports" $ do it "accepts bug-reports URL" $ do [i| bug-reports: https://example.com/ |] `shouldRenderTo` package [i| bug-reports: https://example.com/ |] context "with github" $ do it "gives bug-reports URL precedence" $ do [i| github: hspec/hspec bug-reports: https://example.com/ |] `shouldRenderTo` package [i| homepage: https://github.com/hspec/hspec#readme bug-reports: https://example.com/ source-repository head type: git location: https://github.com/hspec/hspec |] it "omits bug-reports URL if it is null" $ do [i| github: hspec/hspec bug-reports: null |] `shouldRenderTo` package [i| homepage: https://github.com/hspec/hspec#readme source-repository head type: git location: https://github.com/hspec/hspec |] describe "defaults" $ do it "accepts global defaults" $ do writeFile "defaults/sol/hpack-template/2017/defaults.yaml" [i| default-extensions: - RecordWildCards - DeriveFunctor |] [i| defaults: github: sol/hpack-template path: defaults.yaml ref: "2017" library: {} |] `shouldRenderTo` library_ [i| default-extensions: RecordWildCards DeriveFunctor |] it "accepts library defaults" $ do writeFile "defaults/sol/hpack-template/2017/defaults.yaml" [i| exposed-modules: Foo |] [i| library: defaults: github: sol/hpack-template path: defaults.yaml ref: "2017" |] `shouldRenderTo` library [i| exposed-modules: Foo other-modules: Paths_foo |] it "accepts a list of defaults" $ do writeFile "defaults/foo/bar/v1/.hpack/defaults.yaml" "default-extensions: RecordWildCards" writeFile "defaults/foo/bar/v2/.hpack/defaults.yaml" "default-extensions: DeriveFunctor" [i| defaults: - foo/bar@v1 - foo/bar@v2 library: {} |] `shouldRenderTo` library_ [i| default-extensions: RecordWildCards DeriveFunctor |] it "accepts defaults recursively" $ do writeFile "defaults/foo/bar/v1/.hpack/defaults.yaml" "defaults: foo/bar@v2" writeFile "defaults/foo/bar/v2/.hpack/defaults.yaml" "default-extensions: DeriveFunctor" [i| defaults: foo/bar@v1 library: {} |] `shouldRenderTo` library_ [i| default-extensions: DeriveFunctor |] it "fails on cyclic defaults" $ do let file1 = "defaults/foo/bar/v1/.hpack/defaults.yaml" file2 = "defaults/foo/bar/v2/.hpack/defaults.yaml" writeFile file1 "defaults: foo/bar@v2" writeFile file2 "defaults: foo/bar@v1" canonic1 <- canonicalizePath file1 canonic2 <- canonicalizePath file2 [i| defaults: foo/bar@v1 library: {} |] `shouldFailWith` [i|cycle in defaults (#{canonic1} -> #{canonic2} -> #{canonic1})|] it "fails if defaults don't exist" $ do pending [i| defaults: github: sol/foo ref: bar library: {} |] `shouldFailWith` "Invalid value for \"defaults\"! File https://raw.githubusercontent.com/sol/foo/bar/.hpack/defaults.yaml does not exist!" it "fails on parse error" $ do let file = joinPath ["defaults", "sol", "hpack-template", "2017", "defaults.yaml"] writeFile file "[]" [i| defaults: github: sol/hpack-template path: defaults.yaml ref: "2017" library: {} |] `shouldFailWith` (file ++ ": Error while parsing $ - expected Object, but encountered Array") it "warns on unknown fields" $ do let file = joinPath ["defaults", "sol", "hpack-template", "2017", "defaults.yaml"] writeFile file "foo: bar" [i| name: foo defaults: github: sol/hpack-template path: defaults.yaml ref: "2017" bar: baz library: {} |] `shouldWarn` [ "package.yaml: Ignoring unrecognized field $.defaults.bar" , file ++ ": Ignoring unrecognized field $.foo" ] it "accepts defaults from local files" $ do writeFile "defaults/foo.yaml" [i| defaults: local: bar.yaml |] writeFile "defaults/bar.yaml" [i| default-extensions: - RecordWildCards - DeriveFunctor |] [i| defaults: local: defaults/foo.yaml library: {} |] `shouldRenderTo` library [i| other-modules: Paths_foo default-extensions: RecordWildCards DeriveFunctor |] describe "version" $ do it "accepts string" $ do [i| version: 0.1.0 |] `shouldRenderTo` (package "") {packageVersion = "0.1.0"} it "accepts number" $ do [i| version: 0.1 |] `shouldRenderTo` (package [i| |]) {packageVersion = "0.1"} it "rejects other values" $ do [i| version: {} |] `shouldFailWith` "package.yaml: Error while parsing $.version - expected Number or String, but encountered Object" describe "license" $ do it "accepts cabal-style licenses" $ do [i| license: BSD3 |] `shouldRenderTo` (package [i| license: BSD3 |]) it "accepts SPDX licenses" $ do [i| license: BSD-3-Clause |] `shouldRenderTo` (package [i| license: BSD-3-Clause |]) {packageCabalVersion = "2.2"} context "with an ambiguous license" $ do it "treats it as a cabal-style license" $ do [i| license: MIT |] `shouldRenderTo` (package [i| license: MIT |]) context "when cabal-version >= 2.2" $ do it "maps license to SPDX license identifier" $ do [i| license: BSD3 library: cxx-options: -Wall |] `shouldRenderTo` (package [i| license: BSD-3-Clause library other-modules: Paths_foo cxx-options: -Wall default-language: Haskell2010 |]) {packageCabalVersion = "2.2"} it "doesn't touch unknown licenses" $ do [i| license: some-license library: cxx-options: -Wall |] `shouldRenderTo` (package [i| license: some-license library other-modules: Paths_foo cxx-options: -Wall default-language: Haskell2010 |]) {packageCabalVersion = "2.2"} context "with a LICENSE file" $ do before_ (writeFile "LICENSE" license) $ do it "infers license" $ do [i| |] `shouldRenderTo` (package [i| license-file: LICENSE license: MIT |]) context "when license can not be inferred" $ do it "warns" $ do writeFile "LICENSE" "some-licenese" [i| name: foo |] `shouldWarn` ["Inferring license from file LICENSE failed!"] context "when license is null" $ do it "does not infer license" $ do [i| license: null |] `shouldRenderTo` (package [i| license-file: LICENSE |]) describe "build-type" $ do it "accept Simple" $ do [i| build-type: Simple |] `shouldRenderTo` (package "") {packageBuildType = "Simple"} it "accept Configure" $ do [i| build-type: Configure |] `shouldRenderTo` (package "") {packageBuildType = "Configure"} it "accept Make" $ do [i| build-type: Make |] `shouldRenderTo` (package "") {packageBuildType = "Make"} it "accept Custom" $ do [i| build-type: Custom |] `shouldRenderTo` (package "") {packageBuildType = "Custom"} it "rejects invalid values" $ do [i| build-type: foo |] `shouldFailWith` "package.yaml: Error while parsing $.build-type - expected one of Simple, Configure, Make, or Custom" describe "extra-doc-files" $ do it "accepts a list of files" $ do touch "CHANGES.markdown" touch "README.markdown" [i| extra-doc-files: - CHANGES.markdown - README.markdown |] `shouldRenderTo` (package [i| extra-doc-files: CHANGES.markdown README.markdown |]) {packageCabalVersion = "1.18"} it "accepts glob patterns" $ do touch "CHANGES.markdown" touch "README.markdown" [i| extra-doc-files: - "*.markdown" |] `shouldRenderTo` (package [i| extra-doc-files: CHANGES.markdown README.markdown |]) {packageCabalVersion = "1.18"} it "warns if a glob pattern does not match anything" $ do [i| name: foo extra-doc-files: - "*.markdown" |] `shouldWarn` ["Specified pattern \"*.markdown\" for extra-doc-files does not match any files"] describe "build-tools" $ do it "adds known build tools to build-tools" $ do [i| executable: build-tools: alex == 0.1.0 |] `shouldRenderTo` executable_ "foo" [i| build-tools: alex ==0.1.0 |] it "adds other build tools to build-tool-depends" $ do [i| executable: build-tools: hspec-discover: 0.1.0 |] `shouldRenderTo` (executable_ "foo" [i| build-tool-depends: hspec-discover:hspec-discover ==0.1.0 |]) { -- NOTE: We do not set this to 2.0 on purpose, so that the .cabal -- file is compatible with a wider range of Cabal versions! packageCabalVersion = "1.12" } context "when the name of a build tool matches an executable from the same package" $ do it "adds it to build-tools" $ do [i| executables: bar: build-tools: - bar |] `shouldRenderTo` executable_ "bar" [i| build-tools: bar |] it "gives per-section unqualified names precedence over global qualified names" $ do [i| build-tools: - foo:bar == 0.1.0 executables: bar: build-tools: - bar == 0.2.0 |] `shouldRenderTo` executable_ "bar" [i| build-tools: bar ==0.2.0 |] it "gives per-section qualified names precedence over global unqualified names" $ do [i| build-tools: - bar == 0.1.0 executables: bar: build-tools: - foo:bar == 0.2.0 |] `shouldRenderTo` executable_ "bar" [i| build-tools: bar ==0.2.0 |] context "when the name of a build tool matches a legacy system build tool" $ do it "adds it to build-tools" $ do [i| executable: build-tools: ghc >= 7.10 |] `shouldRenderTo` (executable_ "foo" [i| build-tools: ghc >=7.10 |]) { packageWarnings = ["Listing \"ghc\" under build-tools is deperecated! Please list system executables under system-build-tools instead!"] } describe "system-build-tools" $ do it "adds system build tools to build-tools" $ do [i| executable: system-build-tools: ghc >= 7.10 |] `shouldRenderTo` executable_ "foo" [i| build-tools: ghc >=7.10 |] context "with hpc" $ do it "infers cabal-version 1.14" $ do [i| executable: system-build-tools: hpc |] `shouldRenderTo` (executable_ "foo" [i| build-tools: hpc |]) {packageCabalVersion = "1.14"} context "with ghcjs" $ do it "infers cabal-version 1.22" $ do [i| executable: system-build-tools: ghcjs |] `shouldRenderTo` (executable_ "foo" [i| build-tools: ghcjs |]) {packageCabalVersion = "1.22"} context "with an unknown system build tool" $ do it "infers cabal-version 2.0" $ do [i| executable: system-build-tools: g++ >= 5.4.0 |] `shouldRenderTo` (executable_ "foo" [i| build-tools: g++ >=5.4.0 |]) {packageCabalVersion = "2.0"} describe "dependencies" $ do it "accepts single dependency" $ do [i| executable: dependencies: base |] `shouldRenderTo` executable_ "foo" [i| build-depends: base |] it "accepts dependencies with subcomponents" $ do [i| executable: dependencies: foo:bar |] `shouldRenderTo` (executable_ "foo" [i| build-depends: foo:bar |]) {packageCabalVersion = "3.0"} it "accepts list of dependencies" $ do [i| executable: dependencies: - base - transformers |] `shouldRenderTo` executable_ "foo" [i| build-depends: base , transformers |] context "with both global and section specific dependencies" $ do it "combines dependencies" $ do [i| dependencies: - base executable: dependencies: hspec |] `shouldRenderTo` executable_ "foo" [i| build-depends: base , hspec |] it "gives section specific dependencies precedence" $ do [i| dependencies: - base executable: dependencies: base >= 2 |] `shouldRenderTo` executable_ "foo" [i| build-depends: base >=2 |] describe "pkg-config-dependencies" $ do it "accepts pkg-config-dependencies" $ do [i| pkg-config-dependencies: - QtWebKit - weston executable: {} |] `shouldRenderTo` executable_ "foo" [i| pkgconfig-depends: QtWebKit , weston |] describe "include-dirs" $ do it "accepts include-dirs" $ do [i| include-dirs: - foo - bar executable: {} |] `shouldRenderTo` executable_ "foo" [i| include-dirs: foo bar |] describe "install-includes" $ do it "accepts install-includes" $ do [i| install-includes: - foo.h - bar.h executable: {} |] `shouldRenderTo` executable_ "foo" [i| install-includes: foo.h bar.h |] describe "js-sources" $ before_ (touch "foo.js" >> touch "jsbits/bar.js") $ do it "accepts js-sources" $ do [i| executable: js-sources: - foo.js - jsbits/*.js |] `shouldRenderTo` executable_ "foo" [i| js-sources: foo.js jsbits/bar.js |] it "accepts global js-sources" $ do [i| js-sources: - foo.js - jsbits/*.js executable: {} |] `shouldRenderTo` executable_ "foo" [i| js-sources: foo.js jsbits/bar.js |] describe "cxx-options" $ do it "accepts cxx-options" $ do [i| executable: cxx-options: -Wall |] `shouldRenderTo` (executable_ "foo" [i| cxx-options: -Wall |]) {packageCabalVersion = "2.2"} context "when used inside a nested conditional" $ do it "infers correct cabal-version" $ do [i| executable: when: condition: True when: condition: True when: condition: True cxx-options: -Wall |] `shouldRenderTo` (executable_ "foo" [i| if true if true if true cxx-options: -Wall |]) {packageCabalVersion = "2.2"} describe "cxx-sources" $ before_ (touch "foo.cc" >> touch "cxxbits/bar.cc") $ do it "accepts cxx-sources" $ do [i| executable: cxx-sources: - foo.cc - cxxbits/*.cc |] `shouldRenderTo` (executable_ "foo" [i| cxx-sources: foo.cc cxxbits/bar.cc |]) {packageCabalVersion = "2.2"} describe "extra-lib-dirs" $ do it "accepts extra-lib-dirs" $ do [i| extra-lib-dirs: - foo - bar executable: {} |] `shouldRenderTo` executable_ "foo" [i| extra-lib-dirs: foo bar |] describe "extra-libraries" $ do it "accepts extra-libraries" $ do [i| extra-libraries: - foo - bar executable: {} |] `shouldRenderTo` executable_ "foo" [i| extra-libraries: foo bar |] describe "extra-frameworks-dirs" $ do it "accepts extra-frameworks-dirs" $ do [i| extra-frameworks-dirs: - foo - bar executable: {} |] `shouldRenderTo` executable_ "foo" [i| extra-frameworks-dirs: foo bar |] describe "frameworks" $ do it "accepts frameworks" $ do [i| frameworks: - foo - bar executable: {} |] `shouldRenderTo` executable_ "foo" [i| frameworks: foo bar |] describe "c-sources" $ before_ (touch "cbits/foo.c" >> touch "cbits/bar.c" >> touch "cbits/baz.c") $ do it "keeps declaration order" $ do -- IMPORTANT: This is crucial as a workaround for https://ghc.haskell.org/trac/ghc/ticket/13786 [i| library: c-sources: - cbits/foo.c - cbits/bar.c - cbits/baz.c |] `shouldRenderTo` library_ [i| c-sources: cbits/foo.c cbits/bar.c cbits/baz.c |] it "accepts glob patterns" $ do [i| library: c-sources: cbits/*.c |] `shouldRenderTo` library_ [i| c-sources: cbits/bar.c cbits/baz.c cbits/foo.c |] it "warns when a glob pattern does not match any files" $ do [i| name: foo library: c-sources: foo/*.c |] `shouldWarn` pure "Specified pattern \"foo/*.c\" for c-sources does not match any files" it "quotes filenames with special characters" $ do touch "cbits/foo bar.c" [i| library: c-sources: - cbits/foo bar.c |] `shouldRenderTo` library_ [i| c-sources: "cbits/foo bar.c" |] describe "custom-setup" $ do it "warns on unknown fields" $ do [i| name: foo custom-setup: foo: 1 bar: 2 |] `shouldWarn` [ "package.yaml: Ignoring unrecognized field $.custom-setup.bar" , "package.yaml: Ignoring unrecognized field $.custom-setup.foo" ] it "accepts dependencies" $ do [i| custom-setup: dependencies: - base |] `shouldRenderTo` customSetup [i| setup-depends: base |] it "leaves build-type alone, if it exists" $ do [i| build-type: Make custom-setup: dependencies: - base |] `shouldRenderTo` (customSetup [i| setup-depends: base |]) {packageBuildType = "Make"} describe "library" $ do it "accepts reexported-modules" $ do [i| library: reexported-modules: Baz |] `shouldRenderTo` (library_ [i| reexported-modules: Baz |]) {packageCabalVersion = "1.22"} it "accepts signatures" $ do [i| library: signatures: Foo |] `shouldRenderTo` (library_ [i| signatures: Foo |]) {packageCabalVersion = "2.0"} context "when package.yaml contains duplicate modules" $ do it "generates a cabal file with duplicate modules" $ do -- garbage in, garbage out [i| library: exposed-modules: Foo other-modules: Foo |] `shouldRenderTo` library [i| exposed-modules: Foo other-modules: Foo |] context "when inferring modules" $ do context "with exposed-modules" $ do it "infers other-modules" $ do touch "src/Foo.hs" touch "src/Bar.hs" [i| library: source-dirs: src exposed-modules: Foo |] `shouldRenderTo` library [i| hs-source-dirs: src exposed-modules: Foo other-modules: Bar Paths_foo |] context "with other-modules" $ do it "infers exposed-modules" $ do touch "src/Foo.hs" touch "src/Bar.hs" [i| library: source-dirs: src other-modules: Bar |] `shouldRenderTo` library [i| hs-source-dirs: src exposed-modules: Foo other-modules: Bar |] context "with both exposed-modules and other-modules" $ do it "doesn't infer any modules" $ do touch "src/Foo.hs" touch "src/Bar.hs" [i| library: source-dirs: src exposed-modules: Foo other-modules: Bar |] `shouldRenderTo` library [i| hs-source-dirs: src exposed-modules: Foo other-modules: Bar |] context "with neither exposed-modules nor other-modules" $ do it "infers exposed-modules" $ do touch "src/Foo.hs" touch "src/Bar.hs" [i| library: source-dirs: src |] `shouldRenderTo` library [i| hs-source-dirs: src exposed-modules: Bar Foo other-modules: Paths_foo |] context "with a conditional" $ do it "doesn't infer any modules mentioned in that conditional" $ do touch "src/Foo.hs" touch "src/Bar.hs" [i| library: source-dirs: src when: condition: os(windows) exposed-modules: - Foo - Paths_foo |] `shouldRenderTo` library [i| hs-source-dirs: src if os(windows) exposed-modules: Foo Paths_foo exposed-modules: Bar |] context "with a source-dir inside the conditional" $ do it "infers other-modules" $ do touch "windows/Foo.hs" [i| library: when: condition: os(windows) source-dirs: windows |] `shouldRenderTo` library [i| other-modules: Paths_foo if os(windows) other-modules: Foo hs-source-dirs: windows |] it "does not infer outer modules" $ do touch "windows/Foo.hs" touch "unix/Foo.hs" [i| library: exposed-modules: Foo when: condition: os(windows) then: source-dirs: windows/ else: source-dirs: unix/ |] `shouldRenderTo` library [i| exposed-modules: Foo other-modules: Paths_foo if os(windows) hs-source-dirs: windows/ else hs-source-dirs: unix/ |] context "with generated modules" $ do it "includes generated modules in autogen-modules" $ do [i| library: generated-exposed-modules: Foo generated-other-modules: Bar |] `shouldRenderTo` (library [i| exposed-modules: Foo other-modules: Paths_foo Bar autogen-modules: Foo Bar |]) {packageCabalVersion = "2.0"} it "does not infer any mentioned generated modules" $ do touch "src/Exposed.hs" touch "src/Other.hs" [i| library: source-dirs: src generated-exposed-modules: Exposed generated-other-modules: Other |] `shouldRenderTo` (library [i| hs-source-dirs: src exposed-modules: Exposed other-modules: Paths_foo Other autogen-modules: Exposed Other |]) {packageCabalVersion = "2.0"} it "does not infer any generated modules mentioned inside conditionals" $ do touch "src/Exposed.hs" touch "src/Other.hs" [i| library: source-dirs: src when: condition: os(windows) generated-exposed-modules: Exposed generated-other-modules: Other |] `shouldRenderTo` (library [i| other-modules: Paths_foo hs-source-dirs: src if os(windows) exposed-modules: Exposed other-modules: Other autogen-modules: Other Exposed |]) {packageCabalVersion = "2.0"} context "mixins" $ do it "sets cabal-version to 2.0 if mixins are used" $ do [i| library: dependencies: foo: mixin: - (Blah as Etc) |] `shouldRenderTo` (library [i| other-modules: Paths_foo build-depends: foo mixins: foo (Blah as Etc) |]) {packageCabalVersion = "2.0"} describe "internal-libraries" $ do it "accepts internal-libraries" $ do touch "src/Foo.hs" [i| internal-libraries: bar: source-dirs: src |] `shouldRenderTo` internalLibrary "bar" [i| exposed-modules: Foo other-modules: Paths_foo hs-source-dirs: src |] it "warns on unknown fields" $ do [i| name: foo internal-libraries: bar: baz: 42 |] `shouldWarn` pure "package.yaml: Ignoring unrecognized field $.internal-libraries.bar.baz" it "warns on missing source-dirs" $ do [i| name: foo internal-libraries: bar: source-dirs: src |] `shouldWarn` pure "Specified source-dir \"src\" does not exist" it "accepts visibility" $ do [i| internal-libraries: bar: visibility: public |] `shouldRenderTo` (internalLibrary "bar" [i| visibility: public other-modules: Paths_foo |]) {packageCabalVersion = "3.0"} describe "executables" $ do it "accepts arbitrary entry points as main" $ do touch "src/Foo.hs" touch "src/Bar.hs" [i| executables: foo: source-dirs: src main: Foo |] `shouldRenderTo` executable "foo" [i| main-is: Foo.hs ghc-options: -main-is Foo hs-source-dirs: src other-modules: Bar Paths_foo |] context "when inferring modules" $ do it "infers other-modules" $ do touch "src/Main.hs" touch "src/Foo.hs" [i| executables: foo: main: Main.hs source-dirs: src |] `shouldRenderTo` executable "foo" [i| main-is: Main.hs hs-source-dirs: src other-modules: Foo Paths_foo |] it "allows to specify other-modules" $ do touch "src/Foo.hs" touch "src/Bar.hs" [i| executables: foo: main: Main.hs source-dirs: src other-modules: Baz |] `shouldRenderTo` executable "foo" [i| main-is: Main.hs hs-source-dirs: src other-modules: Baz |] it "does not infer any mentioned generated modules" $ do touch "src/Foo.hs" [i| executables: foo: main: Main.hs source-dirs: src generated-other-modules: Foo |] `shouldRenderTo` (executable "foo" [i| main-is: Main.hs hs-source-dirs: src other-modules: Paths_foo Foo autogen-modules: Foo |]) {packageCabalVersion = "2.0"} context "with conditional" $ do it "doesn't infer any modules mentioned in that conditional" $ do touch "src/Foo.hs" touch "src/Bar.hs" [i| executables: foo: source-dirs: src when: condition: os(windows) other-modules: Foo |] `shouldRenderTo` executable "foo" [i| other-modules: Bar Paths_foo hs-source-dirs: src if os(windows) other-modules: Foo |] it "infers other-modules" $ do touch "src/Foo.hs" touch "windows/Bar.hs" [i| executables: foo: source-dirs: src when: condition: os(windows) source-dirs: windows |] `shouldRenderTo` executable "foo" [i| other-modules: Foo Paths_foo hs-source-dirs: src if os(windows) other-modules: Bar hs-source-dirs: windows |] context "with conditional" $ do it "does not apply global options" $ do -- related bug: https://github.com/sol/hpack/issues/214 [i| ghc-options: -Wall executables: foo: when: condition: os(windows) main: Foo.hs |] `shouldRenderTo` executable_ "foo" [i| ghc-options: -Wall if os(windows) main-is: Foo.hs |] it "accepts executable-specific fields" $ do [i| executables: foo: when: condition: os(windows) main: Foo |] `shouldRenderTo` executable_ "foo" [i| if os(windows) main-is: Foo.hs ghc-options: -main-is Foo |] describe "when" $ do it "accepts conditionals" $ do [i| when: condition: os(windows) dependencies: Win32 executable: {} |] `shouldRenderTo` executable_ "foo" [i| if os(windows) build-depends: Win32 |] it "warns on unknown fields" $ do [i| name: foo foo: 23 when: - condition: os(windows) bar: 23 when: condition: os(windows) bar2: 23 - condition: os(windows) baz: 23 |] `shouldWarn` [ "package.yaml: Ignoring unrecognized field $.foo" , "package.yaml: Ignoring unrecognized field $.when[0].bar" , "package.yaml: Ignoring unrecognized field $.when[0].when.bar2" , "package.yaml: Ignoring unrecognized field $.when[1].baz" ] context "when parsing conditionals with else-branch" $ do it "accepts conditionals with else-branch" $ do [i| when: condition: os(windows) then: dependencies: Win32 else: dependencies: unix executable: {} |] `shouldRenderTo` executable_ "foo" [i| if os(windows) build-depends: Win32 else build-depends: unix |] it "rejects invalid conditionals" $ do [i| when: condition: os(windows) then: dependencies: Win32 else: null |] `shouldFailWith` "package.yaml: Error while parsing $.when.else - expected Object, but encountered Null" it "rejects invalid conditionals" $ do [i| dependencies: - foo - 23 |] `shouldFailWith` "package.yaml: Error while parsing $.dependencies[1] - expected Object or String, but encountered Number" it "warns on unknown fields" $ do [i| name: foo when: condition: os(windows) foo: null then: bar: null else: when: condition: os(windows) then: {} else: baz: null |] `shouldWarn` [ "package.yaml: Ignoring unrecognized field $.when.foo" , "package.yaml: Ignoring unrecognized field $.when.then.bar" , "package.yaml: Ignoring unrecognized field $.when.else.when.else.baz" ] describe "verbatim" $ do it "accepts strings" $ do [i| library: verbatim: | foo: 23 bar: 42 |] `shouldRenderTo` package [i| library other-modules: Paths_foo default-language: Haskell2010 foo: 23 bar: 42 |] it "accepts multi-line strings as field values" $ do [i| library: verbatim: build-depneds: | foo bar baz |] `shouldRenderTo` package [i| library other-modules: Paths_foo default-language: Haskell2010 build-depneds: foo bar baz |] it "allows to null out existing fields" $ do [i| library: verbatim: default-language: null |] `shouldRenderTo` package [i| library other-modules: Paths_foo |] context "when specified globally" $ do it "overrides header fields" $ do [i| verbatim: cabal-version: foo |] `shouldRenderTo` (package "") {packageCabalVersion = "foo"} it "overrides other fields" $ do touch "foo" [i| extra-source-files: foo verbatim: extra-source-files: bar |] `shouldRenderTo` package [i| extra-source-files: bar |] it "is not propagated into sections" $ do [i| verbatim: foo: 23 library: {} |] `shouldRenderTo` package [i| foo: 23 library other-modules: Paths_foo default-language: Haskell2010 |] context "within a section" $ do it "overrides section fields" $ do [i| tests: spec: verbatim: type: detailed-0.9 |] `shouldRenderTo` package [i| test-suite spec type: detailed-0.9 other-modules: Paths_foo default-language: Haskell2010 |] describe "default value of maintainer" $ do it "gives maintainer precedence" $ do [i| author: John Doe maintainer: Jane Doe |] `shouldRenderTo` package [i| author: John Doe maintainer: Jane Doe |] context "with author" $ do it "uses author if maintainer is not specified" $ do [i| author: John Doe |] `shouldRenderTo` package [i| author: John Doe maintainer: John Doe |] it "omits maintainer if it is null" $ do [i| author: John Doe maintainer: null |] `shouldRenderTo` package [i| author: John Doe |] run :: HasCallStack => FilePath -> FilePath -> String -> IO ([String], String) run userDataDir c old = run_ userDataDir c old >>= either assertFailure return run_ :: FilePath -> FilePath -> String -> IO (Either String ([String], String)) run_ userDataDir c old = do mPackage <- readPackageConfig defaultDecodeOptions {decodeOptionsTarget = c, decodeOptionsUserDataDir = Just userDataDir} return $ case mPackage of Right (DecodeResult pkg cabalVersion _ warnings) -> let FormattingHints{..} = sniffFormattingHints (lines old) alignment = fromMaybe 0 formattingHintsAlignment settings = formattingHintsRenderSettings output = cabalVersion ++ Hpack.renderPackageWith settings alignment formattingHintsFieldOrder formattingHintsSectionsFieldOrder pkg in Right (warnings, output) Left err -> Left err data RenderResult = RenderResult [String] String deriving Eq instance Show RenderResult where show (RenderResult warnings output) = unlines (map ("WARNING: " ++) warnings) ++ output shouldRenderTo :: HasCallStack => String -> Package -> Expectation shouldRenderTo input p = do writeFile packageConfig ("name: foo\n" ++ unindent input) let currentDirectory = ".working-directory" createDirectory currentDirectory withCurrentDirectory currentDirectory $ do (warnings, output) <- run ".." (".." packageConfig) expected RenderResult warnings (dropEmptyLines output) `shouldBe` RenderResult (packageWarnings p) expected where expected = dropEmptyLines (renderPackage p) dropEmptyLines = unlines . filter (not . null) . lines shouldWarn :: HasCallStack => String -> [String] -> Expectation shouldWarn input expected = do writeFile packageConfig input (warnings, _) <- run "" packageConfig "" sort warnings `shouldBe` sort expected shouldFailWith :: HasCallStack => String -> String -> Expectation shouldFailWith input expected = do writeFile packageConfig input run_ "" packageConfig "" `shouldReturn` Left expected customSetup :: String -> Package customSetup a = (package content) {packageCabalVersion = "1.24", packageBuildType = "Custom"} where content = [i| custom-setup #{indentBy 2 $ unindent a} |] library_ :: String -> Package library_ l = package content where content = [i| library other-modules: Paths_foo #{indentBy 2 $ unindent l} default-language: Haskell2010 |] library :: String -> Package library l = package content where content = [i| library #{indentBy 2 $ unindent l} default-language: Haskell2010 |] internalLibrary :: String -> String -> Package internalLibrary name e = (package content) {packageCabalVersion = "2.0"} where content = [i| library #{name} #{indentBy 2 $ unindent e} default-language: Haskell2010 |] executable_ :: String -> String -> Package executable_ name e = package content where content = [i| executable #{name} other-modules: Paths_foo #{indentBy 2 $ unindent e} default-language: Haskell2010 |] executable :: String -> String -> Package executable name e = package content where content = [i| executable #{name} #{indentBy 2 $ unindent e} default-language: Haskell2010 |] package :: String -> Package package c = Package "foo" "0.0.0" "Simple" "1.12" c [] data Package = Package { packageName :: String , packageVersion :: String , packageBuildType :: String , packageCabalVersion :: String , packageContent :: String , packageWarnings :: [String] } renderPackage :: Package -> String renderPackage Package{..} = unindent [i| cabal-version: #{packageCabalVersion} name: #{packageName} version: #{packageVersion} build-type: #{packageBuildType} #{unindent packageContent} |] indentBy :: Int -> String -> String indentBy n = unlines . map (replicate n ' ' ++) . lines license :: String license = [i| Copyright (c) 2014-2018 Simon Hengel Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. |] hpack-0.34.2/test/Helper.hs0000644000000000000000000000213413665434154013621 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ConstraintKinds #-} module Helper ( module Test.Hspec , module Test.Mockery.Directory , module Control.Monad , module Control.Applicative , withTempDirectory , module System.FilePath , withCurrentDirectory , yaml ) where import Test.Hspec import Test.Mockery.Directory import Control.Monad import Control.Applicative import System.Directory (getCurrentDirectory, setCurrentDirectory, canonicalizePath) import Control.Exception import qualified System.IO.Temp as Temp import System.FilePath import Data.Yaml.TH (yamlQQ) import Language.Haskell.TH.Quote (QuasiQuoter) withCurrentDirectory :: FilePath -> IO a -> IO a withCurrentDirectory dir action = do bracket getCurrentDirectory setCurrentDirectory $ \ _ -> do setCurrentDirectory dir action withTempDirectory :: (FilePath -> IO a) -> IO a withTempDirectory action = Temp.withSystemTempDirectory "hspec" $ \dir -> do canonicalizePath dir >>= action yaml :: Language.Haskell.TH.Quote.QuasiQuoter yaml = yamlQQ hpack-0.34.2/test/Data/0000755000000000000000000000000013665434154012717 5ustar0000000000000000hpack-0.34.2/test/Data/Aeson/0000755000000000000000000000000013665434154013764 5ustar0000000000000000hpack-0.34.2/test/Data/Aeson/Config/0000755000000000000000000000000013665434154015171 5ustar0000000000000000hpack-0.34.2/test/Data/Aeson/Config/FromValueSpec.hs0000644000000000000000000000674213665434154020251 0ustar0000000000000000{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ConstraintKinds #-} module Data.Aeson.Config.FromValueSpec where import Helper import GHC.Generics import qualified Data.Map.Lazy as Map import Data.Aeson.Config.FromValue shouldDecodeTo :: (HasCallStack, Eq a, Show a, FromValue a) => Value -> Result a -> Expectation shouldDecodeTo value expected = decodeValue value `shouldBe` expected shouldDecodeTo_ :: (HasCallStack, Eq a, Show a, FromValue a) => Value -> a -> Expectation shouldDecodeTo_ value expected = decodeValue value `shouldBe` Right (expected, []) data Person = Person { personName :: String , personAge :: Int , personAddress :: Maybe Address } deriving (Eq, Show, Generic, FromValue) data Address = Address { addressRegion :: String , addressZip :: String } deriving (Eq, Show, Generic, FromValue) data Job = Job { jobRole :: String , jobSalary :: Int } deriving (Eq, Show, Generic, FromValue) spec :: Spec spec = do describe "fromValue" $ do context "with a record" $ do let left :: String -> Result Person left = Left it "decodes a record" $ do [yaml| name: "Joe" age: 23 |] `shouldDecodeTo_` Person "Joe" 23 Nothing it "captures unrecognized fields" $ do [yaml| name: "Joe" age: 23 foo: bar |] `shouldDecodeTo` Right (Person "Joe" 23 Nothing, ["$.foo"]) it "captures nested unrecognized fields" $ do [yaml| name: "Joe" age: 23 address: region: somewhere zip: "123456" foo: bar: 23 |] `shouldDecodeTo` Right (Person "Joe" 23 (Just (Address "somewhere" "123456")), ["$.address.foo"]) it "ignores fields that start with an underscore" $ do [yaml| name: "Joe" age: 23 address: region: somewhere zip: "123456" _foo: bar: 23 |] `shouldDecodeTo_` Person "Joe" 23 (Just (Address "somewhere" "123456")) it "fails on missing field" $ do [yaml| name: "Joe" |] `shouldDecodeTo` left "Error while parsing $ - key \"age\" not present" it "fails on invalid field value" $ do [yaml| name: "Joe" age: "23" |] `shouldDecodeTo` left "Error while parsing $.age - parsing Int failed, expected Number, but encountered String" context "with (,)" $ do it "captures unrecognized fields" $ do [yaml| name: Joe age: 23 role: engineer salary: 100000 foo: bar |] `shouldDecodeTo` Right ((Person "Joe" 23 Nothing, Job "engineer" 100000), ["$.foo"]) context "with []" $ do it "captures unrecognized fields" $ do let expected = [Person "Joe" 23 (Just (Address "somewhere" "123456")), Person "Marry" 25 Nothing] [yaml| - name: "Joe" age: 23 address: region: somewhere zip: "123456" foo: 23 - name: "Marry" age: 25 bar: 42 |] `shouldDecodeTo` Right (expected, ["$[1].bar", "$[0].address.foo"]) context "with Map" $ do it "captures unrecognized fields" $ do [yaml| Joe: region: somewhere zip: '123456' foo: bar |] `shouldDecodeTo` Right (Map.fromList [("Joe", Address "somewhere" "123456")], ["$.Joe.foo"]) hpack-0.34.2/test/Data/Aeson/Config/UtilSpec.hs0000644000000000000000000000121213665434154017251 0ustar0000000000000000module Data.Aeson.Config.UtilSpec (spec) where import Test.Hspec import Data.Aeson.Config.Util spec :: Spec spec = do describe "hyphenize" $ do it "hyphenizes" $ do hyphenize "" "personFirstName" `shouldBe` "person-first-name" it "ignores leading underscores" $ do hyphenize "" "__personFirstName" `shouldBe` "person-first-name" context "when given a type name" $ do it "strips type name" $ do hyphenize "Person" "personFirstName" `shouldBe` "first-name" it "ignores trailing underscores in type name" $ do hyphenize "Person__" "personFirstName" `shouldBe` "first-name" hpack-0.34.2/test/Data/Aeson/Config/TypesSpec.hs0000644000000000000000000000224713665434154017451 0ustar0000000000000000{-# LANGUAGE QuasiQuotes #-} module Data.Aeson.Config.TypesSpec (spec) where import Helper import Data.Aeson.Config.FromValueSpec (shouldDecodeTo, shouldDecodeTo_) import Data.Aeson.Config.FromValue import Data.Aeson.Config.Types spec :: Spec spec = do describe "fromValue" $ do context "List" $ do let parseError :: String -> Result (List Int) parseError prefix = Left (prefix ++ " - parsing Int failed, expected Number, but encountered String") context "when parsing single values" $ do it "returns the value in a singleton list" $ do [yaml|23|] `shouldDecodeTo_` (List [23 :: Int]) it "returns error messages from element parsing" $ do [yaml|foo|] `shouldDecodeTo` parseError "Error while parsing $" context "when parsing a list of values" $ do it "returns the list" $ do [yaml| - 23 - 42 |] `shouldDecodeTo_` List [23, 42 :: Int] it "propagates parse error messages of invalid elements" $ do [yaml| - 23 - foo |] `shouldDecodeTo` parseError "Error while parsing $[1]" hpack-0.34.2/test/Hpack/0000755000000000000000000000000013665434154013074 5ustar0000000000000000hpack-0.34.2/test/Hpack/RenderSpec.hs0000644000000000000000000003261313665434154015467 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedLists #-} module Hpack.RenderSpec (spec) where import Helper import Data.List import Hpack.Syntax.DependencyVersion import Hpack.ConfigSpec hiding (spec) import Hpack.Config hiding (package) import Hpack.Render.Dsl import Hpack.Render library :: Library library = Library Nothing Nothing [] [] [] [] [] executable :: Section Executable executable = section (Executable (Just "Main.hs") [] []) renderEmptySection :: Empty -> [Element] renderEmptySection Empty = [] spec :: Spec spec = do describe "renderPackageWith" $ do let renderPackage_ = renderPackageWith defaultRenderSettings 0 [] [] it "renders a package" $ do renderPackage_ package `shouldBe` unlines [ "name: foo" , "version: 0.0.0" , "build-type: Simple" ] it "aligns fields" $ do renderPackageWith defaultRenderSettings 16 [] [] package `shouldBe` unlines [ "name: foo" , "version: 0.0.0" , "build-type: Simple" ] it "includes description" $ do renderPackage_ package {packageDescription = Just "foo\n\nbar\n"} `shouldBe` unlines [ "name: foo" , "version: 0.0.0" , "description: foo" , " ." , " bar" , "build-type: Simple" ] it "aligns description" $ do renderPackageWith defaultRenderSettings 16 [] [] package {packageDescription = Just "foo\n\nbar\n"} `shouldBe` unlines [ "name: foo" , "version: 0.0.0" , "description: foo" , " ." , " bar" , "build-type: Simple" ] it "includes stability" $ do renderPackage_ package {packageStability = Just "experimental"} `shouldBe` unlines [ "name: foo" , "version: 0.0.0" , "stability: experimental" , "build-type: Simple" ] it "includes license-file" $ do renderPackage_ package {packageLicenseFile = ["FOO"]} `shouldBe` unlines [ "name: foo" , "version: 0.0.0" , "license-file: FOO" , "build-type: Simple" ] it "aligns license-files" $ do renderPackageWith defaultRenderSettings 16 [] [] package {packageLicenseFile = ["FOO", "BAR"]} `shouldBe` unlines [ "name: foo" , "version: 0.0.0" , "license-files: FOO," , " BAR" , "build-type: Simple" ] it "includes copyright holder" $ do renderPackage_ package {packageCopyright = ["(c) 2015 Simon Hengel"]} `shouldBe` unlines [ "name: foo" , "version: 0.0.0" , "copyright: (c) 2015 Simon Hengel" , "build-type: Simple" ] it "aligns copyright holders" $ do renderPackageWith defaultRenderSettings 16 [] [] package {packageCopyright = ["(c) 2015 Foo", "(c) 2015 Bar"]} `shouldBe` unlines [ "name: foo" , "version: 0.0.0" , "copyright: (c) 2015 Foo," , " (c) 2015 Bar" , "build-type: Simple" ] it "includes extra-source-files" $ do renderPackage_ package {packageExtraSourceFiles = ["foo", "bar"]} `shouldBe` unlines [ "name: foo" , "version: 0.0.0" , "build-type: Simple" , "extra-source-files:" , " foo" , " bar" ] it "includes buildable" $ do renderPackage_ package {packageLibrary = Just (section library){sectionBuildable = Just False}} `shouldBe` unlines [ "name: foo" , "version: 0.0.0" , "build-type: Simple" , "" , "library" , " buildable: False" , " default-language: Haskell2010" ] context "when rendering library section" $ do it "renders library section" $ do renderPackage_ package {packageLibrary = Just $ section library} `shouldBe` unlines [ "name: foo" , "version: 0.0.0" , "build-type: Simple" , "" , "library" , " default-language: Haskell2010" ] context "when given list of existing fields" $ do it "retains field order" $ do renderPackageWith defaultRenderSettings 16 ["version", "build-type", "name"] [] package `shouldBe` unlines [ "version: 0.0.0" , "build-type: Simple" , "name: foo" ] it "uses default field order for new fields" $ do renderPackageWith defaultRenderSettings 16 [] [] package `shouldBe` unlines [ "name: foo" , "version: 0.0.0" , "build-type: Simple" ] it "retains section field order" $ do renderPackageWith defaultRenderSettings 0 [] [("executable foo", ["default-language", "main-is", "ghc-options"])] package {packageExecutables = [("foo", executable {sectionGhcOptions = ["-Wall", "-Werror"]})]} `shouldBe` unlines [ "name: foo" , "version: 0.0.0" , "build-type: Simple" , "" , "executable foo" , " default-language: Haskell2010" , " main-is: Main.hs" , " ghc-options: -Wall -Werror" ] context "when rendering executable section" $ do it "includes dependencies" $ do let dependencies = Dependencies [ ("foo", defaultInfo { dependencyInfoVersion = versionRange "== 0.1.0" }) , ("bar", defaultInfo) ] renderPackage_ package {packageExecutables = [("foo", executable {sectionDependencies = dependencies})]} `shouldBe` unlines [ "name: foo" , "version: 0.0.0" , "build-type: Simple" , "" , "executable foo" , " main-is: Main.hs" , " build-depends:" , " bar" , " , foo == 0.1.0" , " default-language: Haskell2010" ] it "includes GHC options" $ do renderPackage_ package {packageExecutables = [("foo", executable {sectionGhcOptions = ["-Wall", "-Werror"]})]} `shouldBe` unlines [ "name: foo" , "version: 0.0.0" , "build-type: Simple" , "" , "executable foo" , " main-is: Main.hs" , " ghc-options: -Wall -Werror" , " default-language: Haskell2010" ] it "includes frameworks" $ do renderPackage_ package {packageExecutables = [("foo", executable {sectionFrameworks = ["foo", "bar"]})]} `shouldBe` unlines [ "name: foo" , "version: 0.0.0" , "build-type: Simple" , "" , "executable foo" , " main-is: Main.hs" , " frameworks:" , " foo" , " bar" , " default-language: Haskell2010" ] it "includes extra-framework-dirs" $ do renderPackage_ package {packageExecutables = [("foo", executable {sectionExtraFrameworksDirs = ["foo", "bar"]})]} `shouldBe` unlines [ "name: foo" , "version: 0.0.0" , "build-type: Simple" , "" , "executable foo" , " main-is: Main.hs" , " extra-frameworks-dirs:" , " foo" , " bar" , " default-language: Haskell2010" ] it "includes GHC profiling options" $ do renderPackage_ package {packageExecutables = [("foo", executable {sectionGhcProfOptions = ["-fprof-auto", "-rtsopts"]})]} `shouldBe` unlines [ "name: foo" , "version: 0.0.0" , "build-type: Simple" , "" , "executable foo" , " main-is: Main.hs" , " ghc-prof-options: -fprof-auto -rtsopts" , " default-language: Haskell2010" ] describe "renderConditional" $ do it "renders conditionals" $ do let conditional = Conditional "os(windows)" (section Empty) {sectionDependencies = deps ["Win32"]} Nothing render defaultRenderSettings 0 (renderConditional renderEmptySection conditional) `shouldBe` [ "if os(windows)" , " build-depends:" , " Win32" ] it "renders conditionals with else-branch" $ do let conditional = Conditional "os(windows)" (section Empty) {sectionDependencies = deps ["Win32"]} (Just $ (section Empty) {sectionDependencies = deps ["unix"]}) render defaultRenderSettings 0 (renderConditional renderEmptySection conditional) `shouldBe` [ "if os(windows)" , " build-depends:" , " Win32" , "else" , " build-depends:" , " unix" ] it "renders nested conditionals" $ do let conditional = Conditional "arch(i386)" (section Empty) {sectionGhcOptions = ["-threaded"], sectionConditionals = [innerConditional]} Nothing innerConditional = Conditional "os(windows)" (section Empty) {sectionDependencies = deps ["Win32"]} Nothing render defaultRenderSettings 0 (renderConditional renderEmptySection conditional) `shouldBe` [ "if arch(i386)" , " ghc-options: -threaded" , " if os(windows)" , " build-depends:" , " Win32" ] it "conditionalises both build-depends and mixins" $ do let conditional = Conditional "os(windows)" (section Empty) {sectionDependencies = [("Win32", depInfo)]} Nothing depInfo = defaultInfo { dependencyInfoMixins = ["hiding (Blah)"] } render defaultRenderSettings 0 (renderConditional renderEmptySection conditional) `shouldBe` [ "if os(windows)" , " build-depends:" , " Win32" , " mixins:" , " Win32 hiding (Blah)" ] describe "renderFlag" $ do it "renders flags" $ do let flag = (Flag "foo" (Just "some flag") True False) render defaultRenderSettings 0 (renderFlag flag) `shouldBe` [ "flag foo" , " description: some flag" , " manual: True" , " default: False" ] describe "formatDescription" $ do it "formats description" $ do let description = unlines [ "foo" , "bar" ] "description: " ++ formatDescription 0 description `shouldBe` intercalate "\n" [ "description: foo" , " bar" ] it "takes specified alignment into account" $ do let description = unlines [ "foo" , "bar" , "baz" ] "description: " ++ formatDescription 15 description `shouldBe` intercalate "\n" [ "description: foo" , " bar" , " baz" ] it "formats empty lines" $ do let description = unlines [ "foo" , " " , "bar" ] "description: " ++ formatDescription 0 description `shouldBe` intercalate "\n" [ "description: foo" , " ." , " bar" ] describe "renderSourceRepository" $ do it "renders source-repository without subdir correctly" $ do let repository = SourceRepository "https://github.com/hspec/hspec" Nothing (render defaultRenderSettings 0 $ renderSourceRepository repository) `shouldBe` [ "source-repository head" , " type: git" , " location: https://github.com/hspec/hspec" ] it "renders source-repository with subdir" $ do let repository = SourceRepository "https://github.com/hspec/hspec" (Just "hspec-core") (render defaultRenderSettings 0 $ renderSourceRepository repository) `shouldBe` [ "source-repository head" , " type: git" , " location: https://github.com/hspec/hspec" , " subdir: hspec-core" ] describe "renderDirectories" $ do it "replaces . with ./. (for compatibility with cabal syntax)" $ do (render defaultRenderSettings 0 $ renderDirectories "name" ["."]) `shouldBe` [ "name:" , " ./." ] describe "renderDependencies" $ do it "renders build-depends" $ do let deps_ = [ ("foo", DependencyInfo [] anyVersion) ] renderDependencies "build-depends" deps_ `shouldBe` [ Field "build-depends" $ CommaSeparatedList [ "foo" ] , Field "mixins" $ CommaSeparatedList [] ] it "renders build-depends with versions" $ do let deps_ = [ ("foo", DependencyInfo [] (versionRange ">= 2 && < 3")) ] renderDependencies "build-depends" deps_ `shouldBe` [ Field "build-depends" $ CommaSeparatedList [ "foo >= 2 && < 3" ] , Field "mixins" $ CommaSeparatedList [] ] it "renders mixins and build-depends for multiple modules" $ do let deps_ = [ ("foo", DependencyInfo ["(Foo as Foo1)"] anyVersion) , ("bar", DependencyInfo ["hiding (Spam)", "(Spam as Spam1) requires (Mod as Sig)"] anyVersion) ] renderDependencies "build-depends" deps_ `shouldBe` [ Field "build-depends" $ CommaSeparatedList [ "bar" , "foo" ] , Field "mixins" $ CommaSeparatedList [ "bar hiding (Spam)" , "bar (Spam as Spam1) requires (Mod as Sig)" , "foo (Foo as Foo1)" ] ] hpack-0.34.2/test/Hpack/DefaultsSpec.hs0000644000000000000000000000263713665434154016022 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-name-shadowing #-} module Hpack.DefaultsSpec (spec) where import Helper import System.Directory import Hpack.Syntax.Defaults import Hpack.Defaults spec :: Spec spec = do describe "ensure" $ do it "fails when local file does not exist" $ do cwd <- getCurrentDirectory let expected = Left $ "Invalid value for \"defaults\"! File " ++ (cwd "foo") ++ " does not exist!" ensure undefined cwd (DefaultsLocal $ Local "foo") `shouldReturn` expected describe "ensureFile" $ do let file = "foo" url = "https://raw.githubusercontent.com/sol/hpack/master/Setup.lhs" it "downloads file if missing" $ do pending expected <- readFile "Setup.lhs" inTempDirectory $ do Found <- ensureFile file url readFile file `shouldReturn` expected context "with existing file" $ do it "does nothing" $ do let expected = "contents of existing file" inTempDirectory $ do writeFile file expected Found <- ensureFile file url readFile file `shouldReturn` expected context "with 404" $ do let url = "https://raw.githubusercontent.com/sol/hpack/master/Setup.foo" it "does not create any files" $ do pending inTempDirectory $ do NotFound <- ensureFile file url doesFileExist file `shouldReturn` False hpack-0.34.2/test/Hpack/LicenseSpec.hs0000644000000000000000000000435213665434154015631 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE QuasiQuotes #-} module Hpack.LicenseSpec (spec) where import Helper import Data.Maybe import Data.String.Interpolate import Distribution.Pretty (prettyShow) import Distribution.Parsec (simpleParsec) import qualified Distribution.License as Cabal import Hpack.License cabal :: String -> Cabal.License cabal = fromJust . simpleParsec cabalLicenses :: [(String, License String)] cabalLicenses = [ ("GPL", CanSPDX (cabal "GPL") "LicenseRef-GPL") , ("GPL-2", CanSPDX (cabal "GPL-2") "GPL-2.0-only") , ("GPL-3", CanSPDX (cabal "GPL-3") "GPL-3.0-only") , ("LGPL", CanSPDX (cabal "LGPL") "LicenseRef-LGPL") , ("LGPL-2.1", CanSPDX (cabal "LGPL-2.1") "LGPL-2.1-only") , ("LGPL-3", CanSPDX (cabal "LGPL-3") "LGPL-3.0-only") , ("AGPL", CanSPDX (cabal "AGPL") "LicenseRef-AGPL") , ("AGPL-3", CanSPDX (cabal "AGPL-3") "AGPL-3.0-only") , ("BSD2", CanSPDX (cabal "BSD2") "BSD-2-Clause") , ("BSD3", CanSPDX (cabal "BSD3") "BSD-3-Clause") , ("BSD4", CanSPDX (cabal "BSD4") "BSD-4-Clause") , ("MIT", CanSPDX (cabal "MIT") "MIT") , ("ISC", CanSPDX (cabal "ISC") "ISC") , ("MPL-2.0", CanSPDX (cabal "MPL-2.0") "MPL-2.0") , ("Apache", CanSPDX (cabal "Apache") "LicenseRef-Apache") , ("Apache-2.0", CanSPDX (cabal "Apache-2.0") "Apache-2.0") , ("PublicDomain", CanSPDX (cabal "PublicDomain") "LicenseRef-PublicDomain") , ("OtherLicense", CanSPDX (cabal "OtherLicense") "LicenseRef-OtherLicense") , ("AllRightsReserved", CanSPDX (cabal "AllRightsReserved") "NONE") ] spdxLicenses :: [(String, License String)] spdxLicenses = [ ("GPL-2.0-or-later", MustSPDX "GPL-2.0-or-later") ] unknownLicenses :: [(String, License String)] unknownLicenses = [ ("some-license", DontTouch "some-license") ] spec :: Spec spec = do describe "parseLicense" $ do forM_ (cabalLicenses ++ spdxLicenses ++ unknownLicenses) $ \ (license, expected) -> do it [i|parses #{license}|] $ do prettyShow <$> parseLicense license `shouldBe` expected hpack-0.34.2/test/Hpack/OptionsSpec.hs0000644000000000000000000000734113665434154015703 0ustar0000000000000000module Hpack.OptionsSpec (spec) where import Helper import Hpack.Options spec :: Spec spec = do describe "parseOptions" $ do let defaultTarget = "package.yaml" context "with --help" $ do it "returns Help" $ do parseOptions defaultTarget ["--help"] `shouldReturn` Help context "with --version" $ do it "returns PrintVersion" $ do parseOptions defaultTarget ["--version"] `shouldReturn` PrintVersion context "by default" $ do it "returns Run" $ do parseOptions defaultTarget [] `shouldReturn` Run (ParseOptions Verbose NoForce Nothing False defaultTarget) it "includes target" $ do parseOptions defaultTarget ["foo.yaml"] `shouldReturn` Run (ParseOptions Verbose NoForce Nothing False "foo.yaml") context "with superfluous arguments" $ do it "returns ParseError" $ do parseOptions defaultTarget ["foo", "bar"] `shouldReturn` ParseError context "with --silent" $ do it "sets optionsVerbose to NoVerbose" $ do parseOptions defaultTarget ["--silent"] `shouldReturn` Run (ParseOptions NoVerbose NoForce Nothing False defaultTarget) context "with --force" $ do it "sets optionsForce to Force" $ do parseOptions defaultTarget ["--force"] `shouldReturn` Run (ParseOptions Verbose Force Nothing False defaultTarget) context "with -f" $ do it "sets optionsForce to Force" $ do parseOptions defaultTarget ["-f"] `shouldReturn` Run (ParseOptions Verbose Force Nothing False defaultTarget) context "when determining parseOptionsHash" $ do it "assumes True on --hash" $ do parseOptions defaultTarget ["--hash"] `shouldReturn` Run (ParseOptions Verbose NoForce (Just True) False defaultTarget) it "assumes False on --no-hash" $ do parseOptions defaultTarget ["--no-hash"] `shouldReturn` Run (ParseOptions Verbose NoForce (Just False) False defaultTarget) it "gives last occurrence precedence" $ do parseOptions defaultTarget ["--no-hash", "--hash"] `shouldReturn` Run (ParseOptions Verbose NoForce (Just True) False defaultTarget) parseOptions defaultTarget ["--hash", "--no-hash"] `shouldReturn` Run (ParseOptions Verbose NoForce (Just False) False defaultTarget) context "with -" $ do it "sets optionsToStdout to True, implies Force and NoVerbose" $ do parseOptions defaultTarget ["-"] `shouldReturn` Run (ParseOptions NoVerbose Force Nothing True defaultTarget) it "rejects - for target" $ do parseOptions defaultTarget ["-", "-"] `shouldReturn` ParseError describe "expandTarget" $ around_ inTempDirectory $ do let defaultTarget = "foo.yaml" context "when target is Nothing" $ do it "return default file" $ do expandTarget defaultTarget Nothing `shouldReturn` defaultTarget context "when target is a file" $ do it "return file" $ do let file = "foo/bar.yaml" touch file expandTarget defaultTarget (Just file) `shouldReturn` file context "when target is a directory" $ do it "appends default file" $ do touch "foo/.placeholder" expandTarget defaultTarget (Just "foo") `shouldReturn` "foo" defaultTarget context "when target file does not exist" $ do it "return target file" $ do expandTarget defaultTarget (Just "foo/bar") `shouldReturn` "foo/bar" context "when target directory does not exist" $ do it "appends default file" $ do expandTarget defaultTarget (Just "foo/") `shouldReturn` ("foo/" ++ defaultTarget) context "when target is the empty string" $ do it "return default file" $ do expandTarget defaultTarget (Just "") `shouldReturn` defaultTarget hpack-0.34.2/test/Hpack/ConfigSpec.hs0000644000000000000000000005672413665434154015466 0ustar0000000000000000{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ConstraintKinds #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Hpack.ConfigSpec ( spec , package , deps , defaultInfo ) where import Helper import Data.Aeson.Config.FromValueSpec hiding (spec) import Data.String.Interpolate.IsString import Control.Arrow import qualified GHC.Exts as Exts import System.Directory (createDirectory) import Data.Either import qualified Data.Map.Lazy as Map import Control.Monad.Trans.Writer (runWriter) import Hpack.Syntax.Dependencies import Hpack.Syntax.DependencyVersion import Hpack.Syntax.BuildTools import Hpack.Config hiding (package) import qualified Hpack.Config as Config import Data.Aeson.Config.Types import Data.Aeson.Config.FromValue instance Exts.IsList (Maybe (List a)) where type Item (Maybe (List a)) = a fromList = Just . List toList = undefined defaultInfo :: DependencyInfo defaultInfo = DependencyInfo [] anyVersion deps :: [String] -> Dependencies deps = Dependencies . Map.fromList . map (flip (,) defaultInfo) package :: Package package = Config.package "foo" "0.0.0" executable :: String -> Executable executable main_ = Executable (Just main_) ["Paths_foo"] [] library :: Library library = Library Nothing Nothing [] ["Paths_foo"] [] [] [] testDecodeOptions :: FilePath -> DecodeOptions testDecodeOptions file = defaultDecodeOptions {decodeOptionsTarget = file, decodeOptionsUserDataDir = Just undefined} withPackage :: HasCallStack => String -> IO () -> ((Package, [String]) -> Expectation) -> Expectation withPackage content beforeAction expectation = withTempDirectory $ \dir_ -> do let dir = dir_ "foo" createDirectory dir writeFile (dir "package.yaml") content withCurrentDirectory dir beforeAction r <- readPackageConfig (testDecodeOptions $ dir "package.yaml") either expectationFailure (\ (DecodeResult p _ _ warnings) -> expectation (p, warnings)) r withPackageConfig :: String -> IO () -> (Package -> Expectation) -> Expectation withPackageConfig content beforeAction expectation = withPackage content beforeAction (expectation . fst) withPackageConfig_ :: String -> (Package -> Expectation) -> Expectation withPackageConfig_ content = withPackageConfig content (return ()) withPackageWarnings :: HasCallStack => String -> IO () -> ([String] -> Expectation) -> Expectation withPackageWarnings content beforeAction expectation = withPackage content beforeAction (expectation . snd) withPackageWarnings_ :: HasCallStack => String -> ([String] -> Expectation) -> Expectation withPackageWarnings_ content = withPackageWarnings content (return ()) spec :: Spec spec = do describe "pathsModuleFromPackageName" $ do it "replaces dashes with underscores in package name" $ do pathsModuleFromPackageName "foo-bar" `shouldBe` "Paths_foo_bar" describe "fromLibrarySectionInConditional" $ do let sect = LibrarySection { librarySectionExposed = Nothing , librarySectionVisibility = Nothing , librarySectionExposedModules = Nothing , librarySectionGeneratedExposedModules = Nothing , librarySectionOtherModules = Nothing , librarySectionGeneratedOtherModules = Nothing , librarySectionReexportedModules = Nothing , librarySectionSignatures = Nothing } lib = Library { libraryExposed = Nothing , libraryVisibility = Nothing , libraryExposedModules = [] , libraryOtherModules = [] , libraryGeneratedModules = [] , libraryReexportedModules = [] , librarySignatures = [] } inferableModules = ["Foo", "Bar"] from = fromLibrarySectionInConditional inferableModules context "when inferring modules" $ do it "infers other-modules" $ do from sect `shouldBe` lib {libraryOtherModules = ["Foo", "Bar"]} context "with exposed-modules" $ do it "infers nothing" $ do from sect {librarySectionExposedModules = []} `shouldBe` lib context "with other-modules" $ do it "infers nothing" $ do from sect {librarySectionOtherModules = []} `shouldBe` lib describe "renamePackage" $ do it "renames a package" $ do renamePackage "bar" package `shouldBe` package {packageName = "bar"} it "renames dependencies on self" $ do let packageWithExecutable dependencies = package {packageExecutables = Map.fromList [("main", (section $ executable "Main.hs") {sectionDependencies = deps dependencies})]} renamePackage "bar" (packageWithExecutable ["foo"]) `shouldBe` (packageWithExecutable ["bar"]) {packageName = "bar"} describe "renameDependencies" $ do let sectionWithDeps dependencies = (section ()) {sectionDependencies = deps dependencies} it "renames dependencies" $ do renameDependencies "bar" "baz" (sectionWithDeps ["foo", "bar"]) `shouldBe` sectionWithDeps ["foo", "baz"] it "renames dependency in conditionals" $ do let sectionWithConditional dependencies = (section ()) { sectionConditionals = [ Conditional { conditionalCondition = "some condition" , conditionalThen = sectionWithDeps dependencies , conditionalElse = Just (sectionWithDeps dependencies) } ] } renameDependencies "bar" "baz" (sectionWithConditional ["foo", "bar"]) `shouldBe` sectionWithConditional ["foo", "baz"] describe "getModules" $ around withTempDirectory $ do it "returns Haskell modules in specified source directory" $ \dir -> do touch (dir "src/Foo.hs") touch (dir "src/Bar/Baz.hs") touch (dir "src/Setup.hs") getModules dir "src" >>= (`shouldMatchList` ["Foo", "Bar.Baz", "Setup"]) context "when source directory is '.'" $ do it "ignores Setup" $ \dir -> do touch (dir "Foo.hs") touch (dir "Setup.hs") getModules dir "." `shouldReturn` ["Foo"] context "when source directory is './.'" $ do it "ignores Setup" $ \dir -> do touch (dir "Foo.hs") touch (dir "Setup.hs") getModules dir "./." `shouldReturn` ["Foo"] describe "toBuildTool" $ do let toBuildTool_ name = runWriter $ toBuildTool "my-package" ["foo"] (name, anyVersion) context "with an UnqualifiedBuildTool" $ do context "when name does not match a local executable" $ do it "returns a BuildTool" $ do toBuildTool_ (UnqualifiedBuildTool "bar") `shouldBe` (Right (BuildTool "bar" "bar", anyVersion), []) context "when name matches a local executable" $ do it "returns a LocalBuildTool" $ do toBuildTool_ (UnqualifiedBuildTool "foo") `shouldBe` (Right (LocalBuildTool "foo", anyVersion), []) context "when name matches a legacy executable" $ do it "warns" $ do toBuildTool_ (UnqualifiedBuildTool "gtk2hsTypeGen") `shouldBe` (Right (BuildTool "gtk2hs-buildtools" "gtk2hsTypeGen", anyVersion), ["Usage of the unqualified build-tool name \"gtk2hsTypeGen\" is deprecated! Please use the qualified name \"gtk2hs-buildtools:gtk2hsTypeGen\" instead!"]) context "when name matches a legacy system build tool" $ do it "warns" $ do toBuildTool_ (UnqualifiedBuildTool "ghc") `shouldBe` (Left ("ghc", AnyVersion), ["Listing \"ghc\" under build-tools is deperecated! Please list system executables under system-build-tools instead!"]) context "with a QualifiedBuildTool" $ do context "when only package matches the current package" $ do it "returns a BuildTool" $ do toBuildTool_ (QualifiedBuildTool "my-package" "bar") `shouldBe` (Right (BuildTool "my-package" "bar", anyVersion), []) context "when only executable matches a local executable" $ do it "returns a BuildTool" $ do toBuildTool_ (QualifiedBuildTool "other-package" "foo") `shouldBe` (Right (BuildTool "other-package" "foo", anyVersion), []) context "when both package matches the current package and executable matches a local executable" $ do it "returns a LocalBuildTool" $ do toBuildTool_ (QualifiedBuildTool "my-package" "foo") `shouldBe` (Right (LocalBuildTool "foo", anyVersion), []) describe "readPackageConfig" $ do it "warns on missing name" $ do withPackageWarnings_ [i| {} |] (`shouldBe` [ "Package name not specified, inferred \"foo\"" ] ) it "infers name" $ do withPackageConfig_ [i| {} |] (packageName >>> (`shouldBe` "foo")) it "accepts name" $ do withPackageConfig_ [i| name: bar |] (packageName >>> (`shouldBe` "bar")) it "accepts version" $ do withPackageConfig_ [i| version: 0.1.0 |] (packageVersion >>> (`shouldBe` "0.1.0")) it "accepts synopsis" $ do withPackageConfig_ [i| synopsis: some synopsis |] (packageSynopsis >>> (`shouldBe` Just "some synopsis")) it "accepts description" $ do withPackageConfig_ [i| description: some description |] (packageDescription >>> (`shouldBe` Just "some description")) it "accepts category" $ do withPackageConfig_ [i| category: Data |] (`shouldBe` package {packageCategory = Just "Data"}) it "accepts author" $ do withPackageConfig_ [i| author: John Doe |] (`shouldBe` package {packageAuthor = ["John Doe"] ,packageMaintainer = ["John Doe"]}) it "accepts maintainer" $ do withPackageConfig_ [i| maintainer: John Doe |] (`shouldBe` package {packageMaintainer = ["John Doe "]}) it "accepts copyright" $ do withPackageConfig_ [i| copyright: (c) 2015 John Doe |] (`shouldBe` package {packageCopyright = ["(c) 2015 John Doe"]}) it "accepts stability" $ do withPackageConfig_ [i| stability: experimental |] (packageStability >>> (`shouldBe` Just "experimental")) it "accepts license" $ do withPackageConfig_ [i| license: MIT |] (`shouldBe` package {packageLicense = Just "MIT"}) it "infers license file" $ do withPackageConfig [i| name: foo |] (do touch "LICENSE" ) (packageLicenseFile >>> (`shouldBe` ["LICENSE"])) it "accepts license file" $ do withPackageConfig_ [i| license-file: FOO |] (packageLicenseFile >>> (`shouldBe` ["FOO"])) it "accepts list of license files" $ do withPackageConfig_ [i| license-file: [FOO, BAR] |] (packageLicenseFile >>> (`shouldBe` ["FOO", "BAR"])) it "accepts flags" $ do withPackageConfig_ [i| flags: integration-tests: description: Run the integration test suite manual: yes default: no |] (packageFlags >>> (`shouldBe` [Flag "integration-tests" (Just "Run the integration test suite") True False])) it "accepts extra-source-files" $ do withPackageConfig [i| extra-source-files: - CHANGES.markdown - README.markdown |] (do touch "CHANGES.markdown" touch "README.markdown" ) (packageExtraSourceFiles >>> (`shouldBe` ["CHANGES.markdown", "README.markdown"])) it "accepts arbitrary git URLs as source repository" $ do withPackageConfig_ [i| git: https://gitlab.com/gitlab-org/gitlab-ce.git |] (packageSourceRepository >>> (`shouldBe` Just (SourceRepository "https://gitlab.com/gitlab-org/gitlab-ce.git" Nothing))) it "accepts CPP options" $ do withPackageConfig_ [i| cpp-options: -DFOO library: cpp-options: -DLIB executables: foo: main: Main.hs cpp-options: -DFOO tests: spec: main: Spec.hs cpp-options: -DTEST |] (`shouldBe` package { packageLibrary = Just (section library) {sectionCppOptions = ["-DFOO", "-DLIB"]} , packageExecutables = Map.fromList [("foo", (section $ executable "Main.hs") {sectionCppOptions = ["-DFOO", "-DFOO"]})] , packageTests = Map.fromList [("spec", (section $ executable "Spec.hs") {sectionCppOptions = ["-DFOO", "-DTEST"]})] } ) it "accepts cc-options" $ do withPackageConfig_ [i| cc-options: -Wall library: cc-options: -fLIB executables: foo: main: Main.hs cc-options: -O2 tests: spec: main: Spec.hs cc-options: -O0 |] (`shouldBe` package { packageLibrary = Just (section library) {sectionCcOptions = ["-Wall", "-fLIB"]} , packageExecutables = Map.fromList [("foo", (section $ executable "Main.hs") {sectionCcOptions = ["-Wall", "-O2"]})] , packageTests = Map.fromList [("spec", (section $ executable "Spec.hs") {sectionCcOptions = ["-Wall", "-O0"]})] } ) it "accepts ghcjs-options" $ do withPackageConfig_ [i| ghcjs-options: -dedupe library: ghcjs-options: -ghcjs1 executables: foo: main: Main.hs ghcjs-options: -ghcjs2 tests: spec: main: Spec.hs ghcjs-options: -ghcjs3 |] (`shouldBe` package { packageLibrary = Just (section library) {sectionGhcjsOptions = ["-dedupe", "-ghcjs1"]} , packageExecutables = Map.fromList [("foo", (section $ executable "Main.hs") {sectionGhcjsOptions = ["-dedupe", "-ghcjs2"]})] , packageTests = Map.fromList [("spec", (section $ executable "Spec.hs") {sectionGhcjsOptions = ["-dedupe", "-ghcjs3"]})] } ) it "accepts ld-options" $ do withPackageConfig_ [i| library: ld-options: -static |] (`shouldBe` package { packageLibrary = Just (section library) {sectionLdOptions = ["-static"]} } ) it "accepts buildable" $ do withPackageConfig_ [i| buildable: no library: buildable: yes executables: foo: main: Main.hs |] (`shouldBe` package { packageLibrary = Just (section library) {sectionBuildable = Just True} , packageExecutables = Map.fromList [("foo", (section $ executable "Main.hs") {sectionBuildable = Just False})] } ) it "allows yaml merging and overriding fields" $ do withPackageConfig_ [i| _common: &common name: n1 <<: *common name: n2 |] (packageName >>> (`shouldBe` "n2")) context "when reading library section" $ do it "accepts source-dirs" $ do withPackageConfig_ [i| library: source-dirs: - foo - bar |] (packageLibrary >>> (`shouldBe` Just (section library) {sectionSourceDirs = ["foo", "bar"]})) it "accepts default-extensions" $ do withPackageConfig_ [i| library: default-extensions: - Foo - Bar |] (packageLibrary >>> (`shouldBe` Just (section library) {sectionDefaultExtensions = ["Foo", "Bar"]})) it "accepts global default-extensions" $ do withPackageConfig_ [i| default-extensions: - Foo - Bar library: {} |] (packageLibrary >>> (`shouldBe` Just (section library) {sectionDefaultExtensions = ["Foo", "Bar"]})) it "accepts global source-dirs" $ do withPackageConfig_ [i| source-dirs: - foo - bar library: {} |] (packageLibrary >>> (`shouldBe` Just (section library) {sectionSourceDirs = ["foo", "bar"]})) it "allows to specify exposed" $ do withPackageConfig_ [i| library: exposed: no |] (packageLibrary >>> (`shouldBe` Just (section library{libraryExposed = Just False}))) context "when reading executable section" $ do it "reads executables section" $ do withPackageConfig_ [i| executables: foo: main: driver/Main.hs |] (packageExecutables >>> (`shouldBe` Map.fromList [("foo", section $ executable "driver/Main.hs")])) it "reads executable section" $ do withPackageConfig_ [i| executable: main: driver/Main.hs |] (packageExecutables >>> (`shouldBe` Map.fromList [("foo", section $ executable "driver/Main.hs")])) context "with both executable and executables" $ do it "gives executable precedence" $ do withPackageConfig_ [i| executable: main: driver/Main1.hs executables: foo2: main: driver/Main2.hs |] (packageExecutables >>> (`shouldBe` Map.fromList [("foo", section $ executable "driver/Main1.hs")])) it "warns" $ do withPackageWarnings_ [i| name: foo executable: main: driver/Main1.hs executables: foo2: main: driver/Main2.hs |] (`shouldBe` ["Ignoring field \"executables\" in favor of \"executable\""]) it "accepts source-dirs" $ do withPackageConfig_ [i| executables: foo: main: Main.hs source-dirs: - foo - bar |] (packageExecutables >>> (`shouldBe` Map.fromList [("foo", (section (executable "Main.hs") {executableOtherModules = ["Paths_foo"]}) {sectionSourceDirs = ["foo", "bar"]})])) it "accepts global source-dirs" $ do withPackageConfig_ [i| source-dirs: - foo - bar executables: foo: main: Main.hs |] (packageExecutables >>> (`shouldBe` Map.fromList [("foo", (section (executable "Main.hs") {executableOtherModules = ["Paths_foo"]}) {sectionSourceDirs = ["foo", "bar"]})])) it "accepts default-extensions" $ do withPackageConfig_ [i| executables: foo: main: driver/Main.hs default-extensions: - Foo - Bar |] (packageExecutables >>> (`shouldBe` Map.fromList [("foo", (section $ executable "driver/Main.hs") {sectionDefaultExtensions = ["Foo", "Bar"]})])) it "accepts global default-extensions" $ do withPackageConfig_ [i| default-extensions: - Foo - Bar executables: foo: main: driver/Main.hs |] (packageExecutables >>> (`shouldBe` Map.fromList [("foo", (section $ executable "driver/Main.hs") {sectionDefaultExtensions = ["Foo", "Bar"]})])) it "accepts GHC options" $ do withPackageConfig_ [i| executables: foo: main: driver/Main.hs ghc-options: -Wall |] (`shouldBe` package {packageExecutables = Map.fromList [("foo", (section $ executable "driver/Main.hs") {sectionGhcOptions = ["-Wall"]})]}) it "accepts global GHC options" $ do withPackageConfig_ [i| ghc-options: -Wall executables: foo: main: driver/Main.hs |] (`shouldBe` package {packageExecutables = Map.fromList [("foo", (section $ executable "driver/Main.hs") {sectionGhcOptions = ["-Wall"]})]}) it "accepts GHC profiling options" $ do withPackageConfig_ [i| executables: foo: main: driver/Main.hs ghc-prof-options: -fprof-auto |] (`shouldBe` package {packageExecutables = Map.fromList [("foo", (section $ executable "driver/Main.hs") {sectionGhcProfOptions = ["-fprof-auto"]})]}) it "accepts global GHC profiling options" $ do withPackageConfig_ [i| ghc-prof-options: -fprof-auto executables: foo: main: driver/Main.hs |] (`shouldBe` package {packageExecutables = Map.fromList [("foo", (section $ executable "driver/Main.hs") {sectionGhcProfOptions = ["-fprof-auto"]})]}) context "when reading test section" $ do it "reads test section" $ do withPackageConfig_ [i| tests: spec: main: test/Spec.hs |] (`shouldBe` package {packageTests = Map.fromList [("spec", section $ executable "test/Spec.hs")]}) context "when a specified source directory does not exist" $ do it "warns" $ do withPackageWarnings [i| name: foo source-dirs: - some-dir - some-existing-dir library: source-dirs: some-lib-dir executables: main: main: Main.hs source-dirs: some-exec-dir tests: spec: main: Main.hs source-dirs: some-test-dir |] (do touch "some-existing-dir/foo" ) (`shouldBe` [ "Specified source-dir \"some-dir\" does not exist" , "Specified source-dir \"some-exec-dir\" does not exist" , "Specified source-dir \"some-lib-dir\" does not exist" , "Specified source-dir \"some-test-dir\" does not exist" ] ) around withTempDirectory $ do context "when package.yaml can not be parsed" $ do it "returns an error" $ \dir -> do let file = dir "package.yaml" writeFile file [i| foo: bar foo baz |] readPackageConfig (testDecodeOptions file) `shouldReturn` Left (file ++ ":3:12: could not find expected ':' while scanning a simple key") context "when package.yaml is invalid" $ do it "returns an error" $ \dir -> do let file = dir "package.yaml" writeFile file [i| - one - two |] readPackageConfig (testDecodeOptions file) >>= (`shouldSatisfy` isLeft) context "when package.yaml does not exist" $ do it "returns an error" $ \dir -> do let file = dir "package.yaml" readPackageConfig (testDecodeOptions file) `shouldReturn` Left [i|#{file}: Yaml file not found: #{file}|] describe "fromValue" $ do context "with Cond" $ do it "accepts Strings" $ do [yaml| os(windows) |] `shouldDecodeTo_` Cond "os(windows)" it "accepts True" $ do [yaml| yes |] `shouldDecodeTo_` Cond "true" it "accepts False" $ do [yaml| no |] `shouldDecodeTo_` Cond "false" it "rejects other values" $ do [yaml| 23 |] `shouldDecodeTo` (Left "Error while parsing $ - expected Boolean or String, but encountered Number" :: Result Cond) describe "formatOrList" $ do it "formats a singleton list" $ do formatOrList ["foo"] `shouldBe` "foo" it "formats a 2-element list" $ do formatOrList ["foo", "bar"] `shouldBe` "foo or bar" it "formats an n-element list" $ do formatOrList ["foo", "bar", "baz"] `shouldBe` "foo, bar, or baz" hpack-0.34.2/test/Hpack/CabalFileSpec.hs0000644000000000000000000000501413665434154016045 0ustar0000000000000000{-# LANGUAGE QuasiQuotes #-} module Hpack.CabalFileSpec (spec) where import Helper import Test.QuickCheck import Data.Version (showVersion) import Data.String.Interpolate import Data.String.Interpolate.Util import Paths_hpack (version) import Hpack.Util (Hash) import Data.Version (Version) import Hpack (header) import Hpack.CabalFile mkHeader :: FilePath -> Version -> Hash -> String mkHeader p v hash = unlines $ header p (Just v) (Just hash) spec :: Spec spec = do describe "readCabalFile" $ do let file = "hello.cabal" hash = "some-hash" it "includes hash" $ do inTempDirectory $ do writeFile file $ mkHeader "package.yaml" version hash readCabalFile file `shouldReturn` Just (CabalFile [] (Just version) (Just hash) []) it "accepts cabal-version at the beginning of the file" $ do inTempDirectory $ do writeFile file $ ("cabal-version: 2.2\n" ++ mkHeader "package.yaml" version hash) readCabalFile file `shouldReturn` Just (CabalFile ["cabal-version: 2.2"] (Just version) (Just hash) []) describe "extractVersion" $ do it "extracts Hpack version from a cabal file" $ do let cabalFile = ["-- This file has been generated from package.yaml by hpack version 0.10.0."] extractVersion cabalFile `shouldBe` Just (makeVersion [0, 10, 0]) it "is agnostic to file name" $ do let cabalFile = ["-- This file has been generated from some random file by hpack version 0.10.0."] extractVersion cabalFile `shouldBe` Just (makeVersion [0, 10, 0]) it "is total" $ do let cabalFile = ["-- This file has been generated from package.yaml by hpack version "] extractVersion cabalFile `shouldBe` Nothing describe "parseVersion" $ do it "is inverse to showVersion" $ do let positive = getPositive <$> arbitrary forAll (replicateM 3 positive) $ \xs -> do let v = makeVersion xs parseVersion (showVersion v) `shouldBe` Just v describe "removeGitConflictMarkers" $ do it "remove git conflict markers (git checkout --ours)" $ do let input = lines $ unindent [i| foo <<<<<<< 4a1ca1694ed77195a080688df9bef53c23045211 bar2 ======= bar1 >>>>>>> update foo on branch foo baz |] expected = lines $ unindent [i| foo bar2 baz |] removeGitConflictMarkers input `shouldBe` expected hpack-0.34.2/test/Hpack/UtilSpec.hs0000644000000000000000000001232013665434154015156 0ustar0000000000000000module Hpack.UtilSpec (main, spec) where import Helper import System.Directory import Hpack.Util main :: IO () main = hspec spec spec :: Spec spec = do describe "sort" $ do it "sorts lexicographically" $ do sort ["foo", "Foo"] `shouldBe` ["Foo", "foo" :: String] describe "parseMain" $ do it "accepts source file" $ do parseMain "Main.hs" `shouldBe` ("Main.hs", []) it "accepts literate source file" $ do parseMain "Main.lhs" `shouldBe` ("Main.lhs", []) it "accepts module" $ do parseMain "Foo" `shouldBe` ("Foo.hs", ["-main-is Foo"]) it "accepts hierarchical module" $ do parseMain "Foo.Bar.Baz" `shouldBe` ("Foo/Bar/Baz.hs", ["-main-is Foo.Bar.Baz"]) it "accepts qualified identifier" $ do parseMain "Foo.bar" `shouldBe` ("Foo.hs", ["-main-is Foo.bar"]) describe "toModule" $ do it "maps .hs paths to module names" $ do toModule ["Foo", "Bar", "Baz.hs"] `shouldBe` Just "Foo.Bar.Baz" it "maps .lhs paths to module names" $ do toModule ["Foo", "Bar", "Baz.lhs"] `shouldBe` Just "Foo.Bar.Baz" it "maps .hsc paths to module names" $ do toModule ["Foo", "Bar", "Baz.hsc"] `shouldBe` Just "Foo.Bar.Baz" it "rejects invalid module names" $ do toModule ["resources", "hello.hs"] `shouldBe` Nothing describe "getModuleFilesRecursive" $ do it "gets all files from given directory" $ do inTempDirectory $ do touch "foo/bar" touch "foo/baz" actual <- getModuleFilesRecursive "foo" actual `shouldMatchList` [ ["bar"] , ["baz"] ] it "descends into subdirectories" $ do inTempDirectory $ do touch "foo/Bar/baz" getModuleFilesRecursive "foo" `shouldReturn` [["Bar", "baz"]] context "when a subdirectory is not a valid module name" $ do it "does not descend" $ do inTempDirectory $ do touch "foo/bar/baz" getModuleFilesRecursive "foo" `shouldReturn` empty describe "tryReadFile" $ do it "reads file" $ do inTempDirectory $ do writeFile "foo" "bar" tryReadFile "foo" `shouldReturn` Just "bar" it "returns Nothing if file does not exist" $ do inTempDirectory $ do tryReadFile "foo" `shouldReturn` Nothing describe "expandGlobs" $ around withTempDirectory $ do it "accepts literal files" $ \dir -> do touch (dir "foo.js") expandGlobs "field-name" dir ["foo.js"] `shouldReturn` ([], ["foo.js"]) it "keeps declaration order for literal files" $ \dir -> do touch (dir "foo.js") touch (dir "bar.js") expandGlobs "field-name" dir ["foo.js", "bar.js"] `shouldReturn` ([], ["foo.js", "bar.js"]) it "removes duplicates" $ \dir -> do touch (dir "foo.js") expandGlobs "field-name" dir ["foo.js", "*.js"] `shouldReturn` ([], ["foo.js"]) it "rejects directories" $ \dir -> do touch (dir "foo") createDirectory (dir "bar") expandGlobs "field-name" dir ["*"] `shouldReturn` ([], ["foo"]) it "rejects character ranges" $ \dir -> do touch (dir "foo1") touch (dir "foo2") touch (dir "foo[1,2]") expandGlobs "field-name" dir ["foo[1,2]"] `shouldReturn` ([], ["foo[1,2]"]) context "when expanding *" $ do it "expands by extension" $ \dir -> do let files = [ "files/foo.js" , "files/bar.js" , "files/baz.js"] mapM_ (touch . (dir )) files touch (dir "files/foo.hs") expandGlobs "field-name" dir ["files/*.js"] `shouldReturn` ([], sort files) it "rejects dot-files" $ \dir -> do touch (dir "foo/bar") touch (dir "foo/.baz") expandGlobs "field-name" dir ["foo/*"] `shouldReturn` ([], ["foo/bar"]) it "accepts dot-files when explicitly asked to" $ \dir -> do touch (dir "foo/bar") touch (dir "foo/.baz") expandGlobs "field-name" dir ["foo/.*"] `shouldReturn` ([], ["foo/.baz"]) it "matches at most one directory component" $ \dir -> do touch (dir "foo/bar/baz.js") touch (dir "foo/bar.js") expandGlobs "field-name" dir ["*/*.js"] `shouldReturn` ([], ["foo/bar.js"]) context "when expanding **" $ do it "matches arbitrary many directory components" $ \dir -> do let file = "foo/bar/baz.js" touch (dir file) expandGlobs "field-name" dir ["**/*.js"] `shouldReturn` ([], [file]) context "when a pattern does not match anything" $ do it "warns" $ \dir -> do expandGlobs "field-name" dir ["*.foo"] `shouldReturn` (["Specified pattern \"*.foo\" for field-name does not match any files"], []) context "when a pattern only matches a directory" $ do it "warns" $ \dir -> do createDirectory (dir "foo") expandGlobs "field-name" dir ["fo?"] `shouldReturn` (["Specified pattern \"fo?\" for field-name does not match any files"], []) context "when a literal file does not exist" $ do it "warns and keeps the file" $ \dir -> do expandGlobs "field-name" dir ["foo.js"] `shouldReturn` (["Specified file \"foo.js\" for field-name does not exist"], ["foo.js"]) hpack-0.34.2/test/Hpack/HaskellSpec.hs0000644000000000000000000000151513665434154015630 0ustar0000000000000000module Hpack.HaskellSpec (spec) where import Test.Hspec import Hpack.Haskell spec :: Spec spec = do describe "isModule" $ do it "accepts module names" $ do isModule ["Foo", "Bar"] `shouldBe` True it "rejects the empty list" $ do isModule [] `shouldBe` False describe "isQualifiedIdentifier" $ do it "accepts qualified Haskell identifiers" $ do isQualifiedIdentifier ["Foo", "Bar", "baz"] `shouldBe` True it "rejects invalid input" $ do isQualifiedIdentifier ["Foo", "Bar", "Baz"] `shouldBe` False describe "isIdentifier" $ do it "accepts Haskell identifiers" $ do isIdentifier "foo" `shouldBe` True it "rejects reserved keywords" $ do isIdentifier "case" `shouldBe` False it "rejects invalid input" $ do isIdentifier "Foo" `shouldBe` False hpack-0.34.2/test/Hpack/Utf8Spec.hs0000644000000000000000000000145413665434154015075 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Hpack.Utf8Spec (spec) where import Helper import qualified Data.ByteString as B import qualified Hpack.Utf8 as Utf8 spec :: Spec spec = do describe "readFile" $ do context "with a file that uses CRLF newlines" $ do it "applies newline conversion" $ do inTempDirectory $ do let name = "foo.txt" B.writeFile name "foo\r\nbar" Utf8.readFile name `shouldReturn` "foo\nbar" describe "writeFile" $ do it "uses system specific newline encoding" $ do inTempDirectory $ do let name = "foo.txt" c = "foo\nbar" writeFile name c systemSpecific <- B.readFile name Utf8.writeFile name c B.readFile name `shouldReturn` systemSpecific hpack-0.34.2/test/Hpack/Render/0000755000000000000000000000000013665434154014313 5ustar0000000000000000hpack-0.34.2/test/Hpack/Render/DslSpec.hs0000644000000000000000000001233313665434154016206 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Hpack.Render.DslSpec where import Test.Hspec import Test.QuickCheck import Data.List import Data.Maybe import Hpack.Render.Dsl spec :: Spec spec = do describe "render" $ do let render_ = render defaultRenderSettings 0 context "when rendering a Stanza" $ do it "renders stanza" $ do let stanza = Stanza "foo" [ Field "bar" "23" , Field "baz" "42" ] render_ stanza `shouldBe` [ "foo" , " bar: 23" , " baz: 42" ] it "omits empty fields" $ do let stanza = Stanza "foo" [ Field "bar" "23" , Field "baz" (WordList []) ] render_ stanza `shouldBe` [ "foo" , " bar: 23" ] it "allows to customize indentation" $ do let stanza = Stanza "foo" [ Field "bar" "23" , Field "baz" "42" ] render defaultRenderSettings{renderSettingsIndentation = 4} 0 stanza `shouldBe` [ "foo" , " bar: 23" , " baz: 42" ] it "renders nested stanzas" $ do let input = Stanza "foo" [Field "bar" "23", Stanza "baz" [Field "qux" "42"]] render_ input `shouldBe` [ "foo" , " bar: 23" , " baz" , " qux: 42" ] context "when rendering a Field" $ do context "when rendering a MultipleLines value" $ do it "takes nesting into account" $ do let field = Field "foo" (CommaSeparatedList ["bar", "baz"]) render defaultRenderSettings 1 field `shouldBe` [ " foo:" , " bar" , " , baz" ] context "when value is empty" $ do it "returns an empty list" $ do let field = Field "foo" (CommaSeparatedList []) render_ field `shouldBe` [] context "when rendering a SingleLine value" $ do it "returns a single line" $ do let field = Field "foo" (Literal "bar") render_ field `shouldBe` ["foo: bar"] it "takes nesting into account" $ do let field = Field "foo" (Literal "bar") render defaultRenderSettings 2 field `shouldBe` [" foo: bar"] it "takes alignment into account" $ do let field = Field "foo" (Literal "bar") render defaultRenderSettings {renderSettingsFieldAlignment = 10} 0 field `shouldBe` ["foo: bar"] context "when value is empty" $ do it "returns an empty list" $ do let field = Field "foo" (Literal "") render_ field `shouldBe` [] describe "renderValue" $ do it "renders WordList" $ do renderValue defaultRenderSettings (WordList ["foo", "bar", "baz"]) `shouldBe` SingleLine "foo bar baz" it "renders CommaSeparatedList" $ do renderValue defaultRenderSettings (CommaSeparatedList ["foo", "bar", "baz"]) `shouldBe` MultipleLines [ " foo" , ", bar" , ", baz" ] it "renders LineSeparatedList" $ do renderValue defaultRenderSettings (LineSeparatedList ["foo", "bar", "baz"]) `shouldBe` MultipleLines [ " foo" , " bar" , " baz" ] context "when renderSettingsCommaStyle is TrailingCommas" $ do let settings = defaultRenderSettings{renderSettingsCommaStyle = TrailingCommas} it "renders CommaSeparatedList with trailing commas" $ do renderValue settings (CommaSeparatedList ["foo", "bar", "baz"]) `shouldBe` MultipleLines [ "foo," , "bar," , "baz" ] it "renders LineSeparatedList without padding" $ do renderValue settings (LineSeparatedList ["foo", "bar", "baz"]) `shouldBe` MultipleLines [ "foo" , "bar" , "baz" ] describe "sortFieldsBy" $ do let field name = Field name (Literal $ name ++ " value") arbitraryFieldNames = sublistOf ["foo", "bar", "baz", "qux", "foobar", "foobaz"] >>= shuffle it "sorts fields" $ do let fields = map field ["baz", "bar", "foo"] sortFieldsBy ["foo", "bar", "baz"] fields `shouldBe` map field ["foo", "bar", "baz"] it "keeps existing field order" $ do forAll (map field <$> arbitraryFieldNames) $ \fields -> do forAll arbitraryFieldNames $ \existingFieldOrder -> do let existingIndex :: Element -> Maybe Int existingIndex (Field name _) = name `elemIndex` existingFieldOrder existingIndex _ = Nothing indexes :: [Int] indexes = mapMaybe existingIndex (sortFieldsBy existingFieldOrder fields) sort indexes `shouldBe` indexes it "is stable" $ do forAll arbitraryFieldNames $ \fieldNames -> do forAll (elements $ subsequences fieldNames) $ \existingFieldOrder -> do let fields = map field fieldNames sortFieldsBy existingFieldOrder fields `shouldBe` fields describe "addSortKey" $ do it "adds sort key" $ do addSortKey [(Nothing, "foo"), (Just 3, "bar"), (Nothing, "baz")] `shouldBe` [((-1, 0), "foo"), ((3, 1), "bar"), ((3, 2), "baz" :: String)] hpack-0.34.2/test/Hpack/Render/HintsSpec.hs0000644000000000000000000001105213665434154016546 0ustar0000000000000000module Hpack.Render.HintsSpec (spec) where import Test.Hspec import Hpack.Render.Hints import Hpack.Render.Dsl spec :: Spec spec = do describe "extractFieldOrder" $ do it "extracts field order hints" $ do let input = [ "name: cabalize" , "version: 0.0.0" , "license:" , "license-file: " , "build-type: Simple" ] extractFieldOrder input `shouldBe` [ "name" , "version" , "license" , "license-file" , "build-type" ] describe "extractSectionsFieldOrder" $ do it "splits input into sections" $ do let input = [ "name: cabalize" , "version: 0.0.0" , "" , "library" , " foo: 23" , " bar: 42" , "" , "executable foo" , " bar: 23" , " baz: 42" ] extractSectionsFieldOrder input `shouldBe` [("library", ["foo", "bar"]), ("executable foo", ["bar", "baz"])] describe "sanitize" $ do it "removes empty lines" $ do let input = [ "foo" , "" , " " , " bar " , " baz" ] sanitize input `shouldBe` [ "foo" , " bar" , " baz" ] it "removes trailing whitespace" $ do sanitize ["foo ", "bar "] `shouldBe` ["foo", "bar"] it "removes cabal-version" $ do sanitize ["cabal-version: 2.2", "bar "] `shouldBe` ["bar"] describe "unindent" $ do it "unindents" $ do let input = [ " foo" , " bar" , " baz" ] unindent input `shouldBe` [ " foo" , "bar" , " baz" ] describe "sniffAlignment" $ do it "sniffs field alignment from given cabal file" $ do let input = [ "name: cabalize" , "version: 0.0.0" , "license: MIT" , "license-file: LICENSE" , "build-type: Simple" ] sniffAlignment input `shouldBe` Just 16 it "ignores fields without a value on the same line" $ do let input = [ "name: cabalize" , "version: 0.0.0" , "description: " , " foo" , " bar" ] sniffAlignment input `shouldBe` Just 16 describe "splitField" $ do it "splits fields" $ do splitField "foo: bar" `shouldBe` Just ("foo", " bar") it "accepts fields names with dashes" $ do splitField "foo-bar: baz" `shouldBe` Just ("foo-bar", " baz") it "rejects fields names with spaces" $ do splitField "foo bar: baz" `shouldBe` Nothing it "rejects invalid fields" $ do splitField "foo bar" `shouldBe` Nothing describe "sniffIndentation" $ do it "sniff alignment from executable section" $ do let input = [ "name: foo" , "version: 0.0.0" , "" , "executable foo" , " build-depends: bar" ] sniffIndentation input `shouldBe` Just 4 it "sniff alignment from library section" $ do let input = [ "name: foo" , "version: 0.0.0" , "" , "library" , " build-depends: bar" ] sniffIndentation input `shouldBe` Just 4 it "ignores empty lines" $ do let input = [ "executable foo" , "" , " build-depends: bar" ] sniffIndentation input `shouldBe` Just 4 it "ignores whitespace lines" $ do let input = [ "executable foo" , " " , " build-depends: bar" ] sniffIndentation input `shouldBe` Just 4 describe "sniffCommaStyle" $ do it "detects leading commas" $ do let input = [ "executable foo" , " build-depends:" , " bar" , " , baz" ] sniffCommaStyle input `shouldBe` Just LeadingCommas it "detects trailing commas" $ do let input = [ "executable foo" , " build-depends:" , " bar, " , " baz" ] sniffCommaStyle input `shouldBe` Just TrailingCommas context "when detection fails" $ do it "returns Nothing" $ do sniffCommaStyle [] `shouldBe` Nothing hpack-0.34.2/test/Hpack/Syntax/0000755000000000000000000000000013665434154014362 5ustar0000000000000000hpack-0.34.2/test/Hpack/Syntax/DefaultsSpec.hs0000644000000000000000000001174713665434154017312 0ustar0000000000000000{-# LANGUAGE QuasiQuotes #-} module Hpack.Syntax.DefaultsSpec (spec) where import Helper import Data.Aeson.Config.FromValueSpec hiding (spec) import Data.Aeson.Config.FromValue import Hpack.Syntax.Defaults defaultsGithub :: String -> String -> String -> [FilePath] -> Defaults defaultsGithub owner repo ref path = DefaultsGithub $ Github owner repo ref path spec :: Spec spec = do describe "isValidOwner" $ do it "rejects the empty string" $ do isValidOwner "" `shouldBe` False it "accepts valid owner names" $ do isValidOwner "Foo-Bar-23" `shouldBe` True it "rejects dots" $ do isValidOwner "foo.bar" `shouldBe` False it "rejects multiple consecutive hyphens" $ do isValidOwner "foo--bar" `shouldBe` False it "rejects hyphens at the beginning" $ do isValidOwner "-foo" `shouldBe` False it "rejects hyphens at the end" $ do isValidOwner "foo-" `shouldBe` False describe "isValidRepo" $ do it "rejects the empty string" $ do isValidRepo "" `shouldBe` False it "rejects ." $ do isValidRepo "." `shouldBe` False it "rejects .." $ do isValidRepo ".." `shouldBe` False it "accepts underscores" $ do isValidRepo "foo_bar" `shouldBe` True it "accepts dots" $ do isValidRepo "foo.bar" `shouldBe` True it "accepts hyphens" $ do isValidRepo "foo-bar" `shouldBe` True describe "fromValue" $ do context "when parsing Defaults" $ do let left :: String -> Result Defaults left = Left context "with Object" $ do it "fails when neither github nor local is present" $ do [yaml| defaults: foo: one bar: two library: {} |] `shouldDecodeTo` left "Error while parsing $ - neither key \"github\" nor key \"local\" present" it "accepts Defaults from GitHub" $ do [yaml| github: sol/hpack ref: 0.1.0 path: defaults.yaml |] `shouldDecodeTo_` defaultsGithub "sol" "hpack" "0.1.0" ["defaults.yaml"] it "rejects invalid owner names" $ do [yaml| github: ../hpack ref: 0.1.0 path: defaults.yaml |] `shouldDecodeTo` left "Error while parsing $.github - invalid owner name \"..\"" it "rejects invalid repository names" $ do [yaml| github: sol/.. ref: 0.1.0 path: defaults.yaml |] `shouldDecodeTo` left "Error while parsing $.github - invalid repository name \"..\"" it "rejects invalid Git references" $ do [yaml| github: sol/hpack ref: ../foo/bar path: defaults.yaml |] `shouldDecodeTo` left "Error while parsing $.ref - invalid Git reference \"../foo/bar\"" it "rejects \\ in path" $ do [yaml| github: sol/hpack ref: 0.1.0 path: hpack\defaults.yaml |] `shouldDecodeTo` left "Error while parsing $.path - rejecting '\\' in \"hpack\\\\defaults.yaml\", please use '/' to separate path components" it "rejects : in path" $ do [yaml| github: sol/hpack ref: 0.1.0 path: foo:bar.yaml |] `shouldDecodeTo` left "Error while parsing $.path - rejecting ':' in \"foo:bar.yaml\"" it "rejects absolute paths" $ do [yaml| github: sol/hpack ref: 0.1.0 path: /defaults.yaml |] `shouldDecodeTo` left "Error while parsing $.path - rejecting absolute path \"/defaults.yaml\"" it "rejects .. in path" $ do [yaml| github: sol/hpack ref: 0.1.0 path: ../../defaults.yaml |] `shouldDecodeTo` left "Error while parsing $.path - rejecting \"..\" in \"../../defaults.yaml\"" context "with String" $ do it "accepts Defaults from GitHub" $ do [yaml| sol/hpack@0.1.0 |] `shouldDecodeTo_` defaultsGithub "sol" "hpack" "0.1.0" [".hpack", "defaults.yaml"] it "rejects invalid owner names" $ do [yaml| ../hpack@0.1.0 |] `shouldDecodeTo` left "Error while parsing $ - invalid owner name \"..\"" it "rejects invalid repository names" $ do [yaml| sol/..@0.1.0 |] `shouldDecodeTo` left "Error while parsing $ - invalid repository name \"..\"" it "rejects invalid Git references" $ do [yaml| sol/pack@../foo/bar |] `shouldDecodeTo` left "Error while parsing $ - invalid Git reference \"../foo/bar\"" it "rejects missing Git reference" $ do [yaml| sol/hpack |] `shouldDecodeTo` left "Error while parsing $ - missing Git reference for \"sol/hpack\", the expected format is owner/repo@ref" context "with neither Object nor String" $ do it "fails" $ do [yaml| 10 |] `shouldDecodeTo` left "Error while parsing $ - expected Object or String, but encountered Number" hpack-0.34.2/test/Hpack/Syntax/BuildToolsSpec.hs0000644000000000000000000000747113665434154017622 0ustar0000000000000000{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE OverloadedLists #-} module Hpack.Syntax.BuildToolsSpec (spec) where import Helper import Data.Aeson.Config.FromValueSpec (shouldDecodeTo_) import Hpack.Syntax.DependencyVersion import Hpack.Syntax.BuildTools spec :: Spec spec = do describe "fromValue" $ do context "when parsing BuildTools" $ do context "with a scalar" $ do it "accepts qualified names" $ do [yaml| foo:bar |] `shouldDecodeTo_` BuildTools [(QualifiedBuildTool "foo" "bar", anyVersion)] it "accepts qualified names with a version" $ do [yaml| foo:bar >= 0.1.0 |] `shouldDecodeTo_` BuildTools [(QualifiedBuildTool "foo" "bar", versionRange ">=0.1.0")] it "accepts unqualified names" $ do [yaml| foo |] `shouldDecodeTo_` BuildTools [(UnqualifiedBuildTool "foo", anyVersion)] it "accepts unqualified names with a version" $ do [yaml| foo >= 0.1.0 |] `shouldDecodeTo_` BuildTools [(UnqualifiedBuildTool "foo", versionRange ">=0.1.0")] context "with a mapping" $ do it "accepts qualified names" $ do [yaml| foo:bar: 0.1.0 |] `shouldDecodeTo_` BuildTools [(QualifiedBuildTool "foo" "bar", versionRange "==0.1.0")] it "accepts unqualified names" $ do [yaml| foo: 0.1.0 |] `shouldDecodeTo_` BuildTools [(UnqualifiedBuildTool "foo", versionRange "==0.1.0")] context "with a list" $ do it "accepts a list of build tools" $ do [yaml| - foo:one - bar:two >= 0.1.0 - baz == 0.2.0 |] `shouldDecodeTo_` BuildTools [ (QualifiedBuildTool "foo" "one", anyVersion) , (QualifiedBuildTool "bar" "two", versionRange ">=0.1.0") , (UnqualifiedBuildTool "baz", versionRange "==0.2.0") ] it "accepts source dependencies with a qualified name" $ do let source = Just (GitRef "https://github.com/sol/hpack" "master" Nothing) [yaml| - name: hpack:foo github: sol/hpack ref: master |] `shouldDecodeTo_` BuildTools [(QualifiedBuildTool "hpack" "foo", DependencyVersion source AnyVersion)] it "accepts source dependencies with an unqualified name" $ do let source = Just (GitRef "https://github.com/sol/hpack" "master" Nothing) [yaml| - name: hpack github: sol/hpack ref: master |] `shouldDecodeTo_` BuildTools [(UnqualifiedBuildTool "hpack", DependencyVersion source AnyVersion)] context "when parsing SystemBuildTools" $ do context "with a scalar" $ do it "accepts system build tools" $ do [yaml| g++ |] `shouldDecodeTo_` SystemBuildTools [("g++", AnyVersion)] it "accepts system build tools with a version" $ do [yaml| g++ >= 0.1.0 |] `shouldDecodeTo_` SystemBuildTools [("g++", VersionRange ">=0.1.0")] context "with a mapping" $ do it "accepts system build tools" $ do [yaml| g++: 0.1.0 |] `shouldDecodeTo_` SystemBuildTools [("g++", VersionRange "==0.1.0")] context "with a list" $ do it "accepts a list of system build tools" $ do [yaml| - foo - bar >= 0.1.0 |] `shouldDecodeTo_` SystemBuildTools [ ("foo", AnyVersion) , ("bar", VersionRange ">=0.1.0") ] it "accepts objects with name and version" $ do [yaml| - name: foo version: 0.1.0 |] `shouldDecodeTo_` SystemBuildTools [ ("foo", VersionRange "==0.1.0") ] hpack-0.34.2/test/Hpack/Syntax/DependenciesSpec.hs0000644000000000000000000002501313665434154020120 0ustar0000000000000000{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} module Hpack.Syntax.DependenciesSpec (spec) where import Helper import Data.Aeson.Config.FromValueSpec (shouldDecodeTo, shouldDecodeTo_) import Data.Aeson.Config.FromValue import Hpack.Syntax.DependencyVersion import Hpack.Syntax.Dependencies left :: String -> Result Dependencies left = Left defaultInfo :: DependencyInfo defaultInfo = DependencyInfo [] anyVersion spec :: Spec spec = do describe "parseDependency" $ do it "accepts dependencies" $ do parseDependency "dependency" "foo" `shouldReturn` ("foo", DependencyVersion Nothing AnyVersion) it "accepts dependencies with a subcomponent" $ do parseDependency "dependency" "foo:bar" `shouldReturn` ("foo:bar", DependencyVersion Nothing AnyVersion) it "accepts dependencies with multiple subcomponents" $ do parseDependency "dependency" "foo:{bar,baz}" `shouldReturn` ("foo:{bar,baz}", DependencyVersion Nothing AnyVersion) describe "fromValue" $ do context "when parsing Dependencies" $ do context "with a scalar" $ do it "accepts dependencies without constraints" $ do [yaml| hpack |] `shouldDecodeTo_` Dependencies [("hpack", defaultInfo)] it "accepts dependencies with constraints" $ do [yaml| hpack >= 2 && < 3 |] `shouldDecodeTo_` Dependencies [("hpack", defaultInfo { dependencyInfoVersion = versionRange ">=2 && <3" })] context "with invalid constraint" $ do it "returns an error message" $ do [yaml| hpack == |] `shouldDecodeTo` left "Error while parsing $ - invalid dependency \"hpack ==\"" context "with a list" $ do it "accepts dependencies without constraints" $ do [yaml| - hpack |] `shouldDecodeTo_` Dependencies [("hpack", defaultInfo)] it "accepts dependencies with constraints" $ do [yaml| - hpack >= 2 && < 3 |] `shouldDecodeTo_` Dependencies [("hpack", defaultInfo { dependencyInfoVersion = versionRange ">=2 && <3" })] it "accepts ^>=" $ do [yaml| - hpack ^>= 1.2.3.4 |] `shouldDecodeTo_` Dependencies [("hpack", defaultInfo { dependencyInfoVersion = versionRange ">=1.2.3.4 && <1.3" })] it "accepts objects with name and version" $ do [yaml| - name: hpack version: 0.1.0 |] `shouldDecodeTo_` Dependencies [("hpack", defaultInfo { dependencyInfoVersion = versionRange "==0.1.0" })] it "accepts git dependencies with version" $ do let source = Just (GitRef "https://github.com/sol/hpack" "master" Nothing) [yaml| - name: hpack version: 0.1.0 git: https://github.com/sol/hpack ref: master |] `shouldDecodeTo_` Dependencies [("hpack", defaultInfo { dependencyInfoVersion = DependencyVersion source (VersionRange "==0.1.0") })] it "accepts git dependencies" $ do let source = Just (GitRef "https://github.com/sol/hpack" "master" Nothing) [yaml| - name: hpack git: https://github.com/sol/hpack ref: master |] `shouldDecodeTo_` Dependencies [("hpack", defaultInfo { dependencyInfoVersion = DependencyVersion source AnyVersion })] it "accepts github dependencies" $ do let source = Just (GitRef "https://github.com/sol/hpack" "master" Nothing) [yaml| - name: hpack github: sol/hpack ref: master |] `shouldDecodeTo_` Dependencies [("hpack", defaultInfo { dependencyInfoVersion = DependencyVersion source AnyVersion })] it "accepts an optional subdirectory for git dependencies" $ do let source = Just (GitRef "https://github.com/yesodweb/wai" "master" (Just "warp")) [yaml| - name: warp github: yesodweb/wai ref: master subdir: warp |] `shouldDecodeTo_` Dependencies [("warp", defaultInfo { dependencyInfoVersion = DependencyVersion source AnyVersion })] it "accepts local dependencies" $ do let source = Just (Local "../hpack") [yaml| - name: hpack path: ../hpack |] `shouldDecodeTo_` Dependencies [("hpack", defaultInfo {dependencyInfoVersion = DependencyVersion source AnyVersion })] context "when ref is missing" $ do it "produces accurate error messages" $ do [yaml| - name: hpack git: sol/hpack ef: master |] `shouldDecodeTo` left "Error while parsing $[0] - key \"ref\" not present" context "when both git and github are missing" $ do it "produces accurate error messages" $ do [yaml| - name: hpack gi: sol/hpack ref: master |] `shouldDecodeTo` left "Error while parsing $[0] - neither key \"git\" nor key \"github\" present" context "with a mapping from dependency names to constraints" $ do it "accepts dependencies without constraints" $ do [yaml| array: |] `shouldDecodeTo_` Dependencies [("array", defaultInfo)] it "rejects invalid values" $ do [yaml| hpack: [] |] `shouldDecodeTo` left "Error while parsing $.hpack - expected Null, Object, Number, or String, but encountered Array" context "when the constraint is a Number" $ do it "accepts 1" $ do [yaml| hpack: 1 |] `shouldDecodeTo_` Dependencies [("hpack", defaultInfo { dependencyInfoVersion = versionRange "==1" })] it "accepts 1.0" $ do [yaml| hpack: 1.0 |] `shouldDecodeTo_` Dependencies [("hpack", defaultInfo { dependencyInfoVersion = versionRange "==1.0" })] it "accepts 0.11" $ do [yaml| hpack: 0.11 |] `shouldDecodeTo_` Dependencies [("hpack", defaultInfo { dependencyInfoVersion = versionRange "==0.11" })] it "accepts 0.110" $ do [yaml| hpack: 0.110 |] `shouldDecodeTo_` Dependencies [("hpack", defaultInfo { dependencyInfoVersion = versionRange "==0.110" })] it "accepts 1e2" $ do [yaml| hpack: 1e2 |] `shouldDecodeTo_` Dependencies [("hpack", defaultInfo { dependencyInfoVersion = versionRange "==100" })] context "when the constraint is a String" $ do it "accepts version ranges" $ do [yaml| hpack: '>=2' |] `shouldDecodeTo_` Dependencies [("hpack", defaultInfo { dependencyInfoVersion = versionRange ">=2" })] it "accepts specific versions" $ do [yaml| hpack: 0.10.8.2 |] `shouldDecodeTo_` Dependencies [("hpack", defaultInfo { dependencyInfoVersion = versionRange "==0.10.8.2" })] it "accepts wildcard versions" $ do [yaml| hpack: 2.* |] `shouldDecodeTo_` Dependencies [("hpack", defaultInfo { dependencyInfoVersion = versionRange "==2.*" })] it "accepts ^>=" $ do [yaml| hpack: ^>= 1.2.3.4 |] `shouldDecodeTo_` Dependencies [("hpack", defaultInfo { dependencyInfoVersion = versionRange ">=1.2.3.4 && <1.3" })] it "reports parse errors" $ do [yaml| hpack: foo |] `shouldDecodeTo` left "Error while parsing $.hpack - invalid constraint \"foo\"" context "when the constraint is an Object" $ do it "accepts explicit version field" $ do [yaml| hpack: version: 0.1.0 |] `shouldDecodeTo_` Dependencies [("hpack", defaultInfo { dependencyInfoVersion = versionRange "==0.1.0" })] it "accepts github dependencies" $ do let source = Just (GitRef "https://github.com/haskell/cabal" "d53b6e0d908dfedfdf4337b2935519fb1d689e76" (Just "Cabal")) [yaml| Cabal: github: haskell/cabal ref: d53b6e0d908dfedfdf4337b2935519fb1d689e76 subdir: Cabal |] `shouldDecodeTo_` Dependencies [("Cabal", defaultInfo { dependencyInfoVersion = DependencyVersion source AnyVersion })] it "ignores names in nested hashes" $ do let source = Just (Local "somewhere") [yaml| outer-name: name: inner-name path: somewhere |] `shouldDecodeTo` Right (Dependencies [("outer-name", defaultInfo { dependencyInfoVersion = DependencyVersion source AnyVersion })], ["$.outer-name.name"]) it "defaults to any version" $ do [yaml| foo: {} |] `shouldDecodeTo_` Dependencies [("foo", defaultInfo)] context "with a version key" $ do it "rejects objects" $ do [yaml| foo: version: {} |] `shouldDecodeTo` left "Error while parsing $.foo.version - expected Null, Number, or String, but encountered Object" it "accepts a string" $ do [yaml| foo: version: ">= 3.2.5 && < 3.3" |] `shouldDecodeTo_` Dependencies [("foo", defaultInfo { dependencyInfoVersion = versionRange ">=3.2.5 && <3.3" })] it "accepts a specific version as a number" $ do [yaml| foo: version: 3.0 |] `shouldDecodeTo_` Dependencies [("foo", defaultInfo { dependencyInfoVersion = versionRange "==3.0" })] it "accepts a specific version as a string" $ do [yaml| foo: version: 3.0.2 |] `shouldDecodeTo_` Dependencies [("foo", defaultInfo { dependencyInfoVersion = versionRange "==3.0.2" })] context "with mixin" $ do it "accepts a single value" $ do [yaml| foo: mixin: (Foo as Bar) |] `shouldDecodeTo_` Dependencies [("foo", defaultInfo { dependencyInfoMixins = ["(Foo as Bar)"] })] it "accepts a list" $ do [yaml| foo: mixin: - (Foo as Bar) - hiding (Spam) |] `shouldDecodeTo_` Dependencies [("foo", defaultInfo { dependencyInfoMixins = ["(Foo as Bar)", "hiding (Spam)"] })] hpack-0.34.2/test/Hpack/Syntax/GitSpec.hs0000644000000000000000000000304213665434154016253 0ustar0000000000000000{-# LANGUAGE QuasiQuotes #-} module Hpack.Syntax.GitSpec (spec) where import Helper import Data.String.Interpolate import Hpack.Syntax.Git spec :: Spec spec = do describe "isValidRef" $ do it "accepts slashes" $ do isValidRef "foo/bar" `shouldBe` True it "rejects the empty string" $ do isValidRef "" `shouldBe` False it "accepts .lock as a substring" $ do isValidRef "foo.locking" `shouldBe` True it "rejects .lock at the end of a component" $ do isValidRef "foo/bar.lock/baz" `shouldBe` False it "rejects . at the biginning of a component" $ do isValidRef "foo/.bar/baz" `shouldBe` False it "rejects two consecutive dots .." $ do isValidRef "foo..bar" `shouldBe` False it "rejects ASCII control characters" $ do isValidRef "foo\10bar" `shouldBe` False it "rejects space" $ do isValidRef "foo bar" `shouldBe` False forM_ ["~", "^", ":", "?", "*", "[", "\\"] $ \ xs -> do it [i|rejects #{xs}|] $ do isValidRef [i|foo#{xs}bar|] `shouldBe` False it "rejects multiple consecutive slashes" $ do isValidRef "foo//bar" `shouldBe` False it "rejects slash at beginning" $ do isValidRef "/foo" `shouldBe` False it "rejects slash at end" $ do isValidRef "foo/" `shouldBe` False it "rejects . at end" $ do isValidRef "foo." `shouldBe` False it "rejects @{" $ do isValidRef "foo@{bar" `shouldBe` False it "rejects the single character @" $ do isValidRef "@" `shouldBe` False hpack-0.34.2/src/0000755000000000000000000000000013665434154011656 5ustar0000000000000000hpack-0.34.2/src/Hpack.hs0000644000000000000000000002024213665434154013240 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE RecordWildCards #-} module Hpack ( -- | /__NOTE:__/ This module is exposed to allow integration of Hpack into -- other tools. It is not meant for general use by end users. The following -- caveats apply: -- -- * The API is undocumented, consult the source instead. -- -- * The exposed types and functions primarily serve Hpack's own needs, not -- that of a public API. Breaking changes can happen as Hpack evolves. -- -- As an Hpack user you either want to use the @hpack@ executable or a build -- tool that supports Hpack (e.g. @stack@ or @cabal2nix@). -- * Version version -- * Running Hpack , hpack , hpackResult , printResult , Result(..) , Status(..) -- * Options , defaultOptions , setProgramName , setTarget , setDecode , getOptions , Verbose(..) , Options(..) , Force(..) , GenerateHashStrategy(..) #ifdef TEST , hpackResultWithVersion , header , renderCabalFile #endif ) where import Control.Monad import Data.Version (Version) import qualified Data.Version as Version import System.FilePath import System.Environment import System.Exit import System.IO (stderr) import Data.Aeson (Value) import Data.Maybe import Paths_hpack (version) import Hpack.Options import Hpack.Config import Hpack.Render import Hpack.Util import Hpack.Utf8 as Utf8 import Hpack.CabalFile programVersion :: Maybe Version -> String programVersion Nothing = "hpack" programVersion (Just v) = "hpack version " ++ Version.showVersion v header :: FilePath -> Maybe Version -> (Maybe Hash) -> [String] header p v hash = [ "-- This file has been generated from " ++ takeFileName p ++ " by " ++ programVersion v ++ "." , "--" , "-- see: https://github.com/sol/hpack" ] ++ case hash of Just h -> ["--" , "-- hash: " ++ h, ""] Nothing -> [""] data Options = Options { optionsDecodeOptions :: DecodeOptions , optionsForce :: Force , optionsGenerateHashStrategy :: GenerateHashStrategy , optionsToStdout :: Bool } data GenerateHashStrategy = ForceHash | ForceNoHash | PreferHash | PreferNoHash deriving (Eq, Show) getOptions :: FilePath -> [String] -> IO (Maybe (Verbose, Options)) getOptions defaultPackageConfig args = do result <- parseOptions defaultPackageConfig args case result of PrintVersion -> do putStrLn (programVersion $ Just version) return Nothing PrintNumericVersion -> do putStrLn (Version.showVersion version) return Nothing Help -> do printHelp return Nothing Run (ParseOptions verbose force hash toStdout file) -> do let generateHash = case hash of Just True -> ForceHash Just False -> ForceNoHash Nothing -> PreferNoHash return $ Just (verbose, Options defaultDecodeOptions {decodeOptionsTarget = file} force generateHash toStdout) ParseError -> do printHelp exitFailure printHelp :: IO () printHelp = do name <- getProgName Utf8.hPutStrLn stderr $ unlines [ "Usage: " ++ name ++ " [ --silent ] [ --force | -f ] [ --[no-]hash ] [ PATH ] [ - ]" , " " ++ name ++ " --version" , " " ++ name ++ " --numeric-version" , " " ++ name ++ " --help" ] hpack :: Verbose -> Options -> IO () hpack verbose options = hpackResult options >>= printResult verbose defaultOptions :: Options defaultOptions = Options defaultDecodeOptions NoForce PreferNoHash False setTarget :: FilePath -> Options -> Options setTarget target options@Options{..} = options {optionsDecodeOptions = optionsDecodeOptions {decodeOptionsTarget = target}} setProgramName :: ProgramName -> Options -> Options setProgramName name options@Options{..} = options {optionsDecodeOptions = optionsDecodeOptions {decodeOptionsProgramName = name}} setDecode :: (FilePath -> IO (Either String ([String], Value))) -> Options -> Options setDecode decode options@Options{..} = options {optionsDecodeOptions = optionsDecodeOptions {decodeOptionsDecode = decode}} data Result = Result { resultWarnings :: [String] , resultCabalFile :: String , resultStatus :: Status } deriving (Eq, Show) data Status = Generated | ExistingCabalFileWasModifiedManually | AlreadyGeneratedByNewerHpack | OutputUnchanged deriving (Eq, Show) printResult :: Verbose -> Result -> IO () printResult verbose r = do printWarnings (resultWarnings r) when (verbose == Verbose) $ putStrLn $ case resultStatus r of Generated -> "generated " ++ resultCabalFile r OutputUnchanged -> resultCabalFile r ++ " is up-to-date" AlreadyGeneratedByNewerHpack -> resultCabalFile r ++ " was generated with a newer version of hpack, please upgrade and try again." ExistingCabalFileWasModifiedManually -> resultCabalFile r ++ " was modified manually, please use --force to overwrite." case resultStatus r of Generated -> return () OutputUnchanged -> return () AlreadyGeneratedByNewerHpack -> exitFailure ExistingCabalFileWasModifiedManually -> exitFailure printWarnings :: [String] -> IO () printWarnings = mapM_ $ Utf8.hPutStrLn stderr . ("WARNING: " ++) mkStatus :: CabalFile -> CabalFile -> Status mkStatus new@(CabalFile _ mNewVersion mNewHash _) existing@(CabalFile _ mExistingVersion _ _) | new `hasSameContent` existing = OutputUnchanged | otherwise = case mExistingVersion of Nothing -> ExistingCabalFileWasModifiedManually Just _ | mNewVersion < mExistingVersion -> AlreadyGeneratedByNewerHpack | isJust mNewHash && hashMismatch existing -> ExistingCabalFileWasModifiedManually | otherwise -> Generated hasSameContent :: CabalFile -> CabalFile -> Bool hasSameContent (CabalFile cabalVersionA _ _ a) (CabalFile cabalVersionB _ _ b) = cabalVersionA == cabalVersionB && a == b hashMismatch :: CabalFile -> Bool hashMismatch cabalFile = case cabalFileHash cabalFile of Nothing -> False Just hash -> hash /= calculateHash cabalFile calculateHash :: CabalFile -> Hash calculateHash (CabalFile cabalVersion _ _ body) = sha256 (unlines $ cabalVersion ++ body) hpackResult :: Options -> IO Result hpackResult = hpackResultWithVersion version hpackResultWithVersion :: Version -> Options -> IO Result hpackResultWithVersion v (Options options force generateHashStrategy toStdout) = do DecodeResult pkg (lines -> cabalVersion) cabalFileName warnings <- readPackageConfig options >>= either die return mExistingCabalFile <- readCabalFile cabalFileName let newCabalFile = makeCabalFile generateHashStrategy mExistingCabalFile cabalVersion v pkg status = case force of Force -> Generated NoForce -> maybe Generated (mkStatus newCabalFile) mExistingCabalFile case status of Generated -> writeCabalFile options toStdout cabalFileName newCabalFile _ -> return () return Result { resultWarnings = warnings , resultCabalFile = cabalFileName , resultStatus = status } writeCabalFile :: DecodeOptions -> Bool -> FilePath -> CabalFile -> IO () writeCabalFile options toStdout name cabalFile = do write . unlines $ renderCabalFile (decodeOptionsTarget options) cabalFile where write = if toStdout then Utf8.putStr else Utf8.writeFile name makeCabalFile :: GenerateHashStrategy -> Maybe CabalFile -> [String] -> Version -> Package -> CabalFile makeCabalFile strategy mExistingCabalFile cabalVersion v pkg = cabalFile where cabalFile = CabalFile cabalVersion (Just v) hash body hash | shouldGenerateHash mExistingCabalFile strategy = Just $ calculateHash cabalFile | otherwise = Nothing body = lines $ renderPackage (maybe [] cabalFileContents mExistingCabalFile) pkg shouldGenerateHash :: Maybe CabalFile -> GenerateHashStrategy -> Bool shouldGenerateHash mExistingCabalFile strategy = case (strategy, mExistingCabalFile) of (ForceHash, _) -> True (ForceNoHash, _) -> False (PreferHash, Nothing) -> True (PreferNoHash, Nothing) -> False (_, Just CabalFile {cabalFileHash = Nothing}) -> False (_, Just CabalFile {cabalFileHash = Just _}) -> True renderCabalFile :: FilePath -> CabalFile -> [String] renderCabalFile file (CabalFile cabalVersion hpackVersion hash body) = cabalVersion ++ header file hpackVersion hash ++ body hpack-0.34.2/src/Data/0000755000000000000000000000000013665434154012527 5ustar0000000000000000hpack-0.34.2/src/Data/Aeson/0000755000000000000000000000000013665434154013574 5ustar0000000000000000hpack-0.34.2/src/Data/Aeson/Config/0000755000000000000000000000000013665434154015001 5ustar0000000000000000hpack-0.34.2/src/Data/Aeson/Config/Util.hs0000644000000000000000000000040613665434154016252 0ustar0000000000000000module Data.Aeson.Config.Util where import Data.Aeson.Types (camelTo2) hyphenize :: String -> String -> String hyphenize name = camelTo2 '-' . dropPrefix . dropWhile (== '_') where dropPrefix = drop (length (dropWhile (== '_') $ reverse name)) hpack-0.34.2/src/Data/Aeson/Config/Types.hs0000644000000000000000000000264213665434154016445 0ustar0000000000000000{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Data.Aeson.Config.Types where import Data.Semigroup (Semigroup(..)) import Data.Bitraversable import Data.Bifoldable import Data.Bifunctor import Data.Aeson.Config.FromValue newtype List a = List {fromList :: [a]} deriving (Eq, Show, Functor, Foldable, Traversable, Semigroup, Monoid) instance FromValue a => FromValue (List a) where fromValue v = List <$> case v of Array _ -> fromValue v _ -> return <$> fromValue v fromMaybeList :: Maybe (List a) -> [a] fromMaybeList = maybe [] fromList data Product a b = Product a b deriving (Eq, Show, Functor, Foldable, Traversable) instance (Semigroup a, Semigroup b, Monoid a, Monoid b) => Monoid (Product a b) where mempty = Product mempty mempty mappend = (<>) instance (Semigroup a, Semigroup b) => Semigroup (Product a b) where Product a1 b1 <> Product a2 b2 = Product (a1 <> a2) (b1 <> b2) instance Bifunctor Product where bimap fa fb (Product a b) = Product (fa a) (fb b) instance Bifoldable Product where bifoldMap = bifoldMapDefault instance Bitraversable Product where bitraverse fa fb (Product a b) = Product <$> fa a <*> fb b instance (FromValue a, FromValue b) => FromValue (Product a b) where fromValue v = Product <$> fromValue v <*> fromValue v hpack-0.34.2/src/Data/Aeson/Config/FromValue.hs0000644000000000000000000001067613665434154017247 0ustar0000000000000000{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ConstraintKinds #-} module Data.Aeson.Config.FromValue ( FromValue(..) , Parser , Result , decodeValue , Generic , GenericDecode , genericFromValue , Options(..) , genericFromValueWith , typeMismatch , withObject , withText , withString , withArray , withNumber , withBool , parseArray , traverseObject , (.:) , (.:?) , Value(..) , Object , Array ) where import GHC.Generics import Control.Monad import Control.Applicative import Data.Bifunctor import Data.Map.Lazy (Map) import qualified Data.Map.Lazy as Map import Data.Text (Text) import qualified Data.Text as T import qualified Data.Vector as V import qualified Data.HashMap.Strict as HashMap import Data.Aeson.Types (FromJSON(..)) import Data.Aeson.Config.Util import Data.Aeson.Config.Parser type Result a = Either String (a, [String]) decodeValue :: FromValue a => Value -> Result a decodeValue = runParser fromValue (.:) :: FromValue a => Object -> Text -> Parser a (.:) = explicitParseField fromValue (.:?) :: FromValue a => Object -> Text -> Parser (Maybe a) (.:?) = explicitParseFieldMaybe fromValue class FromValue a where fromValue :: Value -> Parser a default fromValue :: forall d m. (Generic a, Rep a ~ D1 d m, Datatype d, GenericDecode (Rep a)) => Value -> Parser a fromValue = genericFromValue genericFromValue :: forall a d m. (Generic a, Rep a ~ D1 d m, Datatype d, GenericDecode (Rep a)) => Value -> Parser a genericFromValue = genericFromValueWith (Options $ hyphenize name) where name :: String name = datatypeName (undefined :: D1 d m p) instance FromValue Bool where fromValue = liftParser . parseJSON instance FromValue Int where fromValue = liftParser . parseJSON instance FromValue Text where fromValue = liftParser . parseJSON instance {-# OVERLAPPING #-} FromValue String where fromValue = liftParser . parseJSON instance FromValue a => FromValue (Maybe a) where fromValue value = liftParser (parseJSON value) >>= traverse fromValue instance FromValue a => FromValue [a] where fromValue = withArray (parseArray fromValue) parseArray :: (Value -> Parser a) -> Array -> Parser [a] parseArray f = zipWithM (parseIndexed f) [0..] . V.toList where parseIndexed :: (Value -> Parser a) -> Int -> Value -> Parser a parseIndexed p n value = p value Index n instance FromValue a => FromValue (Map String a) where fromValue = withObject $ \ o -> do xs <- traverseObject fromValue o return $ Map.fromList (map (first T.unpack) xs) traverseObject :: (Value -> Parser a) -> Object -> Parser [(Text, a)] traverseObject f o = do forM (HashMap.toList o) $ \ (name, value) -> (,) name <$> f value Key name instance (FromValue a, FromValue b) => FromValue (a, b) where fromValue v = (,) <$> fromValue v <*> fromValue v instance (FromValue a, FromValue b) => FromValue (Either a b) where fromValue v = Left <$> fromValue v <|> Right <$> fromValue v data Options = Options { optionsRecordSelectorModifier :: String -> String } genericFromValueWith :: (Generic a, GenericDecode (Rep a)) => Options -> Value -> Parser a genericFromValueWith opts = fmap to . genericDecode opts class GenericDecode f where genericDecode :: Options -> Value -> Parser (f p) instance (GenericDecode a) => GenericDecode (D1 d a) where genericDecode opts = fmap M1 . genericDecode opts instance (GenericDecode a) => GenericDecode (C1 c a) where genericDecode opts = fmap M1 . genericDecode opts instance (GenericDecode a, GenericDecode b) => GenericDecode (a :*: b) where genericDecode opts o = (:*:) <$> genericDecode opts o <*> genericDecode opts o instance (Selector sel, FromValue a) => GenericDecode (S1 sel (Rec0 a)) where genericDecode = accessFieldWith (.:) instance {-# OVERLAPPING #-} (Selector sel, FromValue a) => GenericDecode (S1 sel (Rec0 (Maybe a))) where genericDecode = accessFieldWith (.:?) accessFieldWith :: forall sel a p. Selector sel => (Object -> Text -> Parser a) -> Options -> Value -> Parser (S1 sel (Rec0 a) p) accessFieldWith op Options{..} v = M1 . K1 <$> withObject (`op` T.pack label) v where label = optionsRecordSelectorModifier $ selName (undefined :: S1 sel (Rec0 a) p) hpack-0.34.2/src/Data/Aeson/Config/Parser.hs0000644000000000000000000001135213665434154016573 0ustar0000000000000000{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} module Data.Aeson.Config.Parser ( Parser , runParser , typeMismatch , withObject , withText , withString , withArray , withNumber , withBool , explicitParseField , explicitParseFieldMaybe , Aeson.JSONPathElement(..) , () , Value(..) , Object , Array , liftParser , fromAesonPath , formatPath ) where import Control.Monad import Control.Applicative import qualified Control.Monad.Fail as Fail import Control.Monad.Trans.Class import Control.Monad.Trans.Writer import Data.Monoid ((<>)) import Data.Scientific import Data.Set (Set, notMember) import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text as T import qualified Data.Vector as V import qualified Data.HashMap.Strict as HashMap import Data.Aeson.Types (Value(..), Object, Array) import qualified Data.Aeson.Types as Aeson import Data.Aeson.Internal (IResult(..), iparse) #if !MIN_VERSION_aeson(1,4,5) import qualified Data.Aeson.Internal as Aeson #endif -- This is needed so that we have an Ord instance for aeson < 1.2.4. data JSONPathElement = Key Text | Index Int deriving (Eq, Show, Ord) type JSONPath = [JSONPathElement] fromAesonPath :: Aeson.JSONPath -> JSONPath fromAesonPath = reverse . map fromAesonPathElement fromAesonPathElement :: Aeson.JSONPathElement -> JSONPathElement fromAesonPathElement e = case e of Aeson.Key k -> Key k Aeson.Index n -> Index n newtype Parser a = Parser {unParser :: WriterT (Set JSONPath) Aeson.Parser a} deriving (Functor, Applicative, Alternative, Monad, Fail.MonadFail) liftParser :: Aeson.Parser a -> Parser a liftParser = Parser . lift runParser :: (Value -> Parser a) -> Value -> Either String (a, [String]) runParser p v = case iparse (runWriterT . unParser <$> p) v of IError path err -> Left ("Error while parsing " ++ formatPath (fromAesonPath path) ++ " - " ++ err) ISuccess (a, consumed) -> Right (a, map formatPath (determineUnconsumed consumed v)) formatPath :: JSONPath -> String formatPath = go "$" . reverse where go :: String -> JSONPath -> String go acc path = case path of [] -> acc Index n : xs -> go (acc ++ "[" ++ show n ++ "]") xs Key key : xs -> go (acc ++ "." ++ T.unpack key) xs determineUnconsumed :: Set JSONPath -> Value -> [JSONPath] determineUnconsumed ((<> Set.singleton []) -> consumed) = Set.toList . execWriter . go [] where go :: JSONPath -> Value -> Writer (Set JSONPath) () go path value | path `notMember` consumed = tell (Set.singleton path) | otherwise = case value of Number _ -> return () String _ -> return () Bool _ -> return () Null -> return () Object o -> do forM_ (HashMap.toList o) $ \ (k, v) -> do unless ("_" `T.isPrefixOf` k) $ do go (Key k : path) v Array xs -> do forM_ (zip [0..] $ V.toList xs) $ \ (n, v) -> do go (Index n : path) v () :: Parser a -> Aeson.JSONPathElement -> Parser a () (Parser (WriterT p)) e = do Parser (WriterT (p Aeson. e)) <* markConsumed (fromAesonPathElement e) markConsumed :: JSONPathElement -> Parser () markConsumed e = do path <- getPath Parser $ tell (Set.singleton $ e : path) getPath :: Parser JSONPath getPath = liftParser $ Aeson.parserCatchError empty $ \ path _ -> return (fromAesonPath path) explicitParseField :: (Value -> Parser a) -> Object -> Text -> Parser a explicitParseField p o key = case HashMap.lookup key o of Nothing -> fail $ "key " ++ show key ++ " not present" Just v -> p v Aeson.Key key explicitParseFieldMaybe :: (Value -> Parser a) -> Object -> Text -> Parser (Maybe a) explicitParseFieldMaybe p o key = case HashMap.lookup key o of Nothing -> pure Nothing Just v -> Just <$> p v Aeson.Key key typeMismatch :: String -> Value -> Parser a typeMismatch expected = liftParser . Aeson.typeMismatch expected withObject :: (Object -> Parser a) -> Value -> Parser a withObject p (Object o) = p o withObject _ v = typeMismatch "Object" v withText :: (Text -> Parser a) -> Value -> Parser a withText p (String s) = p s withText _ v = typeMismatch "String" v withString :: (String -> Parser a) -> Value -> Parser a withString p = withText (p . T.unpack) withArray :: (Array -> Parser a) -> Value -> Parser a withArray p (Array xs) = p xs withArray _ v = typeMismatch "Array" v withNumber :: (Scientific -> Parser a) -> Value -> Parser a withNumber p (Number n) = p n withNumber _ v = typeMismatch "Number" v withBool :: (Bool -> Parser a) -> Value -> Parser a withBool p (Bool b) = p b withBool _ v = typeMismatch "Boolean" v hpack-0.34.2/src/Hpack/0000755000000000000000000000000013665434154012704 5ustar0000000000000000hpack-0.34.2/src/Hpack/Config.hs0000644000000000000000000016532713665434154014463 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE LiberalTypeSynonyms #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE FlexibleContexts #-} module Hpack.Config ( -- | /__NOTE:__/ This module is exposed to allow integration of Hpack into -- other tools. It is not meant for general use by end users. The following -- caveats apply: -- -- * The API is undocumented, consult the source instead. -- -- * The exposed types and functions primarily serve Hpack's own needs, not -- that of a public API. Breaking changes can happen as Hpack evolves. -- -- As an Hpack user you either want to use the @hpack@ executable or a build -- tool that supports Hpack (e.g. @stack@ or @cabal2nix@). DecodeOptions(..) , ProgramName(..) , defaultDecodeOptions , packageConfig , DecodeResult(..) , readPackageConfig , renamePackage , packageDependencies , package , section , Package(..) , Dependencies(..) , DependencyInfo(..) , VersionConstraint(..) , DependencyVersion(..) , SourceDependency(..) , GitRef , GitUrl , BuildTool(..) , SystemBuildTools(..) , GhcOption , Verbatim(..) , VerbatimValue(..) , verbatimValueToString , CustomSetup(..) , Section(..) , Library(..) , Executable(..) , Conditional(..) , Flag(..) , SourceRepository(..) , BuildType(..) , GhcProfOption , GhcjsOption , CppOption , CcOption , LdOption , Path(..) #ifdef TEST , renameDependencies , Empty(..) , getModules , pathsModuleFromPackageName , Cond(..) , LibrarySection(..) , fromLibrarySectionInConditional , formatOrList , toBuildTool #endif ) where import Control.Applicative import Control.Arrow ((>>>), (&&&)) import Control.Monad import Data.Either import Data.Bifunctor import Data.Bitraversable import Data.Map.Lazy (Map) import qualified Data.Map.Lazy as Map import qualified Data.HashMap.Lazy as HashMap import Data.List (nub, (\\), sortBy, intercalate) import Data.Maybe import Data.Semigroup (Semigroup(..)) import Data.Ord import Data.String import Data.Text (Text) import qualified Data.Text as T import Data.Scientific (Scientific) import System.Directory import System.FilePath import Control.Monad.Trans.Class import Control.Monad.Trans.Writer import Control.Monad.Trans.Except import Control.Monad.IO.Class import Data.Version (Version, makeVersion, showVersion) import Distribution.Pretty (prettyShow) import qualified Distribution.SPDX.License as SPDX import Data.Aeson.Config.Types import Data.Aeson.Config.FromValue hiding (decodeValue) import qualified Data.Aeson.Config.FromValue as Config import Hpack.Syntax.Defaults import Hpack.Util hiding (expandGlobs) import qualified Hpack.Util as Util import Hpack.Defaults import qualified Hpack.Yaml as Yaml import Hpack.Syntax.DependencyVersion import Hpack.Syntax.Dependencies import Hpack.Syntax.BuildTools import Hpack.License import Hpack.CabalFile (parseVersion) import qualified Paths_hpack as Hpack (version) package :: String -> String -> Package package name version = Package { packageName = name , packageVersion = version , packageSynopsis = Nothing , packageDescription = Nothing , packageHomepage = Nothing , packageBugReports = Nothing , packageCategory = Nothing , packageStability = Nothing , packageAuthor = [] , packageMaintainer = [] , packageCopyright = [] , packageBuildType = Simple , packageLicense = Nothing , packageLicenseFile = [] , packageTestedWith = Nothing , packageFlags = [] , packageExtraSourceFiles = [] , packageExtraDocFiles = [] , packageDataFiles = [] , packageDataDir = Nothing , packageSourceRepository = Nothing , packageCustomSetup = Nothing , packageLibrary = Nothing , packageInternalLibraries = mempty , packageExecutables = mempty , packageTests = mempty , packageBenchmarks = mempty , packageVerbatim = [] } renamePackage :: String -> Package -> Package renamePackage name p@Package{..} = p { packageName = name , packageExecutables = fmap (renameDependencies packageName name) packageExecutables , packageTests = fmap (renameDependencies packageName name) packageTests , packageBenchmarks = fmap (renameDependencies packageName name) packageBenchmarks } renameDependencies :: String -> String -> Section a -> Section a renameDependencies old new sect@Section{..} = sect {sectionDependencies = (Dependencies . Map.fromList . map rename . Map.toList . unDependencies) sectionDependencies, sectionConditionals = map renameConditional sectionConditionals} where rename dep@(name, version) | name == old = (new, version) | otherwise = dep renameConditional :: Conditional (Section a) -> Conditional (Section a) renameConditional (Conditional condition then_ else_) = Conditional condition (renameDependencies old new then_) (renameDependencies old new <$> else_) packageDependencies :: Package -> [(String, DependencyInfo)] packageDependencies Package{..} = nub . sortBy (comparing (lexicographically . fst)) $ (concatMap deps packageExecutables) ++ (concatMap deps packageTests) ++ (concatMap deps packageBenchmarks) ++ maybe [] deps packageLibrary where deps xs = [(name, info) | (name, info) <- (Map.toList . unDependencies . sectionDependencies) xs] section :: a -> Section a section a = Section a [] mempty [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] Nothing [] mempty mempty [] packageConfig :: FilePath packageConfig = "package.yaml" data CustomSetupSection = CustomSetupSection { customSetupSectionDependencies :: Maybe Dependencies } deriving (Eq, Show, Generic, FromValue) data LibrarySection = LibrarySection { librarySectionExposed :: Maybe Bool , librarySectionVisibility :: Maybe String , librarySectionExposedModules :: Maybe (List String) , librarySectionGeneratedExposedModules :: Maybe (List String) , librarySectionOtherModules :: Maybe (List String) , librarySectionGeneratedOtherModules :: Maybe (List String) , librarySectionReexportedModules :: Maybe (List String) , librarySectionSignatures :: Maybe (List String) } deriving (Eq, Show, Generic, FromValue) instance Monoid LibrarySection where mempty = LibrarySection Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing mappend = (<>) instance Semigroup LibrarySection where a <> b = LibrarySection { librarySectionExposed = librarySectionExposed b <|> librarySectionExposed a , librarySectionVisibility = librarySectionVisibility b <|> librarySectionVisibility a , librarySectionExposedModules = librarySectionExposedModules a <> librarySectionExposedModules b , librarySectionGeneratedExposedModules = librarySectionGeneratedExposedModules a <> librarySectionGeneratedExposedModules b , librarySectionOtherModules = librarySectionOtherModules a <> librarySectionOtherModules b , librarySectionGeneratedOtherModules = librarySectionGeneratedOtherModules a <> librarySectionGeneratedOtherModules b , librarySectionReexportedModules = librarySectionReexportedModules a <> librarySectionReexportedModules b , librarySectionSignatures = librarySectionSignatures a <> librarySectionSignatures b } data ExecutableSection = ExecutableSection { executableSectionMain :: Maybe FilePath , executableSectionOtherModules :: Maybe (List String) , executableSectionGeneratedOtherModules :: Maybe (List String) } deriving (Eq, Show, Generic, FromValue) instance Monoid ExecutableSection where mempty = ExecutableSection Nothing Nothing Nothing mappend = (<>) instance Semigroup ExecutableSection where a <> b = ExecutableSection { executableSectionMain = executableSectionMain b <|> executableSectionMain a , executableSectionOtherModules = executableSectionOtherModules a <> executableSectionOtherModules b , executableSectionGeneratedOtherModules = executableSectionGeneratedOtherModules a <> executableSectionGeneratedOtherModules b } data VerbatimValue = VerbatimString String | VerbatimNumber Scientific | VerbatimBool Bool | VerbatimNull deriving (Eq, Show) instance FromValue VerbatimValue where fromValue v = case v of String s -> return (VerbatimString $ T.unpack s) Number n -> return (VerbatimNumber n) Bool b -> return (VerbatimBool b) Null -> return VerbatimNull Object _ -> err Array _ -> err where err = typeMismatch (formatOrList ["String", "Number", "Bool", "Null"]) v data Verbatim = VerbatimLiteral String | VerbatimObject (Map String VerbatimValue) deriving (Eq, Show) instance FromValue Verbatim where fromValue v = case v of String s -> return (VerbatimLiteral $ T.unpack s) Object _ -> VerbatimObject <$> fromValue v _ -> typeMismatch (formatOrList ["String", "Object"]) v data CommonOptions cSources cxxSources jsSources a = CommonOptions { commonOptionsSourceDirs :: Maybe (List FilePath) , commonOptionsDependencies :: Maybe Dependencies , commonOptionsPkgConfigDependencies :: Maybe (List String) , commonOptionsDefaultExtensions :: Maybe (List String) , commonOptionsOtherExtensions :: Maybe (List String) , commonOptionsGhcOptions :: Maybe (List GhcOption) , commonOptionsGhcProfOptions :: Maybe (List GhcProfOption) , commonOptionsGhcjsOptions :: Maybe (List GhcjsOption) , commonOptionsCppOptions :: Maybe (List CppOption) , commonOptionsCcOptions :: Maybe (List CcOption) , commonOptionsCSources :: cSources , commonOptionsCxxOptions :: Maybe (List CxxOption) , commonOptionsCxxSources :: cxxSources , commonOptionsJsSources :: jsSources , commonOptionsExtraLibDirs :: Maybe (List FilePath) , commonOptionsExtraLibraries :: Maybe (List FilePath) , commonOptionsExtraFrameworksDirs :: Maybe (List FilePath) , commonOptionsFrameworks :: Maybe (List String) , commonOptionsIncludeDirs :: Maybe (List FilePath) , commonOptionsInstallIncludes :: Maybe (List FilePath) , commonOptionsLdOptions :: Maybe (List LdOption) , commonOptionsBuildable :: Maybe Bool , commonOptionsWhen :: Maybe (List (ConditionalSection cSources cxxSources jsSources a)) , commonOptionsBuildTools :: Maybe BuildTools , commonOptionsSystemBuildTools :: Maybe SystemBuildTools , commonOptionsVerbatim :: Maybe (List Verbatim) } deriving (Functor, Generic) type ParseCommonOptions = CommonOptions ParseCSources ParseCxxSources ParseJsSources instance FromValue a => FromValue (ParseCommonOptions a) instance (Semigroup cSources, Semigroup cxxSources, Semigroup jsSources, Monoid cSources, Monoid cxxSources, Monoid jsSources) => Monoid (CommonOptions cSources cxxSources jsSources a) where mempty = CommonOptions { commonOptionsSourceDirs = Nothing , commonOptionsDependencies = Nothing , commonOptionsPkgConfigDependencies = Nothing , commonOptionsDefaultExtensions = Nothing , commonOptionsOtherExtensions = Nothing , commonOptionsGhcOptions = Nothing , commonOptionsGhcProfOptions = Nothing , commonOptionsGhcjsOptions = Nothing , commonOptionsCppOptions = Nothing , commonOptionsCcOptions = Nothing , commonOptionsCSources = mempty , commonOptionsCxxOptions = Nothing , commonOptionsCxxSources = mempty , commonOptionsJsSources = mempty , commonOptionsExtraLibDirs = Nothing , commonOptionsExtraLibraries = Nothing , commonOptionsExtraFrameworksDirs = Nothing , commonOptionsFrameworks = Nothing , commonOptionsIncludeDirs = Nothing , commonOptionsInstallIncludes = Nothing , commonOptionsLdOptions = Nothing , commonOptionsBuildable = Nothing , commonOptionsWhen = Nothing , commonOptionsBuildTools = Nothing , commonOptionsSystemBuildTools = Nothing , commonOptionsVerbatim = Nothing } mappend = (<>) instance (Semigroup cSources, Semigroup cxxSources, Semigroup jsSources) => Semigroup (CommonOptions cSources cxxSources jsSources a) where a <> b = CommonOptions { commonOptionsSourceDirs = commonOptionsSourceDirs a <> commonOptionsSourceDirs b , commonOptionsDependencies = commonOptionsDependencies b <> commonOptionsDependencies a , commonOptionsPkgConfigDependencies = commonOptionsPkgConfigDependencies a <> commonOptionsPkgConfigDependencies b , commonOptionsDefaultExtensions = commonOptionsDefaultExtensions a <> commonOptionsDefaultExtensions b , commonOptionsOtherExtensions = commonOptionsOtherExtensions a <> commonOptionsOtherExtensions b , commonOptionsGhcOptions = commonOptionsGhcOptions a <> commonOptionsGhcOptions b , commonOptionsGhcProfOptions = commonOptionsGhcProfOptions a <> commonOptionsGhcProfOptions b , commonOptionsGhcjsOptions = commonOptionsGhcjsOptions a <> commonOptionsGhcjsOptions b , commonOptionsCppOptions = commonOptionsCppOptions a <> commonOptionsCppOptions b , commonOptionsCcOptions = commonOptionsCcOptions a <> commonOptionsCcOptions b , commonOptionsCSources = commonOptionsCSources a <> commonOptionsCSources b , commonOptionsCxxOptions = commonOptionsCxxOptions a <> commonOptionsCxxOptions b , commonOptionsCxxSources = commonOptionsCxxSources a <> commonOptionsCxxSources b , commonOptionsJsSources = commonOptionsJsSources a <> commonOptionsJsSources b , commonOptionsExtraLibDirs = commonOptionsExtraLibDirs a <> commonOptionsExtraLibDirs b , commonOptionsExtraLibraries = commonOptionsExtraLibraries a <> commonOptionsExtraLibraries b , commonOptionsExtraFrameworksDirs = commonOptionsExtraFrameworksDirs a <> commonOptionsExtraFrameworksDirs b , commonOptionsFrameworks = commonOptionsFrameworks a <> commonOptionsFrameworks b , commonOptionsIncludeDirs = commonOptionsIncludeDirs a <> commonOptionsIncludeDirs b , commonOptionsInstallIncludes = commonOptionsInstallIncludes a <> commonOptionsInstallIncludes b , commonOptionsLdOptions = commonOptionsLdOptions a <> commonOptionsLdOptions b , commonOptionsBuildable = commonOptionsBuildable b <|> commonOptionsBuildable a , commonOptionsWhen = commonOptionsWhen a <> commonOptionsWhen b , commonOptionsBuildTools = commonOptionsBuildTools a <> commonOptionsBuildTools b , commonOptionsSystemBuildTools = commonOptionsSystemBuildTools b <> commonOptionsSystemBuildTools a , commonOptionsVerbatim = commonOptionsVerbatim a <> commonOptionsVerbatim b } type ParseCSources = Maybe (List FilePath) type ParseCxxSources = Maybe (List FilePath) type ParseJsSources = Maybe (List FilePath) type CSources = [Path] type CxxSources = [Path] type JsSources = [Path] type WithCommonOptions cSources cxxSources jsSources a = Product (CommonOptions cSources cxxSources jsSources a) a data Traverse m cSources cSources_ cxxSources cxxSources_ jsSources jsSources_ = Traverse { traverseCSources :: cSources -> m cSources_ , traverseCxxSources :: cxxSources -> m cxxSources_ , traverseJsSources :: jsSources -> m jsSources_ } type Traversal t = forall m cSources cSources_ cxxSources cxxSources_ jsSources jsSources_. Monad m => Traverse m cSources cSources_ cxxSources cxxSources_ jsSources jsSources_ -> t cSources cxxSources jsSources -> m (t cSources_ cxxSources_ jsSources_) type Traversal_ t = forall m cSources cSources_ cxxSources cxxSources_ jsSources jsSources_ a. Monad m => Traverse m cSources cSources_ cxxSources cxxSources_ jsSources jsSources_ -> t cSources cxxSources jsSources a -> m (t cSources_ cxxSources_ jsSources_ a) traverseCommonOptions :: Traversal_ CommonOptions traverseCommonOptions t@Traverse{..} c@CommonOptions{..} = do cSources <- traverseCSources commonOptionsCSources cxxSources <- traverseCxxSources commonOptionsCxxSources jsSources <- traverseJsSources commonOptionsJsSources xs <- traverse (traverse (traverseConditionalSection t)) commonOptionsWhen return c { commonOptionsCSources = cSources , commonOptionsCxxSources = cxxSources , commonOptionsJsSources = jsSources , commonOptionsWhen = xs } traverseConditionalSection :: Traversal_ ConditionalSection traverseConditionalSection t@Traverse{..} = \ case ThenElseConditional c -> ThenElseConditional <$> bitraverse (traverseThenElse t) return c FlatConditional c -> FlatConditional <$> bitraverse (traverseWithCommonOptions t) return c traverseThenElse :: Traversal_ ThenElse traverseThenElse t@Traverse{..} c@ThenElse{..} = do then_ <- traverseWithCommonOptions t thenElseThen else_ <- traverseWithCommonOptions t thenElseElse return c{thenElseThen = then_, thenElseElse = else_} traverseWithCommonOptions :: Traversal_ WithCommonOptions traverseWithCommonOptions t = bitraverse (traverseCommonOptions t) return data ConditionalSection cSources cxxSources jsSources a = ThenElseConditional (Product (ThenElse cSources cxxSources jsSources a) Condition) | FlatConditional (Product (WithCommonOptions cSources cxxSources jsSources a) Condition) instance Functor (ConditionalSection cSources cxxSources jsSources) where fmap f = \ case ThenElseConditional c -> ThenElseConditional (first (fmap f) c) FlatConditional c -> FlatConditional (first (bimap (fmap f) f) c) type ParseConditionalSection = ConditionalSection ParseCSources ParseCxxSources ParseJsSources instance FromValue a => FromValue (ParseConditionalSection a) where fromValue v | hasKey "then" v || hasKey "else" v = ThenElseConditional <$> fromValue v | otherwise = FlatConditional <$> fromValue v hasKey :: Text -> Value -> Bool hasKey key (Object o) = HashMap.member key o hasKey _ _ = False newtype Condition = Condition { _conditionCondition :: Cond } deriving (Eq, Show, Generic, FromValue) newtype Cond = Cond String deriving (Eq, Show) instance FromValue Cond where fromValue v = case v of String s -> return (Cond $ T.unpack s) Bool True -> return (Cond "true") Bool False -> return (Cond "false") _ -> typeMismatch "Boolean or String" v data ThenElse cSources cxxSources jsSources a = ThenElse { thenElseThen :: WithCommonOptions cSources cxxSources jsSources a , thenElseElse :: WithCommonOptions cSources cxxSources jsSources a } deriving Generic instance Functor (ThenElse cSources cxxSources jsSources) where fmap f c@ThenElse{..} = c{thenElseThen = map_ thenElseThen, thenElseElse = map_ thenElseElse} where map_ = bimap (fmap f) f type ParseThenElse = ThenElse ParseCSources ParseCxxSources ParseJsSources instance FromValue a => FromValue (ParseThenElse a) data Empty = Empty deriving (Eq, Show) instance Monoid Empty where mempty = Empty mappend = (<>) instance Semigroup Empty where Empty <> Empty = Empty instance FromValue Empty where fromValue _ = return Empty data BuildType = Simple | Configure | Make | Custom deriving (Eq, Show, Generic, Enum, Bounded) instance FromValue BuildType where fromValue = withText $ \ (T.unpack -> t) -> do maybe err return (lookup t options) where err = fail ("expected one of " ++ formatOrList buildTypesAsString) buildTypes = [minBound .. maxBound] buildTypesAsString = map show buildTypes options = zip buildTypesAsString buildTypes formatOrList :: [String] -> String formatOrList xs = case reverse xs of [] -> "" x : [] -> x y : x : [] -> x ++ " or " ++ y x : ys@(_:_:_) -> intercalate ", " . reverse $ ("or " ++ x) : ys type SectionConfigWithDefaluts cSources cxxSources jsSources a = Product DefaultsConfig (WithCommonOptions cSources cxxSources jsSources a) type PackageConfigWithDefaults cSources cxxSources jsSources = PackageConfig_ (SectionConfigWithDefaluts cSources cxxSources jsSources LibrarySection) (SectionConfigWithDefaluts cSources cxxSources jsSources ExecutableSection) type PackageConfig cSources cxxSources jsSources = PackageConfig_ (WithCommonOptions cSources cxxSources jsSources LibrarySection) (WithCommonOptions cSources cxxSources jsSources ExecutableSection) data PackageVersion = PackageVersion {unPackageVersion :: String} instance FromValue PackageVersion where fromValue v = PackageVersion <$> case v of Number n -> return (scientificToVersion n) String s -> return (T.unpack s) _ -> typeMismatch "Number or String" v data PackageConfig_ library executable = PackageConfig { packageConfigName :: Maybe String , packageConfigVersion :: Maybe PackageVersion , packageConfigSynopsis :: Maybe String , packageConfigDescription :: Maybe String , packageConfigHomepage :: Maybe (Maybe String) , packageConfigBugReports :: Maybe (Maybe String) , packageConfigCategory :: Maybe String , packageConfigStability :: Maybe String , packageConfigAuthor :: Maybe (List String) , packageConfigMaintainer :: Maybe (Maybe (List String)) , packageConfigCopyright :: Maybe (List String) , packageConfigBuildType :: Maybe BuildType , packageConfigLicense :: Maybe (Maybe String) , packageConfigLicenseFile :: Maybe (List String) , packageConfigTestedWith :: Maybe String , packageConfigFlags :: Maybe (Map String FlagSection) , packageConfigExtraSourceFiles :: Maybe (List FilePath) , packageConfigExtraDocFiles :: Maybe (List FilePath) , packageConfigDataFiles :: Maybe (List FilePath) , packageConfigDataDir :: Maybe FilePath , packageConfigGithub :: Maybe GitHub , packageConfigGit :: Maybe String , packageConfigCustomSetup :: Maybe CustomSetupSection , packageConfigLibrary :: Maybe library , packageConfigInternalLibraries :: Maybe (Map String library) , packageConfigExecutable :: Maybe executable , packageConfigExecutables :: Maybe (Map String executable) , packageConfigTests :: Maybe (Map String executable) , packageConfigBenchmarks :: Maybe (Map String executable) } deriving Generic data GitHub = GitHub { _gitHubOwner :: String , _gitHubRepo :: String , _gitHubSubdir :: Maybe String } instance FromValue GitHub where fromValue v = do input <- fromValue v case map T.unpack $ T.splitOn "/" input of [owner, repo, subdir] -> return $ GitHub owner repo (Just subdir) [owner, repo] -> return $ GitHub owner repo Nothing _ -> fail $ "expected owner/repo or owner/repo/subdir, but encountered " ++ show input data DefaultsConfig = DefaultsConfig { defaultsConfigDefaults :: Maybe (List Defaults) } deriving (Generic, FromValue) traversePackageConfig :: Traversal PackageConfig traversePackageConfig t@Traverse{..} p@PackageConfig{..} = do library <- traverse (traverseWithCommonOptions t) packageConfigLibrary internalLibraries <- traverseNamedConfigs t packageConfigInternalLibraries executable <- traverse (traverseWithCommonOptions t) packageConfigExecutable executables <- traverseNamedConfigs t packageConfigExecutables tests <- traverseNamedConfigs t packageConfigTests benchmarks <- traverseNamedConfigs t packageConfigBenchmarks return p { packageConfigLibrary = library , packageConfigInternalLibraries = internalLibraries , packageConfigExecutable = executable , packageConfigExecutables = executables , packageConfigTests = tests , packageConfigBenchmarks = benchmarks } where traverseNamedConfigs = traverse . traverse . traverseWithCommonOptions type ParsePackageConfig = PackageConfigWithDefaults ParseCSources ParseCxxSources ParseJsSources instance FromValue ParsePackageConfig type Warnings m = WriterT [String] m type Errors = ExceptT String decodeYaml :: FromValue a => ProgramName -> FilePath -> Warnings (Errors IO) a decodeYaml programName file = do (warnings, a) <- lift (ExceptT $ Yaml.decodeYaml file) tell warnings decodeValue programName file a data DecodeOptions = DecodeOptions { decodeOptionsProgramName :: ProgramName , decodeOptionsTarget :: FilePath , decodeOptionsUserDataDir :: Maybe FilePath , decodeOptionsDecode :: FilePath -> IO (Either String ([String], Value)) } newtype ProgramName = ProgramName String deriving (Eq, Show) instance IsString ProgramName where fromString = ProgramName defaultDecodeOptions :: DecodeOptions defaultDecodeOptions = DecodeOptions "hpack" packageConfig Nothing Yaml.decodeYaml data DecodeResult = DecodeResult { decodeResultPackage :: Package , decodeResultCabalVersion :: String , decodeResultCabalFile :: FilePath , decodeResultWarnings :: [String] } deriving (Eq, Show) readPackageConfig :: DecodeOptions -> IO (Either String DecodeResult) readPackageConfig (DecodeOptions programName file mUserDataDir readValue) = runExceptT $ fmap addCabalFile . runWriterT $ do (warnings, value) <- lift . ExceptT $ readValue file tell warnings config <- decodeValue programName file value dir <- liftIO $ takeDirectory <$> canonicalizePath file userDataDir <- liftIO $ maybe (getAppUserDataDirectory "hpack") return mUserDataDir toPackage programName userDataDir dir config where addCabalFile :: ((Package, String), [String]) -> DecodeResult addCabalFile ((pkg, cabalVersion), warnings) = DecodeResult pkg cabalVersion (takeDirectory_ file (packageName pkg ++ ".cabal")) warnings takeDirectory_ :: FilePath -> FilePath takeDirectory_ p | takeFileName p == p = "" | otherwise = takeDirectory p deleteVerbatimField :: String -> [Verbatim] -> [Verbatim] deleteVerbatimField name = map $ \ case literal@VerbatimLiteral {} -> literal VerbatimObject o -> VerbatimObject (Map.delete name o) verbatimValueToString :: VerbatimValue -> String verbatimValueToString = \ case VerbatimString s -> s VerbatimNumber n -> scientificToVersion n VerbatimBool b -> show b VerbatimNull -> "" determineCabalVersion :: Maybe (License SPDX.License) -> Package -> (Package, String) determineCabalVersion inferredLicense pkg@Package{..} = ( pkg { packageVerbatim = deleteVerbatimField "cabal-version" packageVerbatim , packageLicense = formatLicense <$> license } , "cabal-version: " ++ fromMaybe inferredCabalVersion verbatimCabalVersion ++ "\n\n" ) where license = fmap prettyShow <$> (parsedLicense <|> inferredLicense) parsedLicense = parseLicense <$> packageLicense formatLicense = \ case MustSPDX spdx -> spdx CanSPDX _ spdx | version >= makeVersion [2,2] -> spdx CanSPDX cabal _ -> prettyShow cabal DontTouch original -> original mustSPDX :: Bool mustSPDX = maybe False f license where f = \case DontTouch _ -> False CanSPDX _ _ -> False MustSPDX _ -> True verbatimCabalVersion :: Maybe String verbatimCabalVersion = listToMaybe (mapMaybe f packageVerbatim) where f :: Verbatim -> Maybe String f = \ case VerbatimLiteral _ -> Nothing VerbatimObject o -> case Map.lookup "cabal-version" o of Just v -> Just (verbatimValueToString v) Nothing -> Nothing inferredCabalVersion :: String inferredCabalVersion = showVersion version version = fromMaybe (makeVersion [1,12]) $ maximum [ packageCabalVersion , packageLibrary >>= libraryCabalVersion , internalLibsCabalVersion packageInternalLibraries , executablesCabalVersion packageExecutables , executablesCabalVersion packageTests , executablesCabalVersion packageBenchmarks ] packageCabalVersion :: Maybe Version packageCabalVersion = maximum [ Nothing , makeVersion [2,2] <$ guard mustSPDX , makeVersion [1,24] <$ packageCustomSetup , makeVersion [1,18] <$ guard (not (null packageExtraDocFiles)) ] libraryCabalVersion :: Section Library -> Maybe Version libraryCabalVersion sect = maximum [ makeVersion [1,22] <$ guard (has libraryReexportedModules) , makeVersion [2,0] <$ guard (has librarySignatures) , makeVersion [2,0] <$ guard (has libraryGeneratedModules) , makeVersion [3,0] <$ guard (has libraryVisibility) , sectionCabalVersion sect ] where has field = any (not . null . field) sect internalLibsCabalVersion :: Map String (Section Library) -> Maybe Version internalLibsCabalVersion internalLibraries | Map.null internalLibraries = Nothing | otherwise = foldr max (Just $ makeVersion [2,0]) versions where versions = libraryCabalVersion <$> Map.elems internalLibraries executablesCabalVersion :: Map String (Section Executable) -> Maybe Version executablesCabalVersion = foldr max Nothing . map executableCabalVersion . Map.elems executableCabalVersion :: Section Executable -> Maybe Version executableCabalVersion sect = maximum [ makeVersion [2,0] <$ guard (executableHasGeneratedModules sect) , sectionCabalVersion sect ] executableHasGeneratedModules :: Section Executable -> Bool executableHasGeneratedModules = any (not . null . executableGeneratedModules) sectionCabalVersion :: Section a -> Maybe Version sectionCabalVersion sect = maximum $ [ makeVersion [2,2] <$ guard (sectionSatisfies (not . null . sectionCxxSources) sect) , makeVersion [2,2] <$ guard (sectionSatisfies (not . null . sectionCxxOptions) sect) , makeVersion [2,0] <$ guard (sectionSatisfies (any hasMixins . unDependencies . sectionDependencies) sect) , makeVersion [3,0] <$ guard (sectionSatisfies (any hasSubcomponents . Map.keys . unDependencies . sectionDependencies) sect) ] ++ map versionFromSystemBuildTool systemBuildTools where versionFromSystemBuildTool name | name `elem` known_1_10 = Nothing | name `elem` known_1_14 = Just (makeVersion [1,14]) | name `elem` known_1_22 = Just (makeVersion [1,22]) | otherwise = Just (makeVersion [2,0]) known_1_10 = [ "ghc" , "ghc-pkg" , "hugs" , "ffihugs" , "nhc98" , "hmake" , "jhc" , "lhc" , "lhc-pkg" , "uhc" , "gcc" , "ranlib" , "ar" , "strip" , "ld" , "tar" , "pkg-config" ] \\ [ -- Support for these build tools has been removed from Cabal at some point "hugs" , "ffihugs" , "nhc98" , "ranlib" , "lhc" , "lhc-pkg" ] known_1_14 = [ "hpc" ] known_1_22 = [ "ghcjs" , "ghcjs-pkg" -- , "haskell-suite" // not a real build tool -- , "haskell-suite-pkg" // not a real build tool ] systemBuildTools :: [String] systemBuildTools = Map.keys $ unSystemBuildTools $ sectionAll sectionSystemBuildTools sect sectionSatisfies :: (Section a -> Bool) -> Section a -> Bool sectionSatisfies p sect = or [ p sect , any (any (sectionSatisfies p)) (sectionConditionals sect) ] sectionAll :: (Semigroup b, Monoid b) => (Section a -> b) -> Section a -> b sectionAll f sect = f sect <> foldMap (foldMap $ sectionAll f) (sectionConditionals sect) hasMixins :: DependencyInfo -> Bool hasMixins (DependencyInfo mixins _) = not (null mixins) hasSubcomponents :: String -> Bool hasSubcomponents = elem ':' decodeValue :: FromValue a => ProgramName -> FilePath -> Value -> Warnings (Errors IO) a decodeValue (ProgramName programName) file value = do (r, unknown) <- lift . ExceptT . return $ first (prefix ++) (Config.decodeValue value) case r of UnsupportedSpecVersion v -> do lift $ throwE ("The file " ++ file ++ " requires version " ++ showVersion v ++ " of the Hpack package specification, however this version of " ++ programName ++ " only supports versions up to " ++ showVersion Hpack.version ++ ". Upgrading to the latest version of " ++ programName ++ " may resolve this issue.") SupportedSpecVersion a -> do tell (map formatUnknownField unknown) return a where prefix = file ++ ": " formatUnknownField name = prefix ++ "Ignoring unrecognized field " ++ name data CheckSpecVersion a = SupportedSpecVersion a | UnsupportedSpecVersion Version instance FromValue a => FromValue (CheckSpecVersion a) where fromValue = withObject $ \ o -> o .:? "spec-version" >>= \ case Just (ParseSpecVersion v) | Hpack.version < v -> return $ UnsupportedSpecVersion v _ -> SupportedSpecVersion <$> fromValue (Object o) newtype ParseSpecVersion = ParseSpecVersion Version instance FromValue ParseSpecVersion where fromValue value = do s <- case value of Number n -> return (scientificToVersion n) String s -> return (T.unpack s) _ -> typeMismatch "Number or String" value case parseVersion s of Just v -> return (ParseSpecVersion v) Nothing -> fail ("invalid value " ++ show s) data Package = Package { packageName :: String , packageVersion :: String , packageSynopsis :: Maybe String , packageDescription :: Maybe String , packageHomepage :: Maybe String , packageBugReports :: Maybe String , packageCategory :: Maybe String , packageStability :: Maybe String , packageAuthor :: [String] , packageMaintainer :: [String] , packageCopyright :: [String] , packageBuildType :: BuildType , packageLicense :: Maybe String , packageLicenseFile :: [FilePath] , packageTestedWith :: Maybe String , packageFlags :: [Flag] , packageExtraSourceFiles :: [Path] , packageExtraDocFiles :: [Path] , packageDataFiles :: [Path] , packageDataDir :: Maybe FilePath , packageSourceRepository :: Maybe SourceRepository , packageCustomSetup :: Maybe CustomSetup , packageLibrary :: Maybe (Section Library) , packageInternalLibraries :: Map String (Section Library) , packageExecutables :: Map String (Section Executable) , packageTests :: Map String (Section Executable) , packageBenchmarks :: Map String (Section Executable) , packageVerbatim :: [Verbatim] } deriving (Eq, Show) data CustomSetup = CustomSetup { customSetupDependencies :: Dependencies } deriving (Eq, Show) data Library = Library { libraryExposed :: Maybe Bool , libraryVisibility :: Maybe String , libraryExposedModules :: [String] , libraryOtherModules :: [String] , libraryGeneratedModules :: [String] , libraryReexportedModules :: [String] , librarySignatures :: [String] } deriving (Eq, Show) data Executable = Executable { executableMain :: Maybe FilePath , executableOtherModules :: [String] , executableGeneratedModules :: [String] } deriving (Eq, Show) data BuildTool = BuildTool String String | LocalBuildTool String deriving (Show, Eq, Ord) data Section a = Section { sectionData :: a , sectionSourceDirs :: [FilePath] , sectionDependencies :: Dependencies , sectionPkgConfigDependencies :: [String] , sectionDefaultExtensions :: [String] , sectionOtherExtensions :: [String] , sectionGhcOptions :: [GhcOption] , sectionGhcProfOptions :: [GhcProfOption] , sectionGhcjsOptions :: [GhcjsOption] , sectionCppOptions :: [CppOption] , sectionCcOptions :: [CcOption] , sectionCSources :: [Path] , sectionCxxOptions :: [CxxOption] , sectionCxxSources :: [Path] , sectionJsSources :: [Path] , sectionExtraLibDirs :: [FilePath] , sectionExtraLibraries :: [FilePath] , sectionExtraFrameworksDirs :: [FilePath] , sectionFrameworks :: [FilePath] , sectionIncludeDirs :: [FilePath] , sectionInstallIncludes :: [FilePath] , sectionLdOptions :: [LdOption] , sectionBuildable :: Maybe Bool , sectionConditionals :: [Conditional (Section a)] , sectionBuildTools :: Map BuildTool DependencyVersion , sectionSystemBuildTools :: SystemBuildTools , sectionVerbatim :: [Verbatim] } deriving (Eq, Show, Functor, Foldable, Traversable) data Conditional a = Conditional { conditionalCondition :: String , conditionalThen :: a , conditionalElse :: Maybe a } deriving (Eq, Show, Functor, Foldable, Traversable) data FlagSection = FlagSection { _flagSectionDescription :: Maybe String , _flagSectionManual :: Bool , _flagSectionDefault :: Bool } deriving (Eq, Show, Generic, FromValue) data Flag = Flag { flagName :: String , flagDescription :: Maybe String , flagManual :: Bool , flagDefault :: Bool } deriving (Eq, Show) toFlag :: (String, FlagSection) -> Flag toFlag (name, FlagSection description manual def) = Flag name description manual def data SourceRepository = SourceRepository { sourceRepositoryUrl :: String , sourceRepositorySubdir :: Maybe String } deriving (Eq, Show) type Config cSources cxxSources jsSources = Product (CommonOptions cSources cxxSources jsSources Empty) (PackageConfig cSources cxxSources jsSources) traverseConfig :: Traversal Config traverseConfig t = bitraverse (traverseCommonOptions t) (traversePackageConfig t) type ConfigWithDefaults = Product (CommonOptionsWithDefaults Empty) (PackageConfigWithDefaults ParseCSources ParseCxxSources ParseJsSources) type CommonOptionsWithDefaults a = Product DefaultsConfig (CommonOptions ParseCSources ParseCxxSources ParseJsSources a) type WithCommonOptionsWithDefaults a = Product DefaultsConfig (WithCommonOptions ParseCSources ParseCxxSources ParseJsSources a) toPackage :: ProgramName -> FilePath -> FilePath -> ConfigWithDefaults -> Warnings (Errors IO) (Package, String) toPackage programName userDataDir dir = expandDefaultsInConfig programName userDataDir dir >=> traverseConfig (expandForeignSources dir) >=> toPackage_ dir expandDefaultsInConfig :: ProgramName -> FilePath -> FilePath -> ConfigWithDefaults -> Warnings (Errors IO) (Config ParseCSources ParseCxxSources ParseJsSources) expandDefaultsInConfig programName userDataDir dir = bitraverse (expandGlobalDefaults programName userDataDir dir) (expandSectionDefaults programName userDataDir dir) expandGlobalDefaults :: ProgramName -> FilePath -> FilePath -> CommonOptionsWithDefaults Empty -> Warnings (Errors IO) (CommonOptions ParseCSources ParseCxxSources ParseJsSources Empty) expandGlobalDefaults programName userDataDir dir = do fmap (`Product` Empty) >>> expandDefaults programName userDataDir dir >=> \ (Product c Empty) -> return c expandSectionDefaults :: ProgramName -> FilePath -> FilePath -> PackageConfigWithDefaults ParseCSources ParseCxxSources ParseJsSources -> Warnings (Errors IO) (PackageConfig ParseCSources ParseCxxSources ParseJsSources) expandSectionDefaults programName userDataDir dir p@PackageConfig{..} = do library <- traverse (expandDefaults programName userDataDir dir) packageConfigLibrary internalLibraries <- traverse (traverse (expandDefaults programName userDataDir dir)) packageConfigInternalLibraries executable <- traverse (expandDefaults programName userDataDir dir) packageConfigExecutable executables <- traverse (traverse (expandDefaults programName userDataDir dir)) packageConfigExecutables tests <- traverse (traverse (expandDefaults programName userDataDir dir)) packageConfigTests benchmarks <- traverse (traverse (expandDefaults programName userDataDir dir)) packageConfigBenchmarks return p{ packageConfigLibrary = library , packageConfigInternalLibraries = internalLibraries , packageConfigExecutable = executable , packageConfigExecutables = executables , packageConfigTests = tests , packageConfigBenchmarks = benchmarks } expandDefaults :: (FromValue a, Semigroup a, Monoid a) => ProgramName -> FilePath -> FilePath -> WithCommonOptionsWithDefaults a -> Warnings (Errors IO) (WithCommonOptions ParseCSources ParseCxxSources ParseJsSources a) expandDefaults programName userDataDir = expand [] where expand :: (FromValue a, Semigroup a, Monoid a) => [FilePath] -> FilePath -> WithCommonOptionsWithDefaults a -> Warnings (Errors IO) (WithCommonOptions ParseCSources ParseCxxSources ParseJsSources a) expand seen dir (Product DefaultsConfig{..} c) = do d <- mconcat <$> mapM (get seen dir) (fromMaybeList defaultsConfigDefaults) return (d <> c) get :: forall a. (FromValue a, Semigroup a, Monoid a) => [FilePath] -> FilePath -> Defaults -> Warnings (Errors IO) (WithCommonOptions ParseCSources ParseCxxSources ParseJsSources a) get seen dir defaults = do file <- lift $ ExceptT (ensure userDataDir dir defaults) seen_ <- lift (checkCycle seen file) let dir_ = takeDirectory file decodeYaml programName file >>= expand seen_ dir_ checkCycle :: [FilePath] -> FilePath -> Errors IO [FilePath] checkCycle seen file = do canonic <- liftIO $ canonicalizePath file let seen_ = canonic : seen when (canonic `elem` seen) $ do throwE ("cycle in defaults (" ++ intercalate " -> " (reverse seen_) ++ ")") return seen_ toExecutableMap :: Monad m => String -> Maybe (Map String a) -> Maybe a -> Warnings m (Maybe (Map String a)) toExecutableMap name executables mExecutable = do case mExecutable of Just executable -> do when (isJust executables) $ do tell ["Ignoring field \"executables\" in favor of \"executable\""] return $ Just (Map.fromList [(name, executable)]) Nothing -> return executables type GlobalOptions = CommonOptions CSources CxxSources JsSources Empty toPackage_ :: MonadIO m => FilePath -> Product GlobalOptions (PackageConfig CSources CxxSources JsSources) -> Warnings m (Package, String) toPackage_ dir (Product g PackageConfig{..}) = do executableMap <- toExecutableMap packageName_ packageConfigExecutables packageConfigExecutable let globalVerbatim = commonOptionsVerbatim g globalOptions = g {commonOptionsVerbatim = Nothing} executableNames = maybe [] Map.keys executableMap toSect :: (Monad m, Monoid a) => WithCommonOptions CSources CxxSources JsSources a -> Warnings m (Section a) toSect = toSection packageName_ executableNames . first ((mempty <$ globalOptions) <>) toLib = toSect >=> liftIO . toLibrary dir packageName_ toExecutables = maybe (return mempty) (traverse $ toSect >=> liftIO . toExecutable dir packageName_) mLibrary <- traverse toLib packageConfigLibrary internalLibraries <- maybe (return mempty) (traverse toLib) packageConfigInternalLibraries executables <- toExecutables executableMap tests <- toExecutables packageConfigTests benchmarks <- toExecutables packageConfigBenchmarks licenseFileExists <- liftIO $ doesFileExist (dir "LICENSE") missingSourceDirs <- liftIO $ nub . sort <$> filterM (fmap not <$> doesDirectoryExist . (dir )) ( maybe [] sectionSourceDirs mLibrary ++ concatMap sectionSourceDirs internalLibraries ++ concatMap sectionSourceDirs executables ++ concatMap sectionSourceDirs tests ++ concatMap sectionSourceDirs benchmarks ) extraSourceFiles <- expandGlobs "extra-source-files" dir (fromMaybeList packageConfigExtraSourceFiles) extraDocFiles <- expandGlobs "extra-doc-files" dir (fromMaybeList packageConfigExtraDocFiles) let dataBaseDir = maybe dir (dir ) packageConfigDataDir dataFiles <- expandGlobs "data-files" dataBaseDir (fromMaybeList packageConfigDataFiles) let licenseFiles :: [String] licenseFiles = fromMaybeList $ packageConfigLicenseFile <|> do guard licenseFileExists Just (List ["LICENSE"]) inferredLicense <- case (packageConfigLicense, licenseFiles) of (Nothing, [file]) -> do input <- liftIO (tryReadFile (dir file)) case input >>= inferLicense of Nothing -> do tell ["Inferring license from file " ++ file ++ " failed!"] return Nothing license -> return license _ -> return Nothing let defaultBuildType :: BuildType defaultBuildType = maybe Simple (const Custom) mCustomSetup pkg = Package { packageName = packageName_ , packageVersion = maybe "0.0.0" unPackageVersion packageConfigVersion , packageSynopsis = packageConfigSynopsis , packageDescription = packageConfigDescription , packageHomepage = homepage , packageBugReports = bugReports , packageCategory = packageConfigCategory , packageStability = packageConfigStability , packageAuthor = fromMaybeList packageConfigAuthor , packageMaintainer = fromMaybeList maintainer , packageCopyright = fromMaybeList packageConfigCopyright , packageBuildType = fromMaybe defaultBuildType packageConfigBuildType , packageLicense = join packageConfigLicense , packageLicenseFile = licenseFiles , packageTestedWith = packageConfigTestedWith , packageFlags = flags , packageExtraSourceFiles = extraSourceFiles , packageExtraDocFiles = extraDocFiles , packageDataFiles = dataFiles , packageDataDir = packageConfigDataDir , packageSourceRepository = sourceRepository , packageCustomSetup = mCustomSetup , packageLibrary = mLibrary , packageInternalLibraries = internalLibraries , packageExecutables = executables , packageTests = tests , packageBenchmarks = benchmarks , packageVerbatim = fromMaybeList globalVerbatim } tell nameWarnings tell (formatMissingSourceDirs missingSourceDirs) return (determineCabalVersion inferredLicense pkg) where nameWarnings :: [String] packageName_ :: String (nameWarnings, packageName_) = case packageConfigName of Nothing -> let inferredName = takeBaseName dir in (["Package name not specified, inferred " ++ show inferredName], inferredName) Just n -> ([], n) mCustomSetup :: Maybe CustomSetup mCustomSetup = toCustomSetup <$> packageConfigCustomSetup flags = map toFlag $ toList packageConfigFlags toList :: Maybe (Map String a) -> [(String, a)] toList = Map.toList . fromMaybe mempty formatMissingSourceDirs = map f where f name = "Specified source-dir " ++ show name ++ " does not exist" sourceRepository :: Maybe SourceRepository sourceRepository = github <|> (`SourceRepository` Nothing) <$> packageConfigGit github :: Maybe SourceRepository github = toSourceRepository <$> packageConfigGithub where toSourceRepository :: GitHub -> SourceRepository toSourceRepository (GitHub owner repo subdir) = SourceRepository (githubBaseUrl ++ owner ++ "/" ++ repo) subdir homepage :: Maybe String homepage = case packageConfigHomepage of Just Nothing -> Nothing _ -> join packageConfigHomepage <|> fromGithub where fromGithub = (++ "#readme") . sourceRepositoryUrl <$> github bugReports :: Maybe String bugReports = case packageConfigBugReports of Just Nothing -> Nothing _ -> join packageConfigBugReports <|> fromGithub where fromGithub = (++ "/issues") . sourceRepositoryUrl <$> github maintainer :: Maybe (List String) maintainer = case (packageConfigAuthor, packageConfigMaintainer) of (Just _, Nothing) -> packageConfigAuthor (_, Just m) -> m _ -> Nothing expandForeignSources :: MonadIO m => FilePath -> Traverse (Warnings m) ParseCSources CSources ParseCxxSources CxxSources ParseJsSources JsSources expandForeignSources dir = Traverse { traverseCSources = expand "c-sources" , traverseCxxSources = expand "cxx-sources" , traverseJsSources = expand "js-sources" } where expand fieldName xs = do expandGlobs fieldName dir (fromMaybeList xs) newtype Path = Path { unPath :: FilePath } deriving (Eq, Show, Ord) instance IsString Path where fromString = Path expandGlobs :: MonadIO m => String -> FilePath -> [String] -> Warnings m [Path] expandGlobs name dir patterns = map Path <$> do (warnings, files) <- liftIO $ Util.expandGlobs name dir patterns tell warnings return files toCustomSetup :: CustomSetupSection -> CustomSetup toCustomSetup CustomSetupSection{..} = CustomSetup { customSetupDependencies = fromMaybe mempty customSetupSectionDependencies } traverseSectionAndConditionals :: Monad m => (acc -> Section a -> m (acc, b)) -> (acc -> Section a -> m (acc, b)) -> acc -> Section a -> m (Section b) traverseSectionAndConditionals fData fConditionals acc0 sect@Section{..} = do (acc1, x) <- fData acc0 sect xs <- traverseConditionals acc1 sectionConditionals return sect{sectionData = x, sectionConditionals = xs} where traverseConditionals = traverse . traverse . traverseSectionAndConditionals fConditionals fConditionals getMentionedLibraryModules :: LibrarySection -> [String] getMentionedLibraryModules (LibrarySection _ _ exposedModules generatedExposedModules otherModules generatedOtherModules _ _) = fromMaybeList (exposedModules <> generatedExposedModules <> otherModules <> generatedOtherModules) listModules :: FilePath -> Section a -> IO [String] listModules dir Section{..} = concat <$> mapM (getModules dir) sectionSourceDirs inferModules :: FilePath -> String -> (a -> [String]) -> (b -> [String]) -> ([String] -> [String] -> a -> b) -> ([String] -> a -> b) -> Section a -> IO (Section b) inferModules dir packageName_ getMentionedModules getInferredModules fromData fromConditionals = traverseSectionAndConditionals (fromConfigSection fromData [pathsModuleFromPackageName packageName_]) (fromConfigSection (\ [] -> fromConditionals) []) [] where fromConfigSection fromConfig pathsModule_ outerModules sect@Section{sectionData = conf} = do modules <- listModules dir sect let mentionedModules = concatMap getMentionedModules sect inferableModules = (modules \\ outerModules) \\ mentionedModules pathsModule = (pathsModule_ \\ outerModules) \\ mentionedModules r = fromConfig pathsModule inferableModules conf return (outerModules ++ getInferredModules r, r) toLibrary :: FilePath -> String -> Section LibrarySection -> IO (Section Library) toLibrary dir name = inferModules dir name getMentionedLibraryModules getLibraryModules fromLibrarySectionTopLevel fromLibrarySectionInConditional where getLibraryModules :: Library -> [String] getLibraryModules Library{..} = libraryExposedModules ++ libraryOtherModules fromLibrarySectionTopLevel pathsModule inferableModules LibrarySection{..} = Library librarySectionExposed librarySectionVisibility exposedModules otherModules generatedModules reexportedModules signatures where (exposedModules, otherModules, generatedModules) = determineModules pathsModule inferableModules librarySectionExposedModules librarySectionGeneratedExposedModules librarySectionOtherModules librarySectionGeneratedOtherModules reexportedModules = fromMaybeList librarySectionReexportedModules signatures = fromMaybeList librarySectionSignatures determineModules :: [String] -> [String] -> Maybe (List String) -> Maybe (List String) -> Maybe (List String) -> Maybe (List String) -> ([String], [String], [String]) determineModules pathsModule inferable mExposed mGeneratedExposed mOther mGeneratedOther = (exposed, others, generated) where generated = fromMaybeList (mGeneratedExposed <> mGeneratedOther) exposed = maybe inferable fromList mExposed ++ fromMaybeList mGeneratedExposed others = maybe ((inferable \\ exposed) ++ pathsModule) fromList mOther ++ fromMaybeList mGeneratedOther fromLibrarySectionInConditional :: [String] -> LibrarySection -> Library fromLibrarySectionInConditional inferableModules lib@(LibrarySection _ _ exposedModules _ otherModules _ _ _) = case (exposedModules, otherModules) of (Nothing, Nothing) -> addToOtherModules inferableModules (fromLibrarySectionPlain lib) _ -> fromLibrarySectionPlain lib where addToOtherModules xs r = r {libraryOtherModules = xs ++ libraryOtherModules r} fromLibrarySectionPlain :: LibrarySection -> Library fromLibrarySectionPlain LibrarySection{..} = Library { libraryExposed = librarySectionExposed , libraryVisibility = librarySectionVisibility , libraryExposedModules = fromMaybeList (librarySectionExposedModules <> librarySectionGeneratedExposedModules) , libraryOtherModules = fromMaybeList (librarySectionOtherModules <> librarySectionGeneratedOtherModules) , libraryGeneratedModules = fromMaybeList (librarySectionGeneratedOtherModules <> librarySectionGeneratedExposedModules) , libraryReexportedModules = fromMaybeList librarySectionReexportedModules , librarySignatures = fromMaybeList librarySectionSignatures } getMentionedExecutableModules :: ExecutableSection -> [String] getMentionedExecutableModules (ExecutableSection main otherModules generatedModules)= maybe id (:) (main >>= toModule . splitDirectories) $ fromMaybeList (otherModules <> generatedModules) toExecutable :: FilePath -> String -> Section ExecutableSection -> IO (Section Executable) toExecutable dir packageName_ = inferModules dir packageName_ getMentionedExecutableModules executableOtherModules fromExecutableSection (fromExecutableSection []) . expandMain where fromExecutableSection :: [String] -> [String] -> ExecutableSection -> Executable fromExecutableSection pathsModule inferableModules ExecutableSection{..} = (Executable executableSectionMain (otherModules ++ generatedModules) generatedModules) where otherModules = maybe (inferableModules ++ pathsModule) fromList executableSectionOtherModules generatedModules = maybe [] fromList executableSectionGeneratedOtherModules expandMain :: Section ExecutableSection -> Section ExecutableSection expandMain = flatten . expand where expand :: Section ExecutableSection -> Section ([GhcOption], ExecutableSection) expand = fmap go where go exec@ExecutableSection{..} = let (mainSrcFile, ghcOptions) = maybe (Nothing, []) (first Just . parseMain) executableSectionMain in (ghcOptions, exec{executableSectionMain = mainSrcFile}) flatten :: Section ([GhcOption], ExecutableSection) -> Section ExecutableSection flatten sect@Section{sectionData = (ghcOptions, exec), ..} = sect{ sectionData = exec , sectionGhcOptions = sectionGhcOptions ++ ghcOptions , sectionConditionals = map (fmap flatten) sectionConditionals } toSection :: Monad m => String -> [String] -> WithCommonOptions CSources CxxSources JsSources a -> Warnings m (Section a) toSection packageName_ executableNames = go where go (Product CommonOptions{..} a) = do (systemBuildTools, buildTools) <- maybe (return mempty) toBuildTools commonOptionsBuildTools conditionals <- mapM toConditional (fromMaybeList commonOptionsWhen) return Section { sectionData = a , sectionSourceDirs = fromMaybeList commonOptionsSourceDirs , sectionDefaultExtensions = fromMaybeList commonOptionsDefaultExtensions , sectionOtherExtensions = fromMaybeList commonOptionsOtherExtensions , sectionGhcOptions = fromMaybeList commonOptionsGhcOptions , sectionGhcProfOptions = fromMaybeList commonOptionsGhcProfOptions , sectionGhcjsOptions = fromMaybeList commonOptionsGhcjsOptions , sectionCppOptions = fromMaybeList commonOptionsCppOptions , sectionCcOptions = fromMaybeList commonOptionsCcOptions , sectionCSources = commonOptionsCSources , sectionCxxOptions = fromMaybeList commonOptionsCxxOptions , sectionCxxSources = commonOptionsCxxSources , sectionJsSources = commonOptionsJsSources , sectionExtraLibDirs = fromMaybeList commonOptionsExtraLibDirs , sectionExtraLibraries = fromMaybeList commonOptionsExtraLibraries , sectionExtraFrameworksDirs = fromMaybeList commonOptionsExtraFrameworksDirs , sectionFrameworks = fromMaybeList commonOptionsFrameworks , sectionIncludeDirs = fromMaybeList commonOptionsIncludeDirs , sectionInstallIncludes = fromMaybeList commonOptionsInstallIncludes , sectionLdOptions = fromMaybeList commonOptionsLdOptions , sectionBuildable = commonOptionsBuildable , sectionDependencies = fromMaybe mempty commonOptionsDependencies , sectionPkgConfigDependencies = fromMaybeList commonOptionsPkgConfigDependencies , sectionConditionals = conditionals , sectionBuildTools = buildTools , sectionSystemBuildTools = systemBuildTools <> fromMaybe mempty commonOptionsSystemBuildTools , sectionVerbatim = fromMaybeList commonOptionsVerbatim } toBuildTools :: Monad m => BuildTools -> Warnings m (SystemBuildTools, Map BuildTool DependencyVersion) toBuildTools = fmap (mkSystemBuildTools &&& mkBuildTools) . mapM (toBuildTool packageName_ executableNames). unBuildTools where mkSystemBuildTools :: [Either (String, VersionConstraint) b] -> SystemBuildTools mkSystemBuildTools = SystemBuildTools . Map.fromList . lefts mkBuildTools = Map.fromList . rights toConditional :: Monad m => ConditionalSection CSources CxxSources JsSources a -> Warnings m (Conditional (Section a)) toConditional x = case x of ThenElseConditional (Product (ThenElse then_ else_) c) -> conditional c <$> (go then_) <*> (Just <$> go else_) FlatConditional (Product sect c) -> conditional c <$> (go sect) <*> pure Nothing where conditional (Condition (Cond c)) = Conditional c type SystemBuildTool = (String, VersionConstraint) toBuildTool :: Monad m => String -> [String] -> (ParseBuildTool, DependencyVersion) -> Warnings m (Either SystemBuildTool (BuildTool, DependencyVersion)) toBuildTool packageName_ executableNames = \ case (QualifiedBuildTool pkg executable, v) | pkg == packageName_ && executable `elem` executableNames -> localBuildTool executable v | otherwise -> buildTool pkg executable v (UnqualifiedBuildTool executable, v) | executable `elem` executableNames -> localBuildTool executable v | Just pkg <- lookup executable legacyTools -> legacyBuildTool pkg executable v | executable `elem` legacySystemTools, DependencyVersion Nothing c <- v -> legacySystemBuildTool executable c | otherwise -> buildTool executable executable v where buildTool pkg executable v = return . Right $ (BuildTool pkg executable, v) systemBuildTool = return . Left localBuildTool executable v = return . Right $ (LocalBuildTool executable, v) legacyBuildTool pkg executable v = warnLegacyTool pkg executable >> buildTool pkg executable v legacySystemBuildTool executable c = warnLegacySystemTool executable >> systemBuildTool (executable, c) legacyTools = [ ("gtk2hsTypeGen", "gtk2hs-buildtools") , ("gtk2hsHookGenerator", "gtk2hs-buildtools") , ("gtk2hsC2hs", "gtk2hs-buildtools") , ("cabal", "cabal-install") , ("grgen", "cgen") , ("cgen-hs", "cgen") ] legacySystemTools = [ "ghc" , "git" , "llvm-config" , "gfortran" , "gcc" , "couchdb" , "mcc" , "nix-store" , "nix-instantiate" , "nix-hash" , "nix-env" , "nix-build" ] warnLegacyTool pkg name = tell ["Usage of the unqualified build-tool name " ++ show name ++ " is deprecated! Please use the qualified name \"" ++ pkg ++ ":" ++ name ++ "\" instead!"] warnLegacySystemTool name = tell ["Listing " ++ show name ++ " under build-tools is deperecated! Please list system executables under system-build-tools instead!"] pathsModuleFromPackageName :: String -> String pathsModuleFromPackageName name = "Paths_" ++ map f name where f '-' = '_' f x = x getModules :: FilePath -> FilePath -> IO [String] getModules dir src_ = sort <$> do exists <- doesDirectoryExist (dir src_) if exists then do src <- canonicalizePath (dir src_) removeSetup src . toModules <$> getModuleFilesRecursive src else return [] where toModules :: [[FilePath]] -> [String] toModules = catMaybes . map toModule removeSetup :: FilePath -> [String] -> [String] removeSetup src | src == dir = filter (/= "Setup") | otherwise = id hpack-0.34.2/src/Hpack/Util.hs0000644000000000000000000001127513665434154014163 0ustar0000000000000000module Hpack.Util ( GhcOption , GhcProfOption , GhcjsOption , CppOption , CcOption , CxxOption , LdOption , parseMain , toModule , getModuleFilesRecursive , tryReadFile , expandGlobs , sort , lexicographically , Hash , sha256 ) where import Control.Exception import Control.Monad import Data.Char import Data.Bifunctor import Data.List hiding (sort) import Data.Ord import System.IO.Error import System.Directory import System.FilePath import qualified System.FilePath.Posix as Posix import System.FilePath.Glob import Crypto.Hash import Hpack.Haskell import Hpack.Utf8 as Utf8 sort :: [String] -> [String] sort = sortBy (comparing lexicographically) lexicographically :: String -> (String, String) lexicographically x = (map toLower x, x) type GhcOption = String type GhcProfOption = String type GhcjsOption = String type CppOption = String type CcOption = String type CxxOption = String type LdOption = String parseMain :: String -> (FilePath, [GhcOption]) parseMain main = case reverse name of x : _ | isQualifiedIdentifier name && x `notElem` ["hs", "lhs"] -> (intercalate "/" (init name) ++ ".hs", ["-main-is " ++ main]) _ | isModule name -> (intercalate "/" name ++ ".hs", ["-main-is " ++ main]) _ -> (main, []) where name = splitOn '.' main splitOn :: Char -> String -> [String] splitOn c = go where go xs = case break (== c) xs of (ys, "") -> [ys] (ys, _:zs) -> ys : go zs toModule :: [FilePath] -> Maybe String toModule path = case reverse path of [] -> Nothing x : xs -> do m <- msum $ map (`stripSuffix` x) [ ".hs" , ".lhs" , ".chs" , ".hsc" , ".y" , ".ly" , ".x" ] let name = reverse (m : xs) guard (isModule name) >> return (intercalate "." name) where stripSuffix :: String -> String -> Maybe String stripSuffix suffix x = reverse <$> stripPrefix (reverse suffix) (reverse x) getModuleFilesRecursive :: FilePath -> IO [[String]] getModuleFilesRecursive baseDir = go [] where go :: [FilePath] -> IO [[FilePath]] go dir = do c <- map ((dir ++) . return) . filter (`notElem` [".", ".."]) <$> getDirectoryContents (pathTo dir) subdirsFiles <- filterM (doesDirectoryExist . pathTo) c >>= mapM go . filter isModule files <- filterM (doesFileExist . pathTo) c return (files ++ concat subdirsFiles) where pathTo :: [FilePath] -> FilePath pathTo p = baseDir joinPath p tryReadFile :: FilePath -> IO (Maybe String) tryReadFile file = do r <- tryJust (guard . isDoesNotExistError) (Utf8.readFile file) return $ either (const Nothing) Just r toPosixFilePath :: FilePath -> FilePath toPosixFilePath = Posix.joinPath . splitDirectories data GlobResult = GlobResult { _globResultPattern :: String , _globResultCompiledPattern :: Pattern , _globResultFiles :: [FilePath] } expandGlobs :: String -> FilePath -> [String] -> IO ([String], [FilePath]) expandGlobs name dir patterns = do files <- globDir compiledPatterns dir >>= mapM removeDirectories let results :: [GlobResult] results = map (uncurry $ uncurry GlobResult) $ zip (zip patterns compiledPatterns) (map sort files) return (combineResults results) where combineResults :: [GlobResult] -> ([String], [FilePath]) combineResults = bimap concat (nub . concat) . unzip . map fromResult fromResult :: GlobResult -> ([String], [FilePath]) fromResult (GlobResult pattern compiledPattern files) = case files of [] -> (warning, literalFile) xs -> ([], map normalize xs) where warning = [warn pattern compiledPattern] literalFile | isLiteral compiledPattern = [pattern] | otherwise = [] normalize :: FilePath -> FilePath normalize = toPosixFilePath . makeRelative dir warn :: String -> Pattern -> String warn pattern compiledPattern | isLiteral compiledPattern = "Specified file " ++ show pattern ++ " for " ++ name ++ " does not exist" | otherwise = "Specified pattern " ++ show pattern ++ " for " ++ name ++ " does not match any files" compiledPatterns :: [Pattern] compiledPatterns = map (compileWith options) patterns removeDirectories :: [FilePath] -> IO [FilePath] removeDirectories = filterM doesFileExist options :: CompOptions options = CompOptions { characterClasses = False , characterRanges = False , numberRanges = False , wildcards = True , recursiveWildcards = True , pathSepInRanges = False , errorRecovery = True } type Hash = String sha256 :: String -> Hash sha256 c = show (hash (Utf8.encodeUtf8 c) :: Digest SHA256) hpack-0.34.2/src/Hpack/Yaml.hs0000644000000000000000000000324713665434154014150 0ustar0000000000000000{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE LambdaCase #-} module Hpack.Yaml ( -- | /__NOTE:__/ This module is exposed to allow integration of Hpack into -- other tools. It is not meant for general use by end users. The following -- caveats apply: -- -- * The API is undocumented, consult the source instead. -- -- * The exposed types and functions primarily serve Hpack's own needs, not -- that of a public API. Breaking changes can happen as Hpack evolves. -- -- As an Hpack user you either want to use the @hpack@ executable or a build -- tool that supports Hpack (e.g. @stack@ or @cabal2nix@). decodeYaml , module Data.Aeson.Config.FromValue ) where import Data.Bifunctor import Data.Yaml hiding (decodeFile, decodeFileWithWarnings) import Data.Yaml.Include import Data.Yaml.Internal (Warning(..)) import Data.Aeson.Config.FromValue import Data.Aeson.Config.Parser (fromAesonPath, formatPath) formatWarning :: FilePath -> Warning -> String formatWarning file = \ case DuplicateKey path -> file ++ ": Duplicate field " ++ formatPath (fromAesonPath path) decodeYaml :: FilePath -> IO (Either String ([String], Value)) decodeYaml file = do result <- decodeFileWithWarnings file return $ either (Left . errToString) (Right . first (map $ formatWarning file)) result where errToString err = file ++ case err of AesonException e -> ": " ++ e InvalidYaml (Just (YamlException s)) -> ": " ++ s InvalidYaml (Just (YamlParseException{..})) -> ":" ++ show yamlLine ++ ":" ++ show yamlColumn ++ ": " ++ yamlProblem ++ " " ++ yamlContext where YamlMark{..} = yamlProblemMark _ -> ": " ++ show err hpack-0.34.2/src/Hpack/Defaults.hs0000644000000000000000000000457013665434154015015 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE LambdaCase #-} module Hpack.Defaults ( ensure , Defaults(..) #ifdef TEST , Result(..) , ensureFile #endif ) where import Network.HTTP.Types import Network.HTTP.Client import Network.HTTP.Client.TLS import Data.List import qualified Data.ByteString.Lazy as LB import qualified Data.ByteString.Char8 as B import System.FilePath import System.Directory import Hpack.Syntax.Defaults type URL = String defaultsUrl :: Github -> URL defaultsUrl Github{..} = "https://raw.githubusercontent.com/" ++ githubOwner ++ "/" ++ githubRepo ++ "/" ++ githubRef ++ "/" ++ intercalate "/" githubPath defaultsCachePath :: FilePath -> Github -> FilePath defaultsCachePath dir Github{..} = joinPath $ dir : "defaults" : githubOwner : githubRepo : githubRef : githubPath data Result = Found | NotFound | Failed String deriving (Eq, Show) get :: URL -> FilePath -> IO Result get url file = do manager <- newManager tlsManagerSettings request <- parseRequest url response <- httpLbs request manager case responseStatus response of Status 200 _ -> do createDirectoryIfMissing True (takeDirectory file) LB.writeFile file (responseBody response) return Found Status 404 _ -> return NotFound status -> return (Failed $ "Error while downloading " ++ url ++ " (" ++ formatStatus status ++ ")") formatStatus :: Status -> String formatStatus (Status code message) = show code ++ " " ++ B.unpack message ensure :: FilePath -> FilePath -> Defaults -> IO (Either String FilePath) ensure userDataDir dir = \ case DefaultsGithub defaults -> do let url = defaultsUrl defaults file = defaultsCachePath userDataDir defaults ensureFile file url >>= \ case Found -> return (Right file) NotFound -> return (Left $ notFound url) Failed err -> return (Left err) DefaultsLocal (Local ((dir ) -> file)) -> do doesFileExist file >>= \ case True -> return (Right file) False -> return (Left $ notFound file) where notFound file = "Invalid value for \"defaults\"! File " ++ file ++ " does not exist!" ensureFile :: FilePath -> URL -> IO Result ensureFile file url = do doesFileExist file >>= \ case True -> return Found False -> get url file hpack-0.34.2/src/Hpack/License.hs0000644000000000000000000000341213665434154014622 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE LambdaCase #-} module Hpack.License where import Control.Arrow ((&&&)) import Distribution.Pretty (prettyShow) import Distribution.Version (mkVersion) import qualified Distribution.License as Cabal import qualified Distribution.SPDX.License as SPDX import Distribution.Parsec (eitherParsec) import qualified Data.License.Infer as Infer data License a = DontTouch String | CanSPDX Cabal.License a | MustSPDX a deriving (Eq, Show, Functor) parseLicense :: String -> License SPDX.License parseLicense license = case lookup license knownLicenses of Just l -> CanSPDX l (Cabal.licenseToSPDX l) Nothing -> case spdxLicense of Just l -> MustSPDX l Nothing -> DontTouch license where knownLicenses :: [(String, Cabal.License)] knownLicenses = map (prettyShow &&& id) (Cabal.BSD4 : Cabal.knownLicenses) spdxLicense :: Maybe SPDX.License spdxLicense = either (const Nothing) Just (eitherParsec license) inferLicense :: String -> Maybe (License SPDX.License) inferLicense = fmap (uncurry CanSPDX . (id &&& Cabal.licenseToSPDX) . toLicense) . Infer.inferLicense where toLicense = \ case Infer.MIT -> Cabal.MIT Infer.ISC -> Cabal.ISC Infer.BSD2 -> Cabal.BSD2 Infer.BSD3 -> Cabal.BSD3 Infer.BSD4 -> Cabal.BSD4 Infer.Apache_2_0 -> Cabal.Apache (Just $ mkVersion [2,0]) Infer.MPL_2_0 -> Cabal.MPL (mkVersion [2,0]) Infer.GPLv2 -> Cabal.GPL (Just $ mkVersion [2]) Infer.GPLv3 -> Cabal.GPL (Just $ mkVersion [3]) Infer.LGPLv2_1 -> Cabal.LGPL (Just $ mkVersion [2,1]) Infer.LGPLv3 -> Cabal.LGPL (Just $ mkVersion [3]) Infer.AGPLv3 -> Cabal.AGPL (Just $ mkVersion [3]) hpack-0.34.2/src/Hpack/Render.hs0000644000000000000000000003650513665434154014470 0ustar0000000000000000{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE CPP #-} module Hpack.Render ( -- | /__NOTE:__/ This module is exposed to allow integration of Hpack into -- other tools. It is not meant for general use by end users. The following -- caveats apply: -- -- * The API is undocumented, consult the source instead. -- -- * The exposed types and functions primarily serve Hpack's own needs, not -- that of a public API. Breaking changes can happen as Hpack evolves. -- -- As an Hpack user you either want to use the @hpack@ executable or a build -- tool that supports Hpack (e.g. @stack@ or @cabal2nix@). renderPackage , renderPackageWith , defaultRenderSettings , RenderSettings(..) , Alignment(..) , CommaStyle(..) #ifdef TEST , renderConditional , renderDependencies , renderLibraryFields , renderExecutableFields , renderFlag , renderSourceRepository , renderDirectories , formatDescription #endif ) where import Control.Monad import Data.Char import Data.Maybe import Data.List import Data.Map.Lazy (Map) import qualified Data.Map.Lazy as Map import Hpack.Util import Hpack.Config import Hpack.Render.Hints import Hpack.Render.Dsl renderPackage :: [String] -> Package -> String renderPackage oldCabalFile = renderPackageWith settings alignment formattingHintsFieldOrder formattingHintsSectionsFieldOrder where FormattingHints{..} = sniffFormattingHints oldCabalFile alignment = fromMaybe 16 formattingHintsAlignment settings = formattingHintsRenderSettings renderPackageWith :: RenderSettings -> Alignment -> [String] -> [(String, [String])] -> Package -> String renderPackageWith settings headerFieldsAlignment existingFieldOrder sectionsFieldOrder Package{..} = intercalate "\n" (unlines header : chunks) where chunks :: [String] chunks = map unlines . filter (not . null) . map (render settings 0) $ sortStanzaFields sectionsFieldOrder stanzas header :: [String] header = concatMap (render settings {renderSettingsFieldAlignment = headerFieldsAlignment} 0) packageFields packageFields :: [Element] packageFields = addVerbatim packageVerbatim . sortFieldsBy existingFieldOrder $ headerFields ++ [ Field "extra-source-files" (renderPaths packageExtraSourceFiles) , Field "extra-doc-files" (renderPaths packageExtraDocFiles) , Field "data-files" (renderPaths packageDataFiles) ] ++ maybe [] (return . Field "data-dir" . Literal) packageDataDir sourceRepository :: [Element] sourceRepository = maybe [] (return . renderSourceRepository) packageSourceRepository customSetup :: [Element] customSetup = maybe [] (return . renderCustomSetup) packageCustomSetup library :: [Element] library = maybe [] (return . renderLibrary) packageLibrary stanzas :: [Element] stanzas = concat [ sourceRepository , customSetup , map renderFlag packageFlags , library , renderInternalLibraries packageInternalLibraries , renderExecutables packageExecutables , renderTests packageTests , renderBenchmarks packageBenchmarks ] headerFields :: [Element] headerFields = mapMaybe (\(name, value) -> Field name . Literal <$> value) $ [ ("name", Just packageName) , ("version", Just packageVersion) , ("synopsis", packageSynopsis) , ("description", (formatDescription headerFieldsAlignment <$> packageDescription)) , ("category", packageCategory) , ("stability", packageStability) , ("homepage", packageHomepage) , ("bug-reports", packageBugReports) , ("author", formatList packageAuthor) , ("maintainer", formatList packageMaintainer) , ("copyright", formatList packageCopyright) , ("license", packageLicense) , case packageLicenseFile of [file] -> ("license-file", Just file) files -> ("license-files", formatList files) , ("tested-with", packageTestedWith) , ("build-type", Just (show packageBuildType)) ] formatList :: [String] -> Maybe String formatList xs = guard (not $ null xs) >> (Just $ intercalate separator xs) where separator = let Alignment n = headerFieldsAlignment in ",\n" ++ replicate n ' ' sortStanzaFields :: [(String, [String])] -> [Element] -> [Element] sortStanzaFields sectionsFieldOrder = go where go sections = case sections of [] -> [] Stanza name fields : xs | Just fieldOrder <- lookup name sectionsFieldOrder -> Stanza name (sortFieldsBy fieldOrder fields) : go xs x : xs -> x : go xs formatDescription :: Alignment -> String -> String formatDescription (Alignment alignment) description = case map emptyLineToDot $ lines description of x : xs -> intercalate "\n" (x : map (indentation ++) xs) [] -> "" where n = max alignment (length ("description: " :: String)) indentation = replicate n ' ' emptyLineToDot xs | isEmptyLine xs = "." | otherwise = xs isEmptyLine = all isSpace renderSourceRepository :: SourceRepository -> Element renderSourceRepository SourceRepository{..} = Stanza "source-repository head" [ Field "type" "git" , Field "location" (Literal sourceRepositoryUrl) , Field "subdir" (maybe "" Literal sourceRepositorySubdir) ] renderFlag :: Flag -> Element renderFlag Flag {..} = Stanza ("flag " ++ flagName) $ description ++ [ Field "manual" (Literal $ show flagManual) , Field "default" (Literal $ show flagDefault) ] where description = maybe [] (return . Field "description" . Literal) flagDescription renderInternalLibraries :: Map String (Section Library) -> [Element] renderInternalLibraries = map renderInternalLibrary . Map.toList renderInternalLibrary :: (String, Section Library) -> Element renderInternalLibrary (name, sect) = Stanza ("library " ++ name) (renderLibrarySection sect) renderExecutables :: Map String (Section Executable) -> [Element] renderExecutables = map renderExecutable . Map.toList renderExecutable :: (String, Section Executable) -> Element renderExecutable (name, sect@(sectionData -> Executable{..})) = Stanza ("executable " ++ name) (renderExecutableSection [] sect) renderTests :: Map String (Section Executable) -> [Element] renderTests = map renderTest . Map.toList renderTest :: (String, Section Executable) -> Element renderTest (name, sect) = Stanza ("test-suite " ++ name) (renderExecutableSection [Field "type" "exitcode-stdio-1.0"] sect) renderBenchmarks :: Map String (Section Executable) -> [Element] renderBenchmarks = map renderBenchmark . Map.toList renderBenchmark :: (String, Section Executable) -> Element renderBenchmark (name, sect) = Stanza ("benchmark " ++ name) (renderExecutableSection [Field "type" "exitcode-stdio-1.0"] sect) renderExecutableSection :: [Element] -> Section Executable -> [Element] renderExecutableSection extraFields = renderSection renderExecutableFields extraFields [defaultLanguage] renderExecutableFields :: Executable -> [Element] renderExecutableFields Executable{..} = mainIs ++ [otherModules, generatedModules] where mainIs = maybe [] (return . Field "main-is" . Literal) executableMain otherModules = renderOtherModules executableOtherModules generatedModules = renderGeneratedModules executableGeneratedModules renderCustomSetup :: CustomSetup -> Element renderCustomSetup CustomSetup{..} = Stanza "custom-setup" $ renderDependencies "setup-depends" customSetupDependencies renderLibrary :: Section Library -> Element renderLibrary sect = Stanza "library" $ renderLibrarySection sect renderLibrarySection :: Section Library -> [Element] renderLibrarySection = renderSection renderLibraryFields [] [defaultLanguage] renderLibraryFields :: Library -> [Element] renderLibraryFields Library{..} = maybe [] (return . renderExposed) libraryExposed ++ maybe [] (return . renderVisibility) libraryVisibility ++ [ renderExposedModules libraryExposedModules , renderOtherModules libraryOtherModules , renderGeneratedModules libraryGeneratedModules , renderReexportedModules libraryReexportedModules , renderSignatures librarySignatures ] renderExposed :: Bool -> Element renderExposed = Field "exposed" . Literal . show renderVisibility :: String -> Element renderVisibility = Field "visibility" . Literal renderSection :: (a -> [Element]) -> [Element] -> [Element] -> Section a -> [Element] renderSection renderSectionData extraFieldsStart extraFieldsEnd Section{..} = addVerbatim sectionVerbatim $ extraFieldsStart ++ renderSectionData sectionData ++ [ renderDirectories "hs-source-dirs" sectionSourceDirs , renderDefaultExtensions sectionDefaultExtensions , renderOtherExtensions sectionOtherExtensions , renderGhcOptions sectionGhcOptions , renderGhcProfOptions sectionGhcProfOptions , renderGhcjsOptions sectionGhcjsOptions , renderCppOptions sectionCppOptions , renderCcOptions sectionCcOptions , renderCxxOptions sectionCxxOptions , renderDirectories "include-dirs" sectionIncludeDirs , Field "install-includes" (LineSeparatedList sectionInstallIncludes) , Field "c-sources" (renderPaths sectionCSources) , Field "cxx-sources" (renderPaths sectionCxxSources) , Field "js-sources" (renderPaths sectionJsSources) , renderDirectories "extra-lib-dirs" sectionExtraLibDirs , Field "extra-libraries" (LineSeparatedList sectionExtraLibraries) , renderDirectories "extra-frameworks-dirs" sectionExtraFrameworksDirs , Field "frameworks" (LineSeparatedList sectionFrameworks) , renderLdOptions sectionLdOptions , Field "pkgconfig-depends" (CommaSeparatedList sectionPkgConfigDependencies) ] ++ renderBuildTools sectionBuildTools sectionSystemBuildTools ++ renderDependencies "build-depends" sectionDependencies ++ maybe [] (return . renderBuildable) sectionBuildable ++ map (renderConditional renderSectionData) sectionConditionals ++ extraFieldsEnd addVerbatim :: [Verbatim] -> [Element] -> [Element] addVerbatim verbatim fields = filterVerbatim verbatim fields ++ renderVerbatim verbatim filterVerbatim :: [Verbatim] -> [Element] -> [Element] filterVerbatim verbatim = filter p where p :: Element -> Bool p = \ case Field name _ -> name `notElem` fields _ -> True fields = concatMap verbatimFieldNames verbatim verbatimFieldNames :: Verbatim -> [String] verbatimFieldNames verbatim = case verbatim of VerbatimLiteral _ -> [] VerbatimObject o -> Map.keys o renderVerbatim :: [Verbatim] -> [Element] renderVerbatim = concatMap $ \ case VerbatimLiteral s -> [Verbatim s] VerbatimObject o -> renderVerbatimObject o renderVerbatimObject :: Map String VerbatimValue -> [Element] renderVerbatimObject = map renderPair . Map.toList where renderPair (key, value) = case lines (verbatimValueToString value) of [x] -> Field key (Literal x) xs -> Field key (LineSeparatedList xs) renderConditional :: (a -> [Element]) -> Conditional (Section a) -> Element renderConditional renderSectionData (Conditional condition sect mElse) = case mElse of Nothing -> if_ Just else_ -> Group if_ (Stanza "else" $ renderSection renderSectionData [] [] else_) where if_ = Stanza ("if " ++ condition) (renderSection renderSectionData [] [] sect) defaultLanguage :: Element defaultLanguage = Field "default-language" "Haskell2010" renderDirectories :: String -> [String] -> Element renderDirectories name = Field name . LineSeparatedList . replaceDots where replaceDots = map replaceDot replaceDot xs = case xs of "." -> "./." _ -> xs renderExposedModules :: [String] -> Element renderExposedModules = Field "exposed-modules" . LineSeparatedList renderOtherModules :: [String] -> Element renderOtherModules = Field "other-modules" . LineSeparatedList renderGeneratedModules :: [String] -> Element renderGeneratedModules = Field "autogen-modules" . LineSeparatedList renderReexportedModules :: [String] -> Element renderReexportedModules = Field "reexported-modules" . CommaSeparatedList renderSignatures :: [String] -> Element renderSignatures = Field "signatures" . CommaSeparatedList renderDependencies :: String -> Dependencies -> [Element] renderDependencies name deps = [ Field name (CommaSeparatedList renderedDeps) , Field "mixins" (CommaSeparatedList $ concat mixins) ] where (renderedDeps, mixins) = unzip . map renderDependency . Map.toList $ unDependencies deps renderDependency :: (String, DependencyInfo) -> (String, [String]) renderDependency (name, DependencyInfo mixins version) = ( name ++ renderVersion version , [ name ++ " " ++ mixin | mixin <- mixins ] ) renderVersion :: DependencyVersion -> String renderVersion (DependencyVersion _ c) = renderVersionConstraint c renderVersionConstraint :: VersionConstraint -> String renderVersionConstraint version = case version of AnyVersion -> "" VersionRange x -> " " ++ x renderBuildTools :: Map BuildTool DependencyVersion -> SystemBuildTools -> [Element] renderBuildTools (map renderBuildTool . Map.toList -> xs) systemBuildTools = [ Field "build-tools" (CommaSeparatedList $ [x | BuildTools x <- xs] ++ renderSystemBuildTools systemBuildTools) , Field "build-tool-depends" (CommaSeparatedList [x | BuildToolDepends x <- xs]) ] data RenderBuildTool = BuildTools String | BuildToolDepends String renderBuildTool :: (BuildTool, DependencyVersion) -> RenderBuildTool renderBuildTool (buildTool, renderVersion -> version) = case buildTool of LocalBuildTool executable -> BuildTools (executable ++ version) BuildTool pkg executable | pkg == executable && executable `elem` knownBuildTools -> BuildTools (executable ++ version) | otherwise -> BuildToolDepends (pkg ++ ":" ++ executable ++ version) where knownBuildTools :: [String] knownBuildTools = [ "alex" , "c2hs" , "cpphs" , "greencard" , "haddock" , "happy" , "hsc2hs" , "hscolour" ] renderSystemBuildTools :: SystemBuildTools -> [String] renderSystemBuildTools = map renderSystemBuildTool . Map.toList . unSystemBuildTools renderSystemBuildTool :: (String, VersionConstraint) -> String renderSystemBuildTool (name, constraint) = name ++ renderVersionConstraint constraint renderGhcOptions :: [GhcOption] -> Element renderGhcOptions = Field "ghc-options" . WordList renderGhcProfOptions :: [GhcProfOption] -> Element renderGhcProfOptions = Field "ghc-prof-options" . WordList renderGhcjsOptions :: [GhcjsOption] -> Element renderGhcjsOptions = Field "ghcjs-options" . WordList renderCppOptions :: [CppOption] -> Element renderCppOptions = Field "cpp-options" . WordList renderCcOptions :: [CcOption] -> Element renderCcOptions = Field "cc-options" . WordList renderCxxOptions :: [CxxOption] -> Element renderCxxOptions = Field "cxx-options" . WordList renderLdOptions :: [LdOption] -> Element renderLdOptions = Field "ld-options" . WordList renderBuildable :: Bool -> Element renderBuildable = Field "buildable" . Literal . show renderDefaultExtensions :: [String] -> Element renderDefaultExtensions = Field "default-extensions" . WordList renderOtherExtensions :: [String] -> Element renderOtherExtensions = Field "other-extensions" . WordList renderPaths :: [Path] -> Value renderPaths = LineSeparatedList . map renderPath where renderPath :: Path -> FilePath renderPath (Path path) | needsQuoting path = show path | otherwise = path needsQuoting :: FilePath -> Bool needsQuoting = any (\x -> isSpace x || x == ',') hpack-0.34.2/src/Hpack/Haskell.hs0000644000000000000000000000174513665434154014632 0ustar0000000000000000module Hpack.Haskell ( isModule , isQualifiedIdentifier , isIdentifier ) where import Data.Char isModule :: [String] -> Bool isModule name = (not . null) name && all isModuleName name isModuleName :: String -> Bool isModuleName name = case name of x : xs -> isUpper x && all isIdChar xs _ -> False isQualifiedIdentifier :: [String] -> Bool isQualifiedIdentifier name = case reverse name of x : xs -> isIdentifier x && isModule xs _ -> False isIdentifier :: String -> Bool isIdentifier name = case name of x : xs -> isLower x && all isIdChar xs && name `notElem` reserved _ -> False reserved :: [String] reserved = [ "case" , "class" , "data" , "default" , "deriving" , "do" , "else" , "foreign" , "if" , "import" , "in" , "infix" , "infixl" , "infixr" , "instance" , "let" , "module" , "newtype" , "of" , "then" , "type" , "where" , "_" ] isIdChar :: Char -> Bool isIdChar c = isAlphaNum c || c == '_' || c == '\'' hpack-0.34.2/src/Hpack/Options.hs0000644000000000000000000000506413665434154014700 0ustar0000000000000000{-# LANGUAGE LambdaCase #-} module Hpack.Options where import Control.Applicative import Control.Monad import Data.Maybe import System.FilePath import System.Directory data ParseResult = Help | PrintVersion | PrintNumericVersion | Run ParseOptions | ParseError deriving (Eq, Show) data Verbose = Verbose | NoVerbose deriving (Eq, Show) data Force = Force | NoForce deriving (Eq, Show) data ParseOptions = ParseOptions { parseOptionsVerbose :: Verbose , parseOptionsForce :: Force , parseOptionsHash :: Maybe Bool , parseOptionsToStdout :: Bool , parseOptionsTarget :: FilePath } deriving (Eq, Show) parseOptions :: FilePath -> [String] -> IO ParseResult parseOptions defaultTarget = \ case ["--version"] -> return PrintVersion ["--numeric-version"] -> return PrintNumericVersion ["--help"] -> return Help args -> case targets of Right (target, toStdout) -> do file <- expandTarget defaultTarget target let options | toStdout = ParseOptions NoVerbose Force hash toStdout file | otherwise = ParseOptions verbose force hash toStdout file return (Run options) Left err -> return err where silentFlag = "--silent" forceFlags = ["--force", "-f"] hashFlag = "--hash" noHashFlag = "--no-hash" flags = hashFlag : noHashFlag : silentFlag : forceFlags verbose :: Verbose verbose = if silentFlag `elem` args then NoVerbose else Verbose force :: Force force = if any (`elem` args) forceFlags then Force else NoForce hash :: Maybe Bool hash = listToMaybe . reverse $ mapMaybe parse args where parse :: String -> Maybe Bool parse t = True <$ guard (t == hashFlag) <|> False <$ guard (t == noHashFlag) ys = filter (`notElem` flags) args targets :: Either ParseResult (Maybe FilePath, Bool) targets = case ys of ["-"] -> Right (Nothing, True) ["-", "-"] -> Left ParseError [path] -> Right (Just path, False) [path, "-"] -> Right (Just path, True) [] -> Right (Nothing, False) _ -> Left ParseError expandTarget :: FilePath -> Maybe FilePath -> IO FilePath expandTarget defaultTarget = \ case Nothing -> return defaultTarget Just "" -> return defaultTarget Just target -> do isFile <- doesFileExist target isDirectory <- doesDirectoryExist target return $ case takeFileName target of _ | isFile -> target _ | isDirectory -> target defaultTarget "" -> target defaultTarget _ -> target hpack-0.34.2/src/Hpack/Utf8.hs0000644000000000000000000000300513665434154014064 0ustar0000000000000000module Hpack.Utf8 ( encodeUtf8 , readFile , writeFile , putStr , hPutStr , hPutStrLn ) where import Prelude hiding (readFile, writeFile, putStr) import qualified Data.Text as T import qualified Data.Text.Encoding as Encoding import Data.Text.Encoding.Error (lenientDecode) import qualified Data.ByteString as B import System.IO (Handle, stdout, IOMode(..), withFile, Newline(..), nativeNewline) encodeUtf8 :: String -> B.ByteString encodeUtf8 = Encoding.encodeUtf8 . T.pack decodeUtf8 :: B.ByteString -> String decodeUtf8 = T.unpack . Encoding.decodeUtf8With lenientDecode encodeText :: String -> B.ByteString encodeText = encodeUtf8 . encodeNewlines decodeText :: B.ByteString -> String decodeText = decodeNewlines . decodeUtf8 encodeNewlines :: String -> String encodeNewlines = case nativeNewline of LF -> id CRLF -> go where go xs = case xs of '\n' : ys -> '\r' : '\n' : ys y : ys -> y : go ys [] -> [] decodeNewlines :: String -> String decodeNewlines = go where go xs = case xs of '\r' : '\n' : ys -> '\n' : go ys y : ys -> y : go ys [] -> [] readFile :: FilePath -> IO String readFile = fmap decodeText . B.readFile writeFile :: FilePath -> String -> IO () writeFile name xs = withFile name WriteMode (`hPutStr` xs) putStr :: String -> IO () putStr = hPutStr stdout hPutStrLn :: Handle -> String -> IO () hPutStrLn h xs = hPutStr h xs >> hPutStr h "\n" hPutStr :: Handle -> String -> IO () hPutStr h = B.hPutStr h . encodeText hpack-0.34.2/src/Hpack/CabalFile.hs0000644000000000000000000000502413665434154015043 0ustar0000000000000000{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ViewPatterns #-} module Hpack.CabalFile where import Control.Monad import Data.List import Data.Maybe import Data.Version (Version(..)) import qualified Data.Version as Version import Text.ParserCombinators.ReadP import Hpack.Util makeVersion :: [Int] -> Version makeVersion v = Version v [] data CabalFile = CabalFile { cabalFileCabalVersion :: [String] , cabalFileHpackVersion :: Maybe Version , cabalFileHash :: Maybe Hash , cabalFileContents :: [String] } deriving (Eq, Show) readCabalFile :: FilePath -> IO (Maybe CabalFile) readCabalFile cabalFile = fmap parse <$> tryReadFile cabalFile where parse :: String -> CabalFile parse (splitHeader -> (cabalVersion, h, c)) = CabalFile cabalVersion (extractVersion h) (extractHash h) c splitHeader :: String -> ([String], [String], [String]) splitHeader (removeGitConflictMarkers . lines -> c) = case span (not . isComment) c of (cabalVersion, xs) -> case span isComment xs of (header, body) -> (cabalVersion, header, dropWhile null body) isComment = ("--" `isPrefixOf`) extractHash :: [String] -> Maybe Hash extractHash = extract "-- hash: " Just extractVersion :: [String] -> Maybe Version extractVersion = extract prefix (stripFileName >=> parseVersion . safeInit) where prefix = "-- This file has been generated from " stripFileName :: String -> Maybe String stripFileName = listToMaybe . mapMaybe (stripPrefix " by hpack version ") . tails extract :: String -> (String -> Maybe a) -> [String] -> Maybe a extract prefix parse = listToMaybe . mapMaybe (stripPrefix prefix >=> parse) safeInit :: [a] -> [a] safeInit [] = [] safeInit xs = init xs parseVersion :: String -> Maybe Version parseVersion xs = case [v | (v, "") <- readP_to_S Version.parseVersion xs] of [v] -> Just v _ -> Nothing removeGitConflictMarkers :: [String] -> [String] removeGitConflictMarkers = takeBoth where takeBoth input = case break (isPrefixOf marker) input of (both, _marker : rest) -> both ++ takeOurs rest (both, []) -> both where marker = "<<<<<<< " takeOurs input = case break (== marker) input of (ours, _marker : rest) -> ours ++ dropTheirs rest (ours, []) -> ours where marker = "=======" dropTheirs input = case break (isPrefixOf marker) input of (_theirs, _marker : rest) -> takeBoth rest (_theirs, []) -> [] where marker = ">>>>>>> " hpack-0.34.2/src/Hpack/Render/0000755000000000000000000000000013665434154014123 5ustar0000000000000000hpack-0.34.2/src/Hpack/Render/Hints.hs0000644000000000000000000000737213665434154015555 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ViewPatterns #-} module Hpack.Render.Hints ( FormattingHints (..) , sniffFormattingHints #ifdef TEST , extractFieldOrder , extractSectionsFieldOrder , sanitize , unindent , sniffAlignment , splitField , sniffIndentation , sniffCommaStyle #endif ) where import Data.Char import Data.Maybe import Data.List import Control.Applicative import Hpack.Render.Dsl data FormattingHints = FormattingHints { formattingHintsFieldOrder :: [String] , formattingHintsSectionsFieldOrder :: [(String, [String])] , formattingHintsAlignment :: Maybe Alignment , formattingHintsRenderSettings :: RenderSettings } deriving (Eq, Show) sniffFormattingHints :: [String] -> FormattingHints sniffFormattingHints (sanitize -> input) = FormattingHints { formattingHintsFieldOrder = extractFieldOrder input , formattingHintsSectionsFieldOrder = extractSectionsFieldOrder input , formattingHintsAlignment = sniffAlignment input , formattingHintsRenderSettings = sniffRenderSettings input } sanitize :: [String] -> [String] sanitize = filter (not . isPrefixOf "cabal-version:") . filter (not . null) . map stripEnd stripEnd :: String -> String stripEnd = reverse . dropWhile isSpace . reverse extractFieldOrder :: [String] -> [String] extractFieldOrder = map fst . catMaybes . map splitField extractSectionsFieldOrder :: [String] -> [(String, [String])] extractSectionsFieldOrder = map (fmap extractFieldOrder) . splitSections where splitSections input = case break startsWithSpace input of ([], []) -> [] (xs, ys) -> case span startsWithSpace ys of (fields, zs) -> case reverse xs of name : _ -> (name, unindent fields) : splitSections zs _ -> splitSections zs startsWithSpace :: String -> Bool startsWithSpace xs = case xs of y : _ -> isSpace y _ -> False unindent :: [String] -> [String] unindent input = map (drop indentation) input where indentation = minimum $ map (length . takeWhile isSpace) input sniffAlignment :: [String] -> Maybe Alignment sniffAlignment input = case nub . catMaybes . map indentation . catMaybes . map splitField $ input of [n] -> Just (Alignment n) _ -> Nothing where indentation :: (String, String) -> Maybe Int indentation (name, value) = case span isSpace value of (_, "") -> Nothing (xs, _) -> (Just . succ . length $ name ++ xs) splitField :: String -> Maybe (String, String) splitField field = case span isNameChar field of (xs, ':':ys) -> Just (xs, ys) _ -> Nothing where isNameChar = (`elem` nameChars) nameChars = ['a'..'z'] ++ ['A'..'Z'] ++ "-" sniffIndentation :: [String] -> Maybe Int sniffIndentation input = sniffFrom "library" <|> sniffFrom "executable" where sniffFrom :: String -> Maybe Int sniffFrom section = case findSection . removeEmptyLines $ input of _ : x : _ -> Just . length $ takeWhile isSpace x _ -> Nothing where findSection = dropWhile (not . isPrefixOf section) removeEmptyLines :: [String] -> [String] removeEmptyLines = filter $ any (not . isSpace) sniffCommaStyle :: [String] -> Maybe CommaStyle sniffCommaStyle input | any startsWithComma input = Just LeadingCommas | any (startsWithComma . reverse) input = Just TrailingCommas | otherwise = Nothing where startsWithComma = isPrefixOf "," . dropWhile isSpace sniffRenderSettings :: [String] -> RenderSettings sniffRenderSettings input = RenderSettings indentation fieldAlignment commaStyle where indentation = fromMaybe (renderSettingsIndentation defaultRenderSettings) (sniffIndentation input) fieldAlignment = renderSettingsFieldAlignment defaultRenderSettings commaStyle = fromMaybe (renderSettingsCommaStyle defaultRenderSettings) (sniffCommaStyle input) hpack-0.34.2/src/Hpack/Render/Dsl.hs0000644000000000000000000001033213665434154015200 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Hpack.Render.Dsl ( -- * AST Element (..) , Value (..) -- * Render , RenderSettings (..) , CommaStyle (..) , defaultRenderSettings , Alignment (..) , Nesting , render -- * Utils , sortFieldsBy #ifdef TEST , Lines (..) , renderValue , addSortKey #endif ) where import Data.String import Data.List data Value = Literal String | CommaSeparatedList [String] | LineSeparatedList [String] | WordList [String] deriving (Eq, Show) data Element = Stanza String [Element] | Group Element Element | Field String Value | Verbatim String deriving (Eq, Show) data Lines = SingleLine String | MultipleLines [String] deriving (Eq, Show) data CommaStyle = LeadingCommas | TrailingCommas deriving (Eq, Show) newtype Nesting = Nesting Int deriving (Eq, Show, Num, Enum) newtype Alignment = Alignment Int deriving (Eq, Show, Num) data RenderSettings = RenderSettings { renderSettingsIndentation :: Int , renderSettingsFieldAlignment :: Alignment , renderSettingsCommaStyle :: CommaStyle } deriving (Eq, Show) defaultRenderSettings :: RenderSettings defaultRenderSettings = RenderSettings 2 0 LeadingCommas render :: RenderSettings -> Nesting -> Element -> [String] render settings nesting (Stanza name elements) = indent settings nesting name : renderElements settings (succ nesting) elements render settings nesting (Group a b) = render settings nesting a ++ render settings nesting b render settings nesting (Field name value) = renderField settings nesting name value render settings nesting (Verbatim str) = map (indent settings nesting) (lines str) renderElements :: RenderSettings -> Nesting -> [Element] -> [String] renderElements settings nesting = concatMap (render settings nesting) renderField :: RenderSettings -> Nesting -> String -> Value -> [String] renderField settings@RenderSettings{..} nesting name value = case renderValue settings value of SingleLine "" -> [] SingleLine x -> [indent settings nesting (name ++ ": " ++ padding ++ x)] MultipleLines [] -> [] MultipleLines xs -> (indent settings nesting name ++ ":") : map (indent settings $ succ nesting) xs where Alignment fieldAlignment = renderSettingsFieldAlignment padding = replicate (fieldAlignment - length name - 2) ' ' renderValue :: RenderSettings -> Value -> Lines renderValue RenderSettings{..} v = case v of Literal s -> SingleLine s WordList ws -> SingleLine $ unwords ws LineSeparatedList xs -> renderLineSeparatedList renderSettingsCommaStyle xs CommaSeparatedList xs -> renderCommaSeparatedList renderSettingsCommaStyle xs renderLineSeparatedList :: CommaStyle -> [String] -> Lines renderLineSeparatedList style = MultipleLines . map (padding ++) where padding = case style of LeadingCommas -> " " TrailingCommas -> "" renderCommaSeparatedList :: CommaStyle -> [String] -> Lines renderCommaSeparatedList style = MultipleLines . case style of LeadingCommas -> map renderLeadingComma . zip (True : repeat False) TrailingCommas -> map renderTrailingComma . reverse . zip (True : repeat False) . reverse where renderLeadingComma :: (Bool, String) -> String renderLeadingComma (isFirst, x) | isFirst = " " ++ x | otherwise = ", " ++ x renderTrailingComma :: (Bool, String) -> String renderTrailingComma (isLast, x) | isLast = x | otherwise = x ++ "," instance IsString Value where fromString = Literal indent :: RenderSettings -> Nesting -> String -> String indent RenderSettings{..} (Nesting nesting) s = replicate (nesting * renderSettingsIndentation) ' ' ++ s sortFieldsBy :: [String] -> [Element] -> [Element] sortFieldsBy existingFieldOrder = map snd . sortOn fst . addSortKey . map (\a -> (existingIndex a, a)) where existingIndex :: Element -> Maybe Int existingIndex (Field name _) = name `elemIndex` existingFieldOrder existingIndex _ = Nothing addSortKey :: [(Maybe Int, a)] -> [((Int, Int), a)] addSortKey = go (-1) . zip [0..] where go :: Int -> [(Int, (Maybe Int, a))] -> [((Int, Int), a)] go n xs = case xs of [] -> [] (x, (Just y, a)) : ys -> ((y, x), a) : go y ys (x, (Nothing, a)) : ys -> ((n, x), a) : go n ys hpack-0.34.2/src/Hpack/Syntax/0000755000000000000000000000000013665434154014172 5ustar0000000000000000hpack-0.34.2/src/Hpack/Syntax/Git.hs0000644000000000000000000000136013665434154015251 0ustar0000000000000000module Hpack.Syntax.Git ( isValidRef ) where import Data.Char (chr) import Data.List import System.FilePath.Posix -- https://git-scm.com/docs/git-check-ref-format isValidRef :: String -> Bool isValidRef ref = not (null ref) && not (any (isSuffixOf ".lock") components) && not (any (isPrefixOf ".") components) && not (".." `isInfixOf` ref) && not (any isControl ref) && all (`notElem` " ~^:?*[\\") ref && not ("//" `isInfixOf` ref) && not ("/" `isPrefixOf` ref) && not ("/" `isSuffixOf` ref) && not ("." `isSuffixOf` ref) && not ("@{" `isInfixOf` ref) && not (ref == "@") where components = splitDirectories ref isControl :: Char -> Bool isControl c = c < chr 0o040 || c == chr 0o177 hpack-0.34.2/src/Hpack/Syntax/DependencyVersion.hs0000644000000000000000000001321213665434154020151 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE LambdaCase #-} module Hpack.Syntax.DependencyVersion ( githubBaseUrl , GitRef , GitUrl , VersionConstraint(..) , versionConstraint , anyVersion , versionRange , DependencyVersion(..) , withDependencyVersion , dependencyVersion , SourceDependency(..) , objectDependency , versionConstraintFromCabal , scientificToVersion , cabalParse ) where import Control.Applicative import qualified Control.Monad.Fail as Fail import Data.Maybe import Data.Scientific import Data.Text (Text) import qualified Data.Text as T import qualified Data.HashMap.Strict as HashMap import Text.PrettyPrint (renderStyle, Style(..), Mode(..)) import Distribution.Version (VersionRangeF(..)) import qualified Distribution.Version as D import qualified Distribution.Parsec as D import qualified Distribution.Pretty as D import Data.Aeson.Config.FromValue githubBaseUrl :: String githubBaseUrl = "https://github.com/" type GitUrl = String type GitRef = String data VersionConstraint = AnyVersion | VersionRange String deriving (Eq, Show) instance FromValue VersionConstraint where fromValue = versionConstraint versionConstraint :: Value -> Parser VersionConstraint versionConstraint v = case v of Null -> return AnyVersion Number n -> return (numericVersionConstraint n) String s -> stringVersionConstraint s _ -> typeMismatch "Null, Number, or String" v anyVersion :: DependencyVersion anyVersion = DependencyVersion Nothing AnyVersion versionRange :: String -> DependencyVersion versionRange = DependencyVersion Nothing . VersionRange data DependencyVersion = DependencyVersion (Maybe SourceDependency) VersionConstraint deriving (Eq, Show) withDependencyVersion :: (DependencyVersion -> a) -> (Object -> DependencyVersion -> Parser a) -> Value -> Parser a withDependencyVersion k obj v = case v of Null -> return $ k anyVersion Object o -> objectDependency o >>= obj o Number n -> return $ k (DependencyVersion Nothing $ numericVersionConstraint n) String s -> k . DependencyVersion Nothing <$> stringVersionConstraint s _ -> typeMismatch "Null, Object, Number, or String" v dependencyVersion :: Value -> Parser DependencyVersion dependencyVersion = withDependencyVersion id (const return) data SourceDependency = GitRef GitUrl GitRef (Maybe FilePath) | Local FilePath deriving (Eq, Show) objectDependency :: Object -> Parser DependencyVersion objectDependency o = let version :: Parser VersionConstraint version = fromMaybe AnyVersion <$> (o .:? "version") local :: Parser SourceDependency local = Local <$> o .: "path" git :: Parser SourceDependency git = GitRef <$> url <*> ref <*> subdir url :: Parser String url = ((githubBaseUrl ++) <$> o .: "github") <|> (o .: "git") <|> fail "neither key \"git\" nor key \"github\" present" ref :: Parser String ref = o .: "ref" subdir :: Parser (Maybe FilePath) subdir = o .:? "subdir" source :: Parser (Maybe SourceDependency) source | any (`HashMap.member` o) ["path", "git", "github", "ref", "subdir"] = Just <$> (local <|> git) | otherwise = return Nothing in DependencyVersion <$> source <*> version numericVersionConstraint :: Scientific -> VersionConstraint numericVersionConstraint n = VersionRange ("==" ++ version) where version = scientificToVersion n stringVersionConstraint :: Text -> Parser VersionConstraint stringVersionConstraint s = parseVersionRange ("== " ++ input) <|> parseVersionRange input where input = T.unpack s scientificToVersion :: Scientific -> String scientificToVersion n = version where version = formatScientific Fixed (Just decimalPlaces) n decimalPlaces | e < 0 = abs e | otherwise = 0 e = base10Exponent n parseVersionRange :: Fail.MonadFail m => String -> m VersionConstraint parseVersionRange = fmap versionConstraintFromCabal . parseCabalVersionRange parseCabalVersionRange :: Fail.MonadFail m => String -> m D.VersionRange parseCabalVersionRange = cabalParse "constraint" cabalParse :: (Fail.MonadFail m, D.Parsec a) => String -> String -> m a cabalParse subject s = case D.eitherParsec s of Right d -> return d Left _ ->fail $ unwords ["invalid", subject, show s] versionConstraintFromCabal :: D.VersionRange -> VersionConstraint versionConstraintFromCabal range | D.isAnyVersion range = AnyVersion | otherwise = VersionRange . renderStyle style . D.pretty $ toPreCabal2VersionRange range where style = Style OneLineMode 0 0 toPreCabal2VersionRange :: D.VersionRange -> D.VersionRange toPreCabal2VersionRange = D.embedVersionRange . D.cataVersionRange f where f :: VersionRangeF (VersionRangeF D.VersionRange) -> VersionRangeF D.VersionRange f = \ case MajorBoundVersionF v -> IntersectVersionRangesF (D.embedVersionRange lower) (D.embedVersionRange upper) where lower = OrLaterVersionF v upper = EarlierVersionF (D.majorUpperBound v) AnyVersionF -> AnyVersionF ThisVersionF v -> ThisVersionF v LaterVersionF v -> LaterVersionF v OrLaterVersionF v -> OrLaterVersionF v EarlierVersionF v -> EarlierVersionF v OrEarlierVersionF v -> OrEarlierVersionF v WildcardVersionF v -> WildcardVersionF v UnionVersionRangesF a b -> UnionVersionRangesF (D.embedVersionRange a) (D.embedVersionRange b) IntersectVersionRangesF a b -> IntersectVersionRangesF (D.embedVersionRange a) (D.embedVersionRange b) VersionRangeParensF a -> VersionRangeParensF (D.embedVersionRange a) hpack-0.34.2/src/Hpack/Syntax/ParseDependencies.hs0000644000000000000000000000205313665434154020107 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} module Hpack.Syntax.ParseDependencies where import Data.Text (Text) import Data.Bifunctor import Data.Aeson.Config.FromValue data Parse k v = Parse { parseString :: Text -> Parser (k, v) , parseListItem :: Object -> Parser v , parseDictItem :: Value -> Parser v , parseName :: Text -> k } parseDependencies :: Parse k v -> Value -> Parser [(k, v)] parseDependencies parse@Parse{..} v = case v of String s -> return <$> parseString s Array xs -> parseArray (buildToolFromValue parse) xs Object o -> map (first parseName) <$> traverseObject parseDictItem o _ -> typeMismatch "Array, Object, or String" v buildToolFromValue :: Parse k v -> Value -> Parser (k, v) buildToolFromValue Parse{..} v = case v of String s -> parseString s Object o -> sourceDependency o _ -> typeMismatch "Object or String" v where sourceDependency o = (,) <$> (parseName <$> name) <*> parseListItem o where name :: Parser Text name = o .: "name" hpack-0.34.2/src/Hpack/Syntax/Dependencies.hs0000644000000000000000000000541013665434154017114 0ustar0000000000000000{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} module Hpack.Syntax.Dependencies ( Dependencies(..) , DependencyInfo(..) , parseDependency ) where import qualified Control.Monad.Fail as Fail import Data.Text (Text) import Data.List import qualified Data.Text as T import Data.Semigroup (Semigroup(..)) import qualified Distribution.Package as D import qualified Distribution.Types.LibraryName as D import Distribution.Pretty (prettyShow) import Data.Map.Lazy (Map) import qualified Data.Map.Lazy as Map import GHC.Exts import Data.Aeson.Config.FromValue import Data.Aeson.Config.Types import Hpack.Syntax.DependencyVersion import Hpack.Syntax.ParseDependencies newtype Dependencies = Dependencies { unDependencies :: Map String DependencyInfo } deriving (Eq, Show, Semigroup, Monoid) instance IsList Dependencies where type Item Dependencies = (String, DependencyInfo) fromList = Dependencies . Map.fromList toList = Map.toList . unDependencies instance FromValue Dependencies where fromValue = fmap (Dependencies . Map.fromList) . parseDependencies parse where parse :: Parse String DependencyInfo parse = Parse { parseString = \ input -> do (name, version) <- parseDependency "dependency" input return (name, DependencyInfo [] version) , parseListItem = objectDependencyInfo , parseDictItem = dependencyInfo , parseName = T.unpack } data DependencyInfo = DependencyInfo { dependencyInfoMixins :: [String] , dependencyInfoVersion :: DependencyVersion } deriving (Eq, Show) addMixins :: Object -> DependencyVersion -> Parser DependencyInfo addMixins o version = do mixinsMay <- o .:? "mixin" return $ DependencyInfo (fromMaybeList mixinsMay) version objectDependencyInfo :: Object -> Parser DependencyInfo objectDependencyInfo o = objectDependency o >>= addMixins o dependencyInfo :: Value -> Parser DependencyInfo dependencyInfo = withDependencyVersion (DependencyInfo []) addMixins parseDependency :: Fail.MonadFail m => String -> Text -> m (String, DependencyVersion) parseDependency subject = fmap fromCabal . cabalParse subject . T.unpack where fromCabal :: D.Dependency -> (String, DependencyVersion) fromCabal d = (toName (D.depPkgName d) (toList $ D.depLibraries d), DependencyVersion Nothing . versionConstraintFromCabal $ D.depVerRange d) toName :: D.PackageName -> [D.LibraryName] -> String toName package components = prettyShow package <> case components of [D.LMainLibName] -> "" [D.LSubLibName lib] -> ":" <> prettyShow lib xs -> ":{" <> (intercalate "," $ map prettyShow [name | D.LSubLibName name <- xs]) <> "}" hpack-0.34.2/src/Hpack/Syntax/Defaults.hs0000644000000000000000000000761313665434154016304 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} module Hpack.Syntax.Defaults ( Defaults(..) , Github(..) , Local(..) #ifdef TEST , isValidOwner , isValidRepo #endif ) where import Data.HashMap.Lazy (member) import Data.List import qualified Data.Text as T import System.FilePath.Posix (splitDirectories) import Data.Aeson.Config.FromValue import Hpack.Syntax.Git data ParseGithub = ParseGithub { parseGithubGithub :: GithubRepo , parseGithubRef :: Ref , parseGithubPath :: Maybe Path } deriving (Generic, FromValue) data GithubRepo = GithubRepo { githubRepoOwner :: String , githubRepoName :: String } instance FromValue GithubRepo where fromValue = withString parseGithub parseGithub :: String -> Parser GithubRepo parseGithub github | not (isValidOwner owner) = fail ("invalid owner name " ++ show owner) | not (isValidRepo repo) = fail ("invalid repository name " ++ show repo) | otherwise = return (GithubRepo owner repo) where (owner, repo) = drop 1 <$> break (== '/') github isValidOwner :: String -> Bool isValidOwner owner = not (null owner) && all isAlphaNumOrHyphen owner && doesNotHaveConsecutiveHyphens owner && doesNotBeginWithHyphen owner && doesNotEndWithHyphen owner where isAlphaNumOrHyphen = (`elem` '-' : alphaNum) doesNotHaveConsecutiveHyphens = not . isInfixOf "--" doesNotBeginWithHyphen = not . isPrefixOf "-" doesNotEndWithHyphen = not . isSuffixOf "-" isValidRepo :: String -> Bool isValidRepo repo = not (null repo) && repo `notElem` [".", ".."] && all isValid repo where isValid = (`elem` '_' : '.' : '-' : alphaNum) alphaNum :: [Char] alphaNum = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] data Ref = Ref {unRef :: String} instance FromValue Ref where fromValue = withString parseRef parseRef :: String -> Parser Ref parseRef ref | isValidRef ref = return (Ref ref) | otherwise = fail ("invalid Git reference " ++ show ref) data Path = Path {unPath :: [FilePath]} instance FromValue Path where fromValue = withString parsePath parsePath :: String -> Parser Path parsePath path | '\\' `elem` path = fail ("rejecting '\\' in " ++ show path ++ ", please use '/' to separate path components") | ':' `elem` path = fail ("rejecting ':' in " ++ show path) | "/" `elem` p = fail ("rejecting absolute path " ++ show path) | ".." `elem` p = fail ("rejecting \"..\" in " ++ show path) | otherwise = return (Path p) where p = splitDirectories path data Github = Github { githubOwner :: String , githubRepo :: String , githubRef :: String , githubPath :: [FilePath] } deriving (Eq, Show) toDefaultsGithub :: ParseGithub -> Github toDefaultsGithub ParseGithub{..} = Github { githubOwner = githubRepoOwner parseGithubGithub , githubRepo = githubRepoName parseGithubGithub , githubRef = unRef parseGithubRef , githubPath = maybe [".hpack", "defaults.yaml"] unPath parseGithubPath } parseDefaultsGithubFromString :: String -> Parser ParseGithub parseDefaultsGithubFromString xs = case break (== '@') xs of (github, '@' : ref) -> ParseGithub <$> parseGithub github <*> parseRef ref <*> pure Nothing _ -> fail ("missing Git reference for " ++ show xs ++ ", the expected format is owner/repo@ref") data Local = Local { localLocal :: String } deriving (Eq, Show, Generic, FromValue) data Defaults = DefaultsLocal Local | DefaultsGithub Github deriving (Eq, Show) instance FromValue Defaults where fromValue v = case v of String s -> DefaultsGithub . toDefaultsGithub <$> parseDefaultsGithubFromString (T.unpack s) Object o | "local" `member` o -> DefaultsLocal <$> fromValue v Object o | "github" `member` o -> DefaultsGithub . toDefaultsGithub <$> fromValue v Object _ -> fail "neither key \"github\" nor key \"local\" present" _ -> typeMismatch "Object or String" v hpack-0.34.2/src/Hpack/Syntax/BuildTools.hs0000644000000000000000000000675113665434154016617 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ViewPatterns #-} module Hpack.Syntax.BuildTools ( BuildTools(..) , ParseBuildTool(..) , SystemBuildTools(..) ) where import qualified Control.Monad.Fail as Fail import Data.Text (Text) import qualified Data.Text as T import Data.Semigroup (Semigroup(..)) import Data.Bifunctor import Control.Applicative import qualified Distribution.Package as D import Data.Map.Lazy (Map) import qualified Data.Map.Lazy as Map import qualified Distribution.Types.ExeDependency as D import qualified Distribution.Types.UnqualComponentName as D import qualified Distribution.Types.LegacyExeDependency as D import Data.Aeson.Config.FromValue import Hpack.Syntax.DependencyVersion import Hpack.Syntax.Dependencies (parseDependency) import Hpack.Syntax.ParseDependencies data ParseBuildTool = QualifiedBuildTool String String | UnqualifiedBuildTool String deriving (Show, Eq) newtype BuildTools = BuildTools { unBuildTools :: [(ParseBuildTool, DependencyVersion)] } deriving (Show, Eq, Semigroup, Monoid) instance FromValue BuildTools where fromValue = fmap BuildTools . parseDependencies parse where parse :: Parse ParseBuildTool DependencyVersion parse = Parse { parseString = buildToolFromString , parseListItem = objectDependency , parseDictItem = dependencyVersion , parseName = nameToBuildTool } nameToBuildTool :: Text -> ParseBuildTool nameToBuildTool (T.unpack -> name) = case break (== ':') name of (executable, "") -> UnqualifiedBuildTool executable (package, executable) -> QualifiedBuildTool package (drop 1 executable) buildToolFromString :: Text -> Parser (ParseBuildTool, DependencyVersion) buildToolFromString s = parseQualifiedBuildTool s <|> parseUnqualifiedBuildTool s parseQualifiedBuildTool :: Fail.MonadFail m => Text -> m (ParseBuildTool, DependencyVersion) parseQualifiedBuildTool = fmap fromCabal . cabalParse "build tool" . T.unpack where fromCabal :: D.ExeDependency -> (ParseBuildTool, DependencyVersion) fromCabal (D.ExeDependency package executable version) = ( QualifiedBuildTool (D.unPackageName package) (D.unUnqualComponentName executable) , DependencyVersion Nothing $ versionConstraintFromCabal version ) parseUnqualifiedBuildTool :: Fail.MonadFail m => Text -> m (ParseBuildTool, DependencyVersion) parseUnqualifiedBuildTool = fmap (first UnqualifiedBuildTool) . parseDependency "build tool" newtype SystemBuildTools = SystemBuildTools { unSystemBuildTools :: Map String VersionConstraint } deriving (Show, Eq, Semigroup, Monoid) instance FromValue SystemBuildTools where fromValue = fmap (SystemBuildTools . Map.fromList) . parseDependencies parse where parse :: Parse String VersionConstraint parse = Parse { parseString = parseSystemBuildTool , parseListItem = (.: "version") , parseDictItem = versionConstraint , parseName = T.unpack } parseSystemBuildTool :: Fail.MonadFail m => Text -> m (String, VersionConstraint) parseSystemBuildTool = fmap fromCabal . cabalParse "system build tool" . T.unpack where fromCabal :: D.LegacyExeDependency -> (String, VersionConstraint) fromCabal (D.LegacyExeDependency name version) = (name, versionConstraintFromCabal version)