hpack 0.31.2 → 0.39.6
raw patch · 53 files changed
Files
- CHANGELOG.md +141/−0
- LICENSE +1/−1
- driver/Main.hs +14/−2
- hpack.cabal +99/−69
- resources/test/hpack.cabal +231/−0
- src/Data/Aeson/Config/FromValue.hs +65/−19
- src/Data/Aeson/Config/Key.hs +24/−0
- src/Data/Aeson/Config/KeyMap.hs +8/−0
- src/Data/Aeson/Config/Parser.hs +37/−19
- src/Data/Aeson/Config/Types.hs +2/−2
- src/Hpack.hs +157/−50
- src/Hpack/CabalFile.hs +44/−17
- src/Hpack/Config.hs +570/−313
- src/Hpack/Defaults.hs +10/−15
- src/Hpack/Error.hs +59/−0
- src/Hpack/Haskell.hs +4/−3
- src/Hpack/License.hs +3/−2
- src/Hpack/Module.hs +113/−0
- src/Hpack/Options.hs +27/−3
- src/Hpack/Render.hs +179/−155
- src/Hpack/Render/Dsl.hs +70/−21
- src/Hpack/Render/Hints.hs +51/−16
- src/Hpack/Syntax/BuildTools.hs +6/−7
- src/Hpack/Syntax/Defaults.hs +3/−2
- src/Hpack/Syntax/Dependencies.hs +26/−5
- src/Hpack/Syntax/DependencyVersion.hs +50/−30
- src/Hpack/Syntax/Git.hs +2/−1
- src/Hpack/Syntax/ParseDependencies.hs +4/−3
- src/Hpack/Utf8.hs +12/−3
- src/Hpack/Util.hs +26/−39
- src/Hpack/Yaml.hs +22/−13
- src/Imports.hs +18/−0
- src/Path.hs +26/−0
- test/Data/Aeson/Config/FromValueSpec.hs +162/−7
- test/Data/Aeson/Config/TypesSpec.hs +1/−1
- test/EndToEndSpec.hs +2251/−1627
- test/Helper.hs +15/−1
- test/Hpack/CabalFileSpec.hs +10/−4
- test/Hpack/ConfigSpec.hs +21/−28
- test/Hpack/DefaultsSpec.hs +2/−3
- test/Hpack/LicenseSpec.hs +2/−1
- test/Hpack/ModuleSpec.hs +58/−0
- test/Hpack/OptionsSpec.hs +18/−6
- test/Hpack/Render/DslSpec.hs +77/−5
- test/Hpack/Render/HintsSpec.hs +35/−7
- test/Hpack/RenderSpec.hs +25/−61
- test/Hpack/Syntax/DefaultsSpec.hs +1/−1
- test/Hpack/Syntax/DependenciesSpec.hs +21/−7
- test/Hpack/Syntax/GitSpec.hs +1/−1
- test/Hpack/Utf8Spec.hs +2/−2
- test/Hpack/UtilSpec.hs +0/−35
- test/HpackSpec.hs +150/−72
- test/SpecHook.hs +8/−0
CHANGELOG.md view
@@ -1,3 +1,144 @@+## Changes in 0.39.6+ - Add support for top-level field `codeberg`++## Changes in 0.39.5+ - When rendering build dependencies in a Cabal file, Hpack no longer excludes+ the reference to the main library from the shorthand syntax such as+ `my-package:{my-package,my-library1,mylibrary2}`.++## Changes in 0.39.4+ - Remove upper on `crypton`++## Changes in 0.39.3+ - Add upper bound `crypton < 1.1`, as dependency `http-client-tls <= 0.3.6.4`+ does not support `crypton-1.1.0` but does not itself have an upper bound.++## Changes in 0.39.2+ - Depend on `cryptohash-sha256`, rather than `crypton`, for SHA256 hashes++## Changes in 0.39.1+ - Add support for `mhs-options` (MicroHs)++## Changes in 0.39.0+ - Handle multi-line values for the `description` field of `flags` (see #623) and other fields++## Changes in 0.38.3+ - Accept a list for `category` (see #624)++## Changes in 0.38.2+ - Infer `cabal-version: 3.12` when `PackageInfo_*` is used (see #620)++## Changes in 0.38.1+ - Add support for `extra-files` (see #603)+ - Preserve empty lines in `description` when `cabal-version >= 3` (see #612)++## Changes in 0.38.0+ - Generate `build-tool-depends` instead of `build-tools` starting with+ `cabal-version: 2` (fixes #596)++## Changes in 0.37.0+ - Add support for `asm-options` and `asm-sources` (see #573)++## Changes in 0.36.1+ - Allow `Cabal-3.12.*`+ - Support `base >= 4.20.0` (`Imports` does not re-export `Data.List.List`)++## Changes in 0.36.0+ - Don't infer `Paths_`-module with `spec-version: 0.36.0` or later++## Changes in 0.35.5+ - Add (undocumented) `list` command++## Changes in 0.35.4+ - Add `--canonical`, which can be used to produce canonical output instead of+ trying to produce minimal diffs+ - Avoid unnecessary writes on `--force` (see #555)+ - When an existing `.cabal` does not align fields then do not align fields in+ the generated `.cabal` file.+ - Fix a bug related to git conflict markers in existing `.cabal` files: When a+ `.cabal` file was essentially unchanged, but contained git conflict markers+ then `hpack` did not write a new `.cabal` file at all. To address this+ `hpack` now unconditionally writes a new `.cabal` file when the existing+ `.cabal` file contains any git conflict markers.++## Changes in 0.35.3+ - Depend on `crypton` instead of `cryptonite`++## Changes in 0.35.2+ - Add support for `ghc-shared-options`++## Changes in 0.35.1+ - Allow `Cabal-3.8.*`+ - Additions to internal API++## Changes in 0.35.0+ - Add support for `language` (thanks @mpilgrem)+ - Accept Cabal names for fields where Hpack and Cabal use different+ terminology, but still warn (e.g. accept `hs-source-dirs` as an alias for+ `source-dirs`)++## Changes in 0.34.7+ - Support `Cabal-3.6.*`+ - Make sure that verbatim `import` fields are rendered at the beginning of+ a section (see #486)++## Changes in 0.34.6+ - Add `Paths_` module to `autogen-modules` when `cabal-version >= 2`++## Changes in 0.34.5+ - Compatibility with `aeson-2.*`++## Changes in 0.34.4+ - Render `default-extensions` / `other-extensions` line-separated+ - Compatibility with `Cabal-3.4.0.0`++## Changes in 0.34.3+ - Ignore duplicate source directories (see #356)+ - Do not infer duplicate modules (see #408, #406, #353)+ - Reject empty `then` / `else` sections (see #362)+ - Omit conditionals that are always `false` from generated `.cabal` file+ (see #404)+ - Infer correct `cabal-version` when `Paths_` is used with `RebindableSyntax`+ and `OverloadedStrings` or `OverloadedLists` (see #400)+ - Do not use indentation from any existing `.cabal` file if it is invalid+ (e.g. `0`) (fixes #252)+ - Accept lists for `tested-with` (see #407)+ - Render current directory as `./` instead of `./.` for forward compatibility+ with future version of Cabal++## 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
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2014-2018 Simon Hengel <sol@typeful.net>+Copyright (c) 2014-2026 Simon Hengel <sol@typeful.net> Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal
driver/Main.hs view
@@ -1,9 +1,21 @@+{-# LANGUAGE LambdaCase #-} module Main (main) where import System.Environment import qualified Hpack-import qualified Hpack.Config as Hpack+import Hpack.Config+import Control.Exception main :: IO ()-main = getArgs >>= Hpack.getOptions Hpack.packageConfig >>= mapM_ (uncurry Hpack.hpack)+main = getArgs >>= \ case+ ["list"] -> exposedModules packageConfig >>= mapM_ (putStrLn . unModule)+ args -> Hpack.getOptions packageConfig args >>= mapM_ (uncurry Hpack.hpack)++exposedModules :: FilePath -> IO [Module]+exposedModules file = readPackageConfig defaultDecodeOptions {decodeOptionsTarget = file} >>= \ case+ Left err -> throwIO $ ErrorCall err+ Right result -> return $ modules result+ where+ modules :: DecodeResult -> [Module]+ modules = maybe [] (libraryExposedModules . sectionData) . packageLibrary . decodeResultPackage
hpack.cabal view
@@ -1,23 +1,24 @@-cabal-version: 1.12+cabal-version: 2.0 --- This file has been generated from package.yaml by hpack version 0.31.0.+-- This file has been generated from package.yaml by hpack version 0.39.1. -- -- see: https://github.com/sol/hpack------ hash: 3d060180293c32b8d0c25b710d0f419e96a6cc6ec3f95ac5e70bb77f44cbafc3 name: hpack-version: 0.31.2+version: 0.39.6 synopsis: A modern format for Haskell packages-description: See README at <https://github.com/sol/hpack#readme>+description: See the README at <https://github.com/sol/hpack#readme> category: Development homepage: https://github.com/sol/hpack#readme bug-reports: https://github.com/sol/hpack/issues+author: Simon Hengel <sol@typeful.net> maintainer: Simon Hengel <sol@typeful.net> license: MIT license-file: LICENSE build-type: Simple extra-source-files:+ resources/test/hpack.cabal+extra-doc-files: CHANGELOG.md source-repository head@@ -25,39 +26,16 @@ location: https://github.com/sol/hpack library- hs-source-dirs:- src- ghc-options: -Wall- build-depends:- Cabal >=2.2- , Glob >=0.9.0- , aeson >=1.2.1.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+ Hpack.Error other-modules: Data.Aeson.Config.FromValue+ Data.Aeson.Config.Key+ Data.Aeson.Config.KeyMap Data.Aeson.Config.Parser Data.Aeson.Config.Types Data.Aeson.Config.Util@@ -65,6 +43,7 @@ Hpack.Defaults Hpack.Haskell Hpack.License+ Hpack.Module Hpack.Options Hpack.Render.Dsl Hpack.Render.Hints@@ -76,31 +55,31 @@ Hpack.Syntax.ParseDependencies Hpack.Utf8 Hpack.Util+ Imports+ Path Paths_hpack- default-language: Haskell2010--executable hpack- main-is: Main.hs+ autogen-modules:+ Paths_hpack hs-source-dirs:- driver- ghc-options: -Wall+ src+ ghc-options: -Wall -fno-warn-incomplete-uni-patterns build-depends:- Cabal >=2.2+ Cabal >=3.0.0.0 && <3.17 , Glob >=0.9.0- , aeson >=1.2.1.0- , base >=4.9 && <5+ , aeson >=1.4.3.0+ , base >=4.13 && <5 , bifunctors , bytestring , containers- , cryptonite+ , cryptohash-sha256 , deepseq- , directory+ , directory >=1.2.5.0 , filepath- , hpack , http-client- , http-client-tls+ , http-client-tls >=0.3.6.2 , http-types , infer-license >=0.2.0 && <0.3+ , mtl , pretty , scientific , text@@ -108,50 +87,49 @@ , unordered-containers , vector , yaml >=0.10.0- other-modules:- Paths_hpack default-language: Haskell2010+ if impl(ghc >= 9.4.5) && os(windows)+ build-depends:+ network >=3.1.2.9 -test-suite spec- type: exitcode-stdio-1.0- main-is: Spec.hs+executable hpack+ main-is: Main.hs hs-source-dirs:- test- src- ghc-options: -Wall- cpp-options: -DTEST+ driver+ ghc-options: -Wall -fno-warn-incomplete-uni-patterns build-depends:- Cabal >=2.2+ Cabal >=3.0.0.0 && <3.17 , Glob >=0.9.0- , HUnit >=1.6.0.0- , QuickCheck- , aeson >=1.2.1.0- , base >=4.9 && <5+ , aeson >=1.4.3.0+ , base >=4.13 && <5 , bifunctors , bytestring , containers- , cryptonite+ , cryptohash-sha256 , deepseq- , directory+ , directory >=1.2.5.0 , filepath- , hspec ==2.*+ , hpack , http-client- , http-client-tls+ , http-client-tls >=0.3.6.2 , http-types , infer-license >=0.2.0 && <0.3- , interpolate- , mockery >=0.3+ , mtl , pretty , scientific- , template-haskell- , temporary , text , transformers , unordered-containers , vector , yaml >=0.10.0- build-tool-depends:- hspec-discover:hspec-discover+ default-language: Haskell2010+ if impl(ghc >= 9.4.5) && os(windows)+ build-depends:+ network >=3.1.2.9++test-suite spec+ type: exitcode-stdio-1.0+ main-is: Spec.hs other-modules: Data.Aeson.Config.FromValueSpec Data.Aeson.Config.TypesSpec@@ -163,6 +141,7 @@ Hpack.DefaultsSpec Hpack.HaskellSpec Hpack.LicenseSpec+ Hpack.ModuleSpec Hpack.OptionsSpec Hpack.Render.DslSpec Hpack.Render.HintsSpec@@ -174,7 +153,10 @@ Hpack.Utf8Spec Hpack.UtilSpec HpackSpec+ SpecHook Data.Aeson.Config.FromValue+ Data.Aeson.Config.Key+ Data.Aeson.Config.KeyMap Data.Aeson.Config.Parser Data.Aeson.Config.Types Data.Aeson.Config.Util@@ -182,8 +164,10 @@ Hpack.CabalFile Hpack.Config Hpack.Defaults+ Hpack.Error Hpack.Haskell Hpack.License+ Hpack.Module Hpack.Options Hpack.Render Hpack.Render.Dsl@@ -197,5 +181,51 @@ Hpack.Utf8 Hpack.Util Hpack.Yaml+ Imports+ Path Paths_hpack+ autogen-modules:+ Paths_hpack+ hs-source-dirs:+ test+ src+ ghc-options: -Wall -fno-warn-incomplete-uni-patterns+ cpp-options: -DTEST+ build-tool-depends:+ hspec-discover:hspec-discover+ build-depends:+ Cabal >=3.0.0.0 && <3.17+ , Glob >=0.9.0+ , HUnit >=1.6.0.0+ , QuickCheck+ , aeson >=1.4.3.0+ , base >=4.13 && <5+ , bifunctors+ , bytestring+ , containers+ , cryptohash-sha256+ , deepseq+ , directory >=1.2.5.0+ , filepath+ , hspec ==2.*+ , http-client+ , http-client-tls >=0.3.6.2+ , http-types+ , infer-license >=0.2.0 && <0.3+ , interpolate+ , mockery >=0.3+ , mtl+ , pretty+ , scientific+ , template-haskell+ , temporary+ , text+ , transformers+ , unordered-containers+ , vcr+ , vector+ , yaml >=0.10.0 default-language: Haskell2010+ if impl(ghc >= 9.4.5) && os(windows)+ build-depends:+ network >=3.1.2.9
+ resources/test/hpack.cabal view
@@ -0,0 +1,231 @@+cabal-version: 2.0++-- This file has been generated from package.yaml by hpack version 0.39.1.+--+-- see: https://github.com/sol/hpack++name: hpack+version: 0.39.6+synopsis: A modern format for Haskell packages+description: See the README at <https://github.com/sol/hpack#readme>+category: Development+homepage: https://github.com/sol/hpack#readme+bug-reports: https://github.com/sol/hpack/issues+author: Simon Hengel <sol@typeful.net>+maintainer: Simon Hengel <sol@typeful.net>+license: MIT+license-file: LICENSE+build-type: Simple+extra-source-files:+ resources/test/hpack.cabal+extra-doc-files:+ CHANGELOG.md++source-repository head+ type: git+ location: https://github.com/sol/hpack++library+ exposed-modules:+ Hpack+ Hpack.Config+ Hpack.Render+ Hpack.Yaml+ Hpack.Error+ other-modules:+ Data.Aeson.Config.FromValue+ Data.Aeson.Config.Key+ Data.Aeson.Config.KeyMap+ Data.Aeson.Config.Parser+ Data.Aeson.Config.Types+ Data.Aeson.Config.Util+ Hpack.CabalFile+ Hpack.Defaults+ Hpack.Haskell+ Hpack.License+ Hpack.Module+ 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+ Imports+ Path+ Paths_hpack+ autogen-modules:+ Paths_hpack+ hs-source-dirs:+ src+ ghc-options: -Wall -fno-warn-incomplete-uni-patterns+ build-depends:+ Cabal >=3.0.0.0 && <3.17+ , Glob >=0.9.0+ , aeson >=1.4.3.0+ , base >=4.13 && <5+ , bifunctors+ , bytestring+ , containers+ , cryptohash-sha256+ , deepseq+ , directory >=1.2.5.0+ , filepath+ , http-client+ , http-client-tls >=0.3.6.2+ , http-types+ , infer-license >=0.2.0 && <0.3+ , mtl+ , pretty+ , scientific+ , text+ , transformers+ , unordered-containers+ , vector+ , yaml >=0.10.0+ default-language: Haskell2010+ if impl(ghc >= 9.4.5) && os(windows)+ build-depends:+ network >=3.1.2.9++executable hpack+ main-is: Main.hs+ hs-source-dirs:+ driver+ ghc-options: -Wall -fno-warn-incomplete-uni-patterns+ build-depends:+ Cabal >=3.0.0.0 && <3.17+ , Glob >=0.9.0+ , aeson >=1.4.3.0+ , base >=4.13 && <5+ , bifunctors+ , bytestring+ , containers+ , cryptohash-sha256+ , deepseq+ , directory >=1.2.5.0+ , filepath+ , hpack+ , http-client+ , http-client-tls >=0.3.6.2+ , http-types+ , infer-license >=0.2.0 && <0.3+ , mtl+ , pretty+ , scientific+ , text+ , transformers+ , unordered-containers+ , vector+ , yaml >=0.10.0+ default-language: Haskell2010+ if impl(ghc >= 9.4.5) && os(windows)+ build-depends:+ network >=3.1.2.9++test-suite spec+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ 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.ModuleSpec+ 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+ SpecHook+ Data.Aeson.Config.FromValue+ Data.Aeson.Config.Key+ Data.Aeson.Config.KeyMap+ Data.Aeson.Config.Parser+ Data.Aeson.Config.Types+ Data.Aeson.Config.Util+ Hpack+ Hpack.CabalFile+ Hpack.Config+ Hpack.Defaults+ Hpack.Error+ Hpack.Haskell+ Hpack.License+ Hpack.Module+ 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+ Imports+ Path+ Paths_hpack+ autogen-modules:+ Paths_hpack+ hs-source-dirs:+ test+ src+ ghc-options: -Wall -fno-warn-incomplete-uni-patterns+ cpp-options: -DTEST+ build-tool-depends:+ hspec-discover:hspec-discover+ build-depends:+ Cabal >=3.0.0.0 && <3.17+ , Glob >=0.9.0+ , HUnit >=1.6.0.0+ , QuickCheck+ , aeson >=1.4.3.0+ , base >=4.13 && <5+ , bifunctors+ , bytestring+ , containers+ , cryptohash-sha256+ , deepseq+ , directory >=1.2.5.0+ , filepath+ , hspec ==2.*+ , http-client+ , http-client-tls >=0.3.6.2+ , http-types+ , infer-license >=0.2.0 && <0.3+ , interpolate+ , mockery >=0.3+ , mtl+ , pretty+ , scientific+ , template-haskell+ , temporary+ , text+ , transformers+ , unordered-containers+ , vcr+ , vector+ , yaml >=0.10.0+ default-language: Haskell2010+ if impl(ghc >= 9.4.5) && os(windows)+ build-depends:+ network >=3.1.2.9
src/Data/Aeson/Config/FromValue.hs view
@@ -6,8 +6,11 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE RecordWildCards #-}- {-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE DeriveFunctor #-} module Data.Aeson.Config.FromValue ( FromValue(..) , Parser@@ -34,37 +37,44 @@ , (.:) , (.:?) +, Key , Value(..) , Object , Array++, Alias(..)+, unAlias ) where -import GHC.Generics+import Imports -import Control.Monad-import Control.Applicative+import Data.Monoid (Last(..))+import GHC.Generics+import GHC.TypeLits+import Data.Proxy -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.Config.Key (Key)+import qualified Data.Aeson.Config.Key as Key+import Data.Aeson.Config.KeyMap (member)+import qualified Data.Aeson.Config.KeyMap as KeyMap+ import Data.Aeson.Types (FromJSON(..)) import Data.Aeson.Config.Util import Data.Aeson.Config.Parser -type Result a = Either String (a, [String])+type Result a = Either String (a, [String], [(String, String)]) decodeValue :: FromValue a => Value -> Result a decodeValue = runParser fromValue -(.:) :: FromValue a => Object -> Text -> Parser a+(.:) :: FromValue a => Object -> Key -> Parser a (.:) = explicitParseField fromValue -(.:?) :: FromValue a => Object -> Text -> Parser (Maybe a)+(.:?) :: FromValue a => Object -> Key -> Parser (Maybe a) (.:?) = explicitParseFieldMaybe fromValue class FromValue a where@@ -105,11 +115,11 @@ instance FromValue a => FromValue (Map String a) where fromValue = withObject $ \ o -> do xs <- traverseObject fromValue o- return $ Map.fromList (map (first T.unpack) xs)+ return $ Map.fromList (map (first Key.toString) xs) -traverseObject :: (Value -> Parser a) -> Object -> Parser [(Text, a)]+traverseObject :: (Value -> Parser a) -> Object -> Parser [(Key, a)] traverseObject f o = do- forM (HashMap.toList o) $ \ (name, value) ->+ forM (KeyMap.toList o) $ \ (name, value) -> (,) name <$> f value <?> Key name instance (FromValue a, FromValue b) => FromValue (a, b) where@@ -137,13 +147,49 @@ 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+type RecordField sel a = S1 sel (Rec0 a)++instance (Selector sel, FromValue a) => GenericDecode (RecordField sel a) where genericDecode = accessFieldWith (.:) -instance {-# OVERLAPPING #-} (Selector sel, FromValue a) => GenericDecode (S1 sel (Rec0 (Maybe a))) where+instance {-# OVERLAPPING #-} (Selector sel, FromValue a) => GenericDecode (RecordField sel (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+instance {-# OVERLAPPING #-} (Selector sel, FromValue a) => GenericDecode (RecordField sel (Last a)) where+ genericDecode = accessFieldWith (\ value key -> Last <$> (value .:? key))++instance {-# OVERLAPPING #-} (Selector sel, FromValue a, KnownBool deprecated, KnownSymbol alias) => GenericDecode (RecordField sel (Alias deprecated alias (Maybe a))) where+ genericDecode = accessFieldWith (\ value key -> aliasAccess (.:?) value (Alias key))++instance {-# OVERLAPPING #-} (Selector sel, FromValue a, KnownBool deprecated, KnownSymbol alias) => GenericDecode (RecordField sel (Alias deprecated alias (Last a))) where+ genericDecode = accessFieldWith (\ value key -> fmap Last <$> aliasAccess (.:?) value (Alias key))++aliasAccess :: forall deprecated alias a. (KnownBool deprecated, KnownSymbol alias) => (Object -> Key -> Parser a) -> Object -> (Alias deprecated alias Key) -> Parser (Alias deprecated alias a)+aliasAccess op value (Alias key)+ | alias `member` value && not (key `member` value) = Alias <$> value `op` alias <* deprecated+ | otherwise = Alias <$> value `op` key where- label = optionsRecordSelectorModifier $ selName (undefined :: S1 sel (Rec0 a) p)+ deprecated = case boolVal (Proxy @deprecated) of+ False -> return ()+ True -> markDeprecated alias key+ alias = Key.fromString (symbolVal $ Proxy @alias)++accessFieldWith :: forall sel a p. Selector sel => (Object -> Key -> Parser a) -> Options -> Value -> Parser (RecordField sel a p)+accessFieldWith op Options{..} v = M1 . K1 <$> withObject (`op` Key.fromString label) v+ where+ label = optionsRecordSelectorModifier $ selName (undefined :: RecordField sel a p)++newtype Alias (deprecated :: Bool) (alias :: Symbol) a = Alias a+ deriving (Show, Eq, Semigroup, Monoid, Functor)++unAlias :: Alias deprecated alias a -> a+unAlias (Alias a) = a++class KnownBool (a :: Bool) where+ boolVal :: Proxy a -> Bool++instance KnownBool 'True where+ boolVal _ = True++instance KnownBool 'False where+ boolVal _ = False
+ src/Data/Aeson/Config/Key.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE CPP #-}+module Data.Aeson.Config.Key (module Data.Aeson.Config.Key) where++#if MIN_VERSION_aeson(2,0,0)++import Data.Aeson.Key as Data.Aeson.Config.Key++#else++import Data.Text (Text)+import qualified Data.Text as T++type Key = Text++toText :: Key -> Text+toText = id++toString :: Key -> String+toString = T.unpack++fromString :: String -> Key+fromString = T.pack++#endif
+ src/Data/Aeson/Config/KeyMap.hs view
@@ -0,0 +1,8 @@+{-# LANGUAGE CPP #-}+module Data.Aeson.Config.KeyMap (module KeyMap) where++#if MIN_VERSION_aeson(2,0,0)+import Data.Aeson.KeyMap as KeyMap+#else+import Data.HashMap.Strict as KeyMap+#endif
src/Data/Aeson/Config/Parser.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP #-} module Data.Aeson.Config.Parser ( Parser , runParser@@ -27,24 +28,33 @@ , fromAesonPath , formatPath++, markDeprecated ) where -import Control.Monad-import Control.Applicative+import Imports++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.Config.Key (Key)+import qualified Data.Aeson.Config.Key as Key+import qualified Data.Aeson.Config.KeyMap as KeyMap import Data.Aeson.Types (Value(..), Object, Array) import qualified Data.Aeson.Types as Aeson+#if MIN_VERSION_aeson(2,1,0)+import Data.Aeson.Types (IResult(..), iparse)+#else import Data.Aeson.Internal (IResult(..), iparse)+#endif+#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@@ -52,24 +62,27 @@ type JSONPath = [JSONPathElement] +data Path = Consumed JSONPath | Deprecated JSONPath JSONPath+ deriving (Eq, Ord, Show)+ fromAesonPath :: Aeson.JSONPath -> JSONPath fromAesonPath = reverse . map fromAesonPathElement fromAesonPathElement :: Aeson.JSONPathElement -> JSONPathElement fromAesonPathElement e = case e of- Aeson.Key k -> Key k+ Aeson.Key k -> Key (Key.toText k) Aeson.Index n -> Index n -newtype Parser a = Parser {unParser :: WriterT (Set JSONPath) Aeson.Parser a}- deriving (Functor, Applicative, Alternative, Monad)+newtype Parser a = Parser {unParser :: WriterT (Set Path) 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 :: (Value -> Parser a) -> Value -> Either String (a, [String], [(String, 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))+ ISuccess (a, paths) -> Right (a, map formatPath (determineUnconsumed paths v), [(formatPath name, formatPath substitute) | Deprecated name substitute <- Set.toList paths]) formatPath :: JSONPath -> String formatPath = go "$" . reverse@@ -80,19 +93,19 @@ 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 []+determineUnconsumed :: Set Path -> Value -> [JSONPath]+determineUnconsumed ((<> Set.singleton (Consumed [])) -> consumed) = Set.toList . execWriter . go [] where go :: JSONPath -> Value -> Writer (Set JSONPath) () go path value- | path `notMember` consumed = tell (Set.singleton path)+ | Consumed 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+ forM_ (KeyMap.toList o) $ \ (Key.toText -> k, v) -> do unless ("_" `T.isPrefixOf` k) $ do go (Key k : path) v Array xs -> do@@ -106,18 +119,23 @@ markConsumed :: JSONPathElement -> Parser () markConsumed e = do path <- getPath- Parser $ tell (Set.singleton $ e : path)+ Parser $ tell (Set.singleton . Consumed $ e : path) +markDeprecated :: Key -> Key -> Parser ()+markDeprecated (Key.toText -> name) (Key.toText -> substitute) = do+ path <- getPath+ Parser $ tell (Set.singleton $ Deprecated (Key name : path) (Key substitute : 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+explicitParseField :: (Value -> Parser a) -> Object -> Key -> Parser a+explicitParseField p o key = case KeyMap.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+explicitParseFieldMaybe :: (Value -> Parser a) -> Object -> Key -> Parser (Maybe a)+explicitParseFieldMaybe p o key = case KeyMap.lookup key o of Nothing -> pure Nothing Just v -> Just <$> p v <?> Aeson.Key key
src/Data/Aeson/Config/Types.hs view
@@ -4,10 +4,10 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Data.Aeson.Config.Types where -import Data.Semigroup (Semigroup(..))+import Imports+ import Data.Bitraversable import Data.Bifoldable-import Data.Bifunctor import Data.Aeson.Config.FromValue
src/Hpack.hs view
@@ -1,5 +1,7 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE LambdaCase #-} 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@@ -19,6 +21,7 @@ -- * Running Hpack , hpack , hpackResult+, hpackResultWithError , printResult , Result(..) , Status(..)@@ -28,18 +31,23 @@ , setProgramName , setTarget , setDecode+, setFormatYamlParseError , getOptions , Verbose(..) , Options(..) , Force(..)+, GenerateHashStrategy(..)+, OutputStrategy(..) #ifdef TEST , hpackResultWithVersion , header+, renderCabalFile #endif ) where -import Control.Monad+import Imports+ import Data.Version (Version) import qualified Data.Version as Version import System.FilePath@@ -47,40 +55,48 @@ 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.Error (HpackError, formatHpackError) import Hpack.Render import Hpack.Util import Hpack.Utf8 as Utf8 import Hpack.CabalFile+import qualified Data.Yaml as Yaml -programVersion :: Version -> String-programVersion v = "hpack version " ++ Version.showVersion v+programVersion :: Maybe Version -> String+programVersion Nothing = "hpack"+programVersion (Just v) = "hpack version " ++ Version.showVersion v -header :: FilePath -> Version -> Hash -> String-header p v hash = unlines [+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"- , "--"- , "-- hash: " ++ hash- , ""- ]+ ] ++ case hash of+ Just h -> ["--" , "-- hash: " ++ h, ""]+ Nothing -> [""] data Options = Options { optionsDecodeOptions :: DecodeOptions , optionsForce :: Force+, optionsGenerateHashStrategy :: GenerateHashStrategy , optionsToStdout :: Bool+, optionsOutputStrategy :: OutputStrategy } +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 version)+ putStrLn (programVersion $ Just version) return Nothing PrintNumericVersion -> do putStrLn (Version.showVersion version)@@ -88,9 +104,12 @@ Help -> do printHelp return Nothing- Run options -> case options of- ParseOptions verbose force toStdout file -> do- return $ Just (verbose, Options defaultDecodeOptions {decodeOptionsTarget = file} force toStdout)+ Run (ParseOptions verbose force hash toStdout file outputStrategy) -> do+ let generateHash = case hash of+ Just True -> ForceHash+ Just False -> ForceNoHash+ Nothing -> PreferNoHash+ return $ Just (verbose, Options defaultDecodeOptions {decodeOptionsTarget = file} force generateHash toStdout outputStrategy) ParseError -> do printHelp exitFailure@@ -99,7 +118,7 @@ printHelp = do name <- getProgName Utf8.hPutStrLn stderr $ unlines [- "Usage: " ++ name ++ " [ --silent ] [ --force | -f ] [ PATH ] [ - ]"+ "Usage: " ++ name ++ " [ --silent ] [ --canonical ] [ --force | -f ] [ --[no-]hash ] [ PATH ] [ - ]" , " " ++ name ++ " --version" , " " ++ name ++ " --numeric-version" , " " ++ name ++ " --help"@@ -109,7 +128,7 @@ hpack verbose options = hpackResult options >>= printResult verbose defaultOptions :: Options-defaultOptions = Options defaultDecodeOptions NoForce False+defaultOptions = Options defaultDecodeOptions NoForce PreferNoHash False MinimizeDiffs setTarget :: FilePath -> Options -> Options setTarget target options@Options{..} =@@ -123,6 +142,41 @@ setDecode decode options@Options{..} = options {optionsDecodeOptions = optionsDecodeOptions {decodeOptionsDecode = decode}} +-- | This is used to format any `Yaml.ParseException`s encountered during+-- decoding of <https://github.com/sol/hpack#defaults defaults>.+--+-- Note that:+--+-- 1. This is not used to format `Yaml.ParseException`s encountered during+-- decoding of the main @package.yaml@. To customize this you have to set a+-- custom decode function.+--+-- 2. Some of the constructors of `Yaml.ParseException` are never produced by+-- Hpack (e.g. `Yaml.AesonException` as Hpack uses it's own mechanism to decode+-- `Yaml.Value`s).+--+-- Example:+--+-- @+-- example :: IO (Either `HpackError` `Result`)+-- example = `hpackResultWithError` options+-- where+-- options :: `Options`+-- options = setCustomYamlParseErrorFormat format `defaultOptions`+--+-- format :: FilePath -> `Yaml.ParseException` -> String+-- format file err = file ++ ": " ++ displayException err+--+-- setCustomYamlParseErrorFormat :: (FilePath -> `Yaml.ParseException` -> String) -> `Options` -> `Options`+-- setCustomYamlParseErrorFormat format = `setDecode` decode >>> `setFormatYamlParseError` format+-- where+-- decode :: FilePath -> IO (Either String ([String], Value))+-- decode file = first (format file) \<$> `Hpack.Yaml.decodeYamlWithParseError` file+-- @+setFormatYamlParseError :: (FilePath -> Yaml.ParseException -> String) -> Options -> Options+setFormatYamlParseError formatYamlParseError options@Options{..} =+ options {optionsDecodeOptions = optionsDecodeOptions {decodeOptionsFormatYamlParseError = formatYamlParseError}}+ data Result = Result { resultWarnings :: [String] , resultCabalFile :: String@@ -154,41 +208,94 @@ printWarnings :: [String] -> IO () printWarnings = mapM_ $ Utf8.hPutStrLn stderr . ("WARNING: " ++) -mkStatus :: [String] -> Version -> CabalFile -> Status-mkStatus new v (CabalFile mOldVersion mHash old) = case (mOldVersion, mHash) of- (Nothing, _) -> ExistingCabalFileWasModifiedManually- (Just oldVersion, _) | oldVersion < makeVersion [0, 20, 0] -> Generated- (_, Nothing) -> ExistingCabalFileWasModifiedManually- (Just oldVersion, Just hash)- | old == new -> OutputUnchanged- | v < oldVersion -> AlreadyGeneratedByNewerHpack- | sha256 (unlines old) /= hash -> ExistingCabalFileWasModifiedManually- | otherwise -> Generated+mkStatus :: NewCabalFile -> ExistingCabalFile -> 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 :: NewCabalFile -> ExistingCabalFile -> Bool+hasSameContent (CabalFile cabalVersionA _ _ a ()) (CabalFile cabalVersionB _ _ b gitConflictMarkers) =+ cabalVersionA == cabalVersionB+ && a == b+ && gitConflictMarkers == DoesNotHaveGitConflictMarkers++hashMismatch :: ExistingCabalFile -> Bool+hashMismatch cabalFile = case cabalFileHash cabalFile of+ Nothing -> False+ Just hash -> cabalFileGitConflictMarkers cabalFile == HasGitConflictMarkers || hash /= calculateHash cabalFile++calculateHash :: CabalFile a -> Hash+calculateHash (CabalFile cabalVersion _ _ body _) = sha256 (unlines $ cabalVersion ++ body)+ hpackResult :: Options -> IO Result-hpackResult = hpackResultWithVersion version+hpackResult opts = hpackResultWithError opts >>= either (die . formatHpackError programName) return+ where+ programName = decodeOptionsProgramName (optionsDecodeOptions opts) -hpackResultWithVersion :: Version -> Options -> IO Result-hpackResultWithVersion v (Options options force toStdout) = do- DecodeResult pkg cabalVersion cabalFile warnings <- readPackageConfig options >>= either die return- oldCabalFile <- readCabalFile cabalFile- let- body = renderPackage (maybe [] cabalFileContents oldCabalFile) pkg- withoutHeader = cabalVersion ++ body- let- status = case force of- Force -> Generated- NoForce -> maybe Generated (mkStatus (lines withoutHeader) v) oldCabalFile- case status of- Generated -> do- let hash = sha256 withoutHeader- out = cabalVersion ++ header (decodeOptionsTarget options) v hash ++ body- if toStdout- then Utf8.putStr out- else Utf8.writeFile cabalFile out- _ -> return ()- return Result {- resultWarnings = warnings- , resultCabalFile = cabalFile- , resultStatus = status- }+hpackResultWithError :: Options -> IO (Either HpackError Result)+hpackResultWithError = hpackResultWithVersion version++hpackResultWithVersion :: Version -> Options -> IO (Either HpackError Result)+hpackResultWithVersion v (Options options force generateHashStrategy toStdout outputStrategy) = do+ readPackageConfigWithError options >>= \ case+ Right (DecodeResult pkg (lines -> cabalVersion) cabalFileName warnings) -> do+ mExistingCabalFile <- readCabalFile cabalFileName+ let+ newCabalFile = makeCabalFile outputStrategy 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 $ Right Result {+ resultWarnings = warnings+ , resultCabalFile = cabalFileName+ , resultStatus = status+ }+ Left err -> return $ Left err++writeCabalFile :: DecodeOptions -> Bool -> FilePath -> NewCabalFile -> IO ()+writeCabalFile options toStdout name cabalFile = do+ write . unlines $ renderCabalFile (decodeOptionsTarget options) cabalFile+ where+ write = if toStdout then Utf8.putStr else Utf8.ensureFile name++makeCabalFile :: OutputStrategy -> GenerateHashStrategy -> Maybe ExistingCabalFile -> [String] -> Version -> Package -> NewCabalFile+makeCabalFile outputStrategy generateHashStrategy mExistingCabalFile cabalVersion v pkg = cabalFile+ where+ hints :: [String]+ hints = case outputStrategy of+ CanonicalOutput -> []+ MinimizeDiffs -> maybe [] cabalFileContents mExistingCabalFile++ cabalFile :: NewCabalFile+ cabalFile = CabalFile cabalVersion (Just v) hash body ()++ hash :: Maybe Hash+ hash+ | shouldGenerateHash mExistingCabalFile generateHashStrategy = Just $ calculateHash cabalFile+ | otherwise = Nothing++ body :: [String]+ body = lines $ renderPackage hints pkg++shouldGenerateHash :: Maybe ExistingCabalFile -> 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 -> NewCabalFile -> [String]+renderCabalFile file (CabalFile cabalVersion hpackVersion hash body _) = cabalVersion ++ header file hpackVersion hash ++ body
src/Hpack/CabalFile.hs view
@@ -1,10 +1,22 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ViewPatterns #-}-module Hpack.CabalFile where+module Hpack.CabalFile (+ CabalFile(..)+, GitConflictMarkers(..)+, ExistingCabalFile+, NewCabalFile+, readCabalFile+, parseVersion+#ifdef TEST+, extractVersion+, removeGitConflictMarkers+#endif+) where -import Control.Monad-import Data.List+import Imports+ import Data.Maybe import Data.Version (Version(..)) import qualified Data.Version as Version@@ -12,27 +24,42 @@ import Hpack.Util -makeVersion :: [Int] -> Version-makeVersion v = Version v []--data CabalFile = CabalFile {- cabalFileHpackVersion :: Maybe Version+data CabalFile a = CabalFile {+ cabalFileCabalVersion :: [String]+, cabalFileHpackVersion :: Maybe Version , cabalFileHash :: Maybe Hash , cabalFileContents :: [String]+, cabalFileGitConflictMarkers :: a } deriving (Eq, Show) -readCabalFile :: FilePath -> IO (Maybe CabalFile)-readCabalFile cabalFile = fmap parse <$> tryReadFile cabalFile+data GitConflictMarkers = HasGitConflictMarkers | DoesNotHaveGitConflictMarkers+ deriving (Show, Eq)++type ExistingCabalFile = CabalFile GitConflictMarkers+type NewCabalFile = CabalFile ()++readCabalFile :: FilePath -> IO (Maybe ExistingCabalFile)+readCabalFile cabalFile = fmap parseCabalFile <$> tryReadFile cabalFile++parseCabalFile :: String -> ExistingCabalFile+parseCabalFile (lines -> input) = case span isComment <$> span (not . isComment) clean of+ (cabalVersion, (header, body)) -> CabalFile {+ cabalFileCabalVersion = cabalVersion+ , cabalFileHpackVersion = extractVersion header+ , cabalFileHash = extractHash header+ , cabalFileContents = dropWhile null body+ , cabalFileGitConflictMarkers = gitConflictMarkers+ } where- parse :: String -> CabalFile- parse (splitHeader -> (h, c)) = CabalFile (extractVersion h) (extractHash h) c+ clean :: [String]+ clean = removeGitConflictMarkers input - splitHeader :: String -> ([String], [String])- splitHeader (removeGitConflictMarkers . lines -> c) =- case span (not . isComment) c of- (cabalVersion, xs) -> case span isComment xs of- (header, body) -> (header, cabalVersion ++ dropWhile null body)+ gitConflictMarkers :: GitConflictMarkers+ gitConflictMarkers+ | input == clean = DoesNotHaveGitConflictMarkers+ | otherwise = HasGitConflictMarkers + isComment :: String -> Bool isComment = ("--" `isPrefixOf`) extractHash :: [String] -> Maybe Hash
src/Hpack/Config.hs view
@@ -1,17 +1,21 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE LiberalTypeSynonyms #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-} {-# 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@@ -31,13 +35,17 @@ , packageConfig , DecodeResult(..) , readPackageConfig+, readPackageConfigWithError , renamePackage , packageDependencies , package , section , Package(..)+, CabalVersion(..)+, makeCabalVersion , Dependencies(..)+, DependencyInfo(..) , VersionConstraint(..) , DependencyVersion(..) , SourceDependency(..)@@ -54,21 +62,23 @@ , Library(..) , Executable(..) , Conditional(..)+, Cond(..) , Flag(..) , SourceRepository(..)+, Language(..) , BuildType(..) , GhcProfOption , GhcjsOption , CppOption+, AsmOption , CcOption , LdOption , Path(..)+, Module(..) #ifdef TEST , renameDependencies , Empty(..)-, getModules , pathsModuleFromPackageName-, Cond(..) , LibrarySection(..) , fromLibrarySectionInConditional@@ -78,38 +88,38 @@ #endif ) where -import Control.Applicative-import Control.Arrow ((>>>), (&&&))-import Control.Monad+import Imports+ 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 qualified Data.Aeson.Config.KeyMap as KeyMap import Data.Maybe-import Data.Semigroup (Semigroup(..))+import Data.Monoid (Last(..)) import Data.Ord-import Data.String-import Data.Text (Text) import qualified Data.Text as T+import Data.Text.Encoding (decodeUtf8) 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 Control.Monad.State (MonadState, StateT, evalStateT)+import qualified Control.Monad.State as State+import Control.Monad.Writer (MonadWriter, WriterT, runWriterT, tell)+import Control.Monad.Except+import Data.Version (Version, showVersion)+import qualified Data.Version as Version import Distribution.Pretty (prettyShow) import qualified Distribution.SPDX.License as SPDX +import qualified Data.Yaml.Pretty as Yaml+import Data.Aeson (object, (.=)) import Data.Aeson.Config.Types import Data.Aeson.Config.FromValue hiding (decodeValue) import qualified Data.Aeson.Config.FromValue as Config +import Hpack.Error import Hpack.Syntax.Defaults import Hpack.Util hiding (expandGlobs) import qualified Hpack.Util as Util@@ -120,18 +130,25 @@ import Hpack.Syntax.BuildTools import Hpack.License import Hpack.CabalFile (parseVersion)+import Hpack.Module +import qualified Path+ import qualified Paths_hpack as Hpack (version) +defaultCabalVersion :: Version+defaultCabalVersion = Version.makeVersion [1,12]+ package :: String -> String -> Package package name version = Package {- packageName = name+ packageCabalVersion = CabalVersion defaultCabalVersion+ , packageName = name , packageVersion = version , packageSynopsis = Nothing , packageDescription = Nothing , packageHomepage = Nothing , packageBugReports = Nothing- , packageCategory = Nothing+ , packageCategory = [] , packageStability = Nothing , packageAuthor = [] , packageMaintainer = []@@ -139,10 +156,11 @@ , packageBuildType = Simple , packageLicense = Nothing , packageLicenseFile = []- , packageTestedWith = Nothing+ , packageTestedWith = [] , packageFlags = [] , packageExtraSourceFiles = [] , packageExtraDocFiles = []+ , packageExtraFiles = [] , packageDataFiles = [] , packageDataDir = Nothing , packageSourceRepository = Nothing@@ -183,7 +201,7 @@ deps xs = [(name, info) | (name, info) <- (Map.toList . unDependencies . sectionDependencies) xs] section :: a -> Section a-section a = Section a [] mempty [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] Nothing [] mempty mempty []+section a = Section a [] mempty [] [] [] Nothing [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] Nothing [] mempty mempty [] packageConfig :: FilePath packageConfig = "package.yaml"@@ -194,21 +212,23 @@ data LibrarySection = LibrarySection { librarySectionExposed :: Maybe Bool-, librarySectionExposedModules :: Maybe (List String)-, librarySectionGeneratedExposedModules :: Maybe (List String)-, librarySectionOtherModules :: Maybe (List String)-, librarySectionGeneratedOtherModules :: Maybe (List String)+, librarySectionVisibility :: Maybe String+, librarySectionExposedModules :: Maybe (List Module)+, librarySectionGeneratedExposedModules :: Maybe (List Module)+, librarySectionOtherModules :: Maybe (List Module)+, librarySectionGeneratedOtherModules :: Maybe (List Module) , 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+ 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@@ -218,18 +238,18 @@ } data ExecutableSection = ExecutableSection {- executableSectionMain :: Maybe FilePath-, executableSectionOtherModules :: Maybe (List String)-, executableSectionGeneratedOtherModules :: Maybe (List String)+ executableSectionMain :: Alias 'True "main-is" (Last FilePath)+, executableSectionOtherModules :: Maybe (List Module)+, executableSectionGeneratedOtherModules :: Maybe (List Module) } deriving (Eq, Show, Generic, FromValue) instance Monoid ExecutableSection where- mempty = ExecutableSection Nothing Nothing Nothing+ mempty = ExecutableSection mempty Nothing Nothing mappend = (<>) instance Semigroup ExecutableSection where a <> b = ExecutableSection {- executableSectionMain = executableSectionMain b <|> executableSectionMain a+ executableSectionMain = executableSectionMain a <> executableSectionMain b , executableSectionOtherModules = executableSectionOtherModules a <> executableSectionOtherModules b , executableSectionGeneratedOtherModules = executableSectionGeneratedOtherModules a <> executableSectionGeneratedOtherModules b }@@ -261,17 +281,22 @@ 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)+data CommonOptions asmSources cSources cxxSources jsSources a = CommonOptions {+ commonOptionsSourceDirs :: Alias 'True "hs-source-dirs" (Maybe (List FilePath))+, commonOptionsDependencies :: Alias 'True "build-depends" (Maybe Dependencies)+, commonOptionsPkgConfigDependencies :: Alias 'False "pkgconfig-depends" (Maybe (List String)) , commonOptionsDefaultExtensions :: Maybe (List String) , commonOptionsOtherExtensions :: Maybe (List String)+, commonOptionsLanguage :: Alias 'True "default-language" (Last (Maybe Language))+, commonOptionsMhsOptions :: Maybe (List GhcOption) , commonOptionsGhcOptions :: Maybe (List GhcOption) , commonOptionsGhcProfOptions :: Maybe (List GhcProfOption)+, commonOptionsGhcSharedOptions :: Maybe (List GhcOption) , commonOptionsGhcjsOptions :: Maybe (List GhcjsOption) , commonOptionsCppOptions :: Maybe (List CppOption) , commonOptionsCcOptions :: Maybe (List CcOption)+, commonOptionsAsmOptions :: Maybe (List AsmOption)+, commonOptionsAsmSources :: asmSources , commonOptionsCSources :: cSources , commonOptionsCxxOptions :: Maybe (List CxxOption) , commonOptionsCxxSources :: cxxSources@@ -283,27 +308,32 @@ , 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+, commonOptionsBuildable :: Last Bool+, commonOptionsWhen :: Maybe (List (ConditionalSection asmSources cSources cxxSources jsSources a))+, commonOptionsBuildTools :: Alias 'True "build-tool-depends" (Maybe BuildTools) , commonOptionsSystemBuildTools :: Maybe SystemBuildTools , commonOptionsVerbatim :: Maybe (List Verbatim) } deriving (Functor, Generic) -type ParseCommonOptions = CommonOptions ParseCSources ParseCxxSources ParseJsSources+type ParseCommonOptions = CommonOptions ParseAsmSources 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+instance (Semigroup asmSources, Semigroup cSources, Semigroup cxxSources, Semigroup jsSources, Monoid asmSources, Monoid cSources, Monoid cxxSources, Monoid jsSources) => Monoid (CommonOptions asmSources cSources cxxSources jsSources a) where mempty = CommonOptions {- commonOptionsSourceDirs = Nothing- , commonOptionsDependencies = Nothing- , commonOptionsPkgConfigDependencies = Nothing+ commonOptionsSourceDirs = Alias Nothing+ , commonOptionsDependencies = Alias Nothing+ , commonOptionsPkgConfigDependencies = Alias Nothing , commonOptionsDefaultExtensions = Nothing , commonOptionsOtherExtensions = Nothing+ , commonOptionsLanguage = mempty+ , commonOptionsMhsOptions = Nothing , commonOptionsGhcOptions = Nothing , commonOptionsGhcProfOptions = Nothing+ , commonOptionsGhcSharedOptions = Nothing , commonOptionsGhcjsOptions = Nothing , commonOptionsCppOptions = Nothing+ , commonOptionsAsmOptions = Nothing+ , commonOptionsAsmSources = mempty , commonOptionsCcOptions = Nothing , commonOptionsCSources = mempty , commonOptionsCxxOptions = Nothing@@ -316,25 +346,30 @@ , commonOptionsIncludeDirs = Nothing , commonOptionsInstallIncludes = Nothing , commonOptionsLdOptions = Nothing- , commonOptionsBuildable = Nothing+ , commonOptionsBuildable = mempty , commonOptionsWhen = Nothing- , commonOptionsBuildTools = Nothing+ , commonOptionsBuildTools = Alias Nothing , commonOptionsSystemBuildTools = Nothing , commonOptionsVerbatim = Nothing } mappend = (<>) -instance (Semigroup cSources, Semigroup cxxSources, Semigroup jsSources) => Semigroup (CommonOptions cSources cxxSources jsSources a) where+instance (Semigroup asmSources, Semigroup cSources, Semigroup cxxSources, Semigroup jsSources) => Semigroup (CommonOptions asmSources 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+ , commonOptionsLanguage = commonOptionsLanguage a <> commonOptionsLanguage b+ , commonOptionsMhsOptions = commonOptionsMhsOptions a <> commonOptionsMhsOptions b , commonOptionsGhcOptions = commonOptionsGhcOptions a <> commonOptionsGhcOptions b , commonOptionsGhcProfOptions = commonOptionsGhcProfOptions a <> commonOptionsGhcProfOptions b+ , commonOptionsGhcSharedOptions = commonOptionsGhcSharedOptions a <> commonOptionsGhcSharedOptions b , commonOptionsGhcjsOptions = commonOptionsGhcjsOptions a <> commonOptionsGhcjsOptions b , commonOptionsCppOptions = commonOptionsCppOptions a <> commonOptionsCppOptions b+ , commonOptionsAsmOptions = commonOptionsAsmOptions a <> commonOptionsAsmOptions b+ , commonOptionsAsmSources = commonOptionsAsmSources a <> commonOptionsAsmSources b , commonOptionsCcOptions = commonOptionsCcOptions a <> commonOptionsCcOptions b , commonOptionsCSources = commonOptionsCSources a <> commonOptionsCSources b , commonOptionsCxxOptions = commonOptionsCxxOptions a <> commonOptionsCxxOptions b@@ -347,59 +382,64 @@ , commonOptionsIncludeDirs = commonOptionsIncludeDirs a <> commonOptionsIncludeDirs b , commonOptionsInstallIncludes = commonOptionsInstallIncludes a <> commonOptionsInstallIncludes b , commonOptionsLdOptions = commonOptionsLdOptions a <> commonOptionsLdOptions b- , commonOptionsBuildable = commonOptionsBuildable b <|> commonOptionsBuildable a+ , commonOptionsBuildable = commonOptionsBuildable a <> commonOptionsBuildable b , commonOptionsWhen = commonOptionsWhen a <> commonOptionsWhen b , commonOptionsBuildTools = commonOptionsBuildTools a <> commonOptionsBuildTools b , commonOptionsSystemBuildTools = commonOptionsSystemBuildTools b <> commonOptionsSystemBuildTools a , commonOptionsVerbatim = commonOptionsVerbatim a <> commonOptionsVerbatim b } +type ParseAsmSources = Maybe (List FilePath) type ParseCSources = Maybe (List FilePath) type ParseCxxSources = Maybe (List FilePath) type ParseJsSources = Maybe (List FilePath) +type AsmSources = [Path] type CSources = [Path] type CxxSources = [Path] type JsSources = [Path] -type WithCommonOptions cSources cxxSources jsSources a = Product (CommonOptions cSources cxxSources jsSources a) a+type WithCommonOptions asmSources cSources cxxSources jsSources a = Product (CommonOptions asmSources cSources cxxSources jsSources a) a -data Traverse m cSources cSources_ cxxSources cxxSources_ jsSources jsSources_ = Traverse {- traverseCSources :: cSources -> m cSources_+data Traverse m asmSources asmSources_ cSources cSources_ cxxSources cxxSources_ jsSources jsSources_ = Traverse {+ traverseAsmSources :: asmSources -> m asmSources_+, 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 asmSources asmSources_ cSources cSources_ cxxSources cxxSources_ jsSources jsSources_. Monad m+ => Traverse m asmSources asmSources_ cSources cSources_ cxxSources cxxSources_ jsSources jsSources_+ -> t asmSources cSources cxxSources jsSources+ -> m (t asmSources_ 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)+type Traversal_ t = forall m asmSources asmSources_ cSources cSources_ cxxSources cxxSources_ jsSources jsSources_ a. Monad m+ => Traverse m asmSources asmSources_ cSources cSources_ cxxSources cxxSources_ jsSources jsSources_+ -> t asmSources cSources cxxSources jsSources a+ -> m (t asmSources_ cSources_ cxxSources_ jsSources_ a) traverseCommonOptions :: Traversal_ CommonOptions traverseCommonOptions t@Traverse{..} c@CommonOptions{..} = do+ asmSources <- traverseAsmSources commonOptionsAsmSources cSources <- traverseCSources commonOptionsCSources cxxSources <- traverseCxxSources commonOptionsCxxSources jsSources <- traverseJsSources commonOptionsJsSources xs <- traverse (traverse (traverseConditionalSection t)) commonOptionsWhen return c {- commonOptionsCSources = cSources+ commonOptionsAsmSources = asmSources+ , commonOptionsCSources = cSources , commonOptionsCxxSources = cxxSources , commonOptionsJsSources = jsSources , commonOptionsWhen = xs } traverseConditionalSection :: Traversal_ ConditionalSection-traverseConditionalSection t@Traverse{..} = \ case+traverseConditionalSection t = \ 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+traverseThenElse t c@ThenElse{..} = do then_ <- traverseWithCommonOptions t thenElseThen else_ <- traverseWithCommonOptions t thenElseElse return c{thenElseThen = then_, thenElseElse = else_}@@ -407,51 +447,80 @@ 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)+data ConditionalSection asmSources cSources cxxSources jsSources a =+ ThenElseConditional (Product (ThenElse asmSources cSources cxxSources jsSources a) Condition)+ | FlatConditional (Product (WithCommonOptions asmSources cSources cxxSources jsSources a) Condition) -instance Functor (ConditionalSection cSources cxxSources jsSources) where+instance Functor (ConditionalSection asmSources 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+type ParseConditionalSection = ConditionalSection ParseAsmSources ParseCSources ParseCxxSources ParseJsSources instance FromValue a => FromValue (ParseConditionalSection a) where fromValue v- | hasKey "then" v || hasKey "else" v = ThenElseConditional <$> fromValue v+ | hasKey "then" v || hasKey "else" v = ThenElseConditional <$> fromValue v <* giveHint | otherwise = FlatConditional <$> fromValue v+ where+ giveHint = case v of+ Object o -> case (,,) <$> KeyMap.lookup "then" o <*> KeyMap.lookup "else" o <*> KeyMap.lookup "condition" o of+ Just (Object then_, Object else_, String condition) -> do+ when (KeyMap.null then_) $ "then" `emptyTryInstead` flatElse+ when (KeyMap.null else_) $ "else" `emptyTryInstead` flatThen+ where+ flatThen = flatConditional condition then_+ flatElse = flatConditional (negate_ condition) else_+ _ -> return ()+ _ -> return () -hasKey :: Text -> Value -> Bool-hasKey key (Object o) = HashMap.member key o+ negate_ condition = "!(" <> condition <> ")"++ flatConditional condition sect = object [("when" .= KeyMap.insert "condition" (String condition) sect)]++ emptyTryInstead :: String -> Value -> Parser ()+ emptyTryInstead name sect = do+ fail $ "an empty " <> show name <> " section is not allowed, try the following instead:\n\n" ++ encodePretty sect++ encodePretty = T.unpack . decodeUtf8 . Yaml.encodePretty c+ where+ c :: Yaml.Config+ c = Yaml.setConfCompare f Yaml.defConfig+ where+ f a b = case (a, b) of+ ("condition", "condition") -> EQ+ ("condition", _) -> LT+ (_, "condition") -> GT+ _ -> compare a b++hasKey :: Key -> Value -> Bool+hasKey key (Object o) = KeyMap.member key o hasKey _ _ = False newtype Condition = Condition {- _conditionCondition :: Cond+ conditionCondition :: Cond } deriving (Eq, Show, Generic, FromValue) -newtype Cond = Cond String+data Cond = CondBool Bool | CondExpression 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")+ String c -> return (CondExpression $ T.unpack c)+ Bool c -> return (CondBool c) _ -> typeMismatch "Boolean or String" v -data ThenElse cSources cxxSources jsSources a = ThenElse {- thenElseThen :: WithCommonOptions cSources cxxSources jsSources a-, thenElseElse :: WithCommonOptions cSources cxxSources jsSources a+data ThenElse asmSources cSources cxxSources jsSources a = ThenElse {+ thenElseThen :: WithCommonOptions asmSources cSources cxxSources jsSources a+, thenElseElse :: WithCommonOptions asmSources cSources cxxSources jsSources a } deriving Generic -instance Functor (ThenElse cSources cxxSources jsSources) where+instance Functor (ThenElse asmSources 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+type ParseThenElse = ThenElse ParseAsmSources ParseCSources ParseCxxSources ParseJsSources instance FromValue a => FromValue (ParseThenElse a) @@ -468,12 +537,21 @@ instance FromValue Empty where fromValue _ = return Empty +newtype Language = Language String+ deriving (Eq, Show)++instance IsString Language where+ fromString = Language++instance FromValue Language where+ fromValue = fmap Language . fromValue+ data BuildType = Simple | Configure | Make | Custom- deriving (Eq, Show, Generic, Enum, Bounded)+ deriving (Eq, Show, Enum, Bounded) instance FromValue BuildType where fromValue = withText $ \ (T.unpack -> t) -> do@@ -491,15 +569,15 @@ 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 SectionConfigWithDefaults asmSources cSources cxxSources jsSources a = Product DefaultsConfig (WithCommonOptions asmSources cSources cxxSources jsSources a) -type PackageConfigWithDefaults cSources cxxSources jsSources = PackageConfig_- (SectionConfigWithDefaluts cSources cxxSources jsSources LibrarySection)- (SectionConfigWithDefaluts cSources cxxSources jsSources ExecutableSection)+type PackageConfigWithDefaults asmSources cSources cxxSources jsSources = PackageConfig_+ (SectionConfigWithDefaults asmSources cSources cxxSources jsSources LibrarySection)+ (SectionConfigWithDefaults asmSources cSources cxxSources jsSources ExecutableSection) -type PackageConfig cSources cxxSources jsSources = PackageConfig_- (WithCommonOptions cSources cxxSources jsSources LibrarySection)- (WithCommonOptions cSources cxxSources jsSources ExecutableSection)+type PackageConfig asmSources cSources cxxSources jsSources = PackageConfig_+ (WithCommonOptions asmSources cSources cxxSources jsSources LibrarySection)+ (WithCommonOptions asmSources cSources cxxSources jsSources ExecutableSection) data PackageVersion = PackageVersion {unPackageVersion :: String} @@ -516,7 +594,7 @@ , packageConfigDescription :: Maybe String , packageConfigHomepage :: Maybe (Maybe String) , packageConfigBugReports :: Maybe (Maybe String)-, packageConfigCategory :: Maybe String+, packageConfigCategory :: Maybe (List String) , packageConfigStability :: Maybe String , packageConfigAuthor :: Maybe (List String) , packageConfigMaintainer :: Maybe (Maybe (List String))@@ -524,13 +602,15 @@ , packageConfigBuildType :: Maybe BuildType , packageConfigLicense :: Maybe (Maybe String) , packageConfigLicenseFile :: Maybe (List String)-, packageConfigTestedWith :: Maybe String+, packageConfigTestedWith :: Maybe (List String) , packageConfigFlags :: Maybe (Map String FlagSection) , packageConfigExtraSourceFiles :: Maybe (List FilePath) , packageConfigExtraDocFiles :: Maybe (List FilePath)+, packageConfigExtraFiles :: Maybe (List FilePath) , packageConfigDataFiles :: Maybe (List FilePath) , packageConfigDataDir :: Maybe FilePath-, packageConfigGithub :: Maybe Text+, packageConfigGithub :: Maybe GitHub+, packageConfigCodeberg :: Maybe GitHub , packageConfigGit :: Maybe String , packageConfigCustomSetup :: Maybe CustomSetupSection , packageConfigLibrary :: Maybe library@@ -541,12 +621,26 @@ , 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+traversePackageConfig t p@PackageConfig{..} = do library <- traverse (traverseWithCommonOptions t) packageConfigLibrary internalLibraries <- traverseNamedConfigs t packageConfigInternalLibraries executable <- traverse (traverseWithCommonOptions t) packageConfigExecutable@@ -564,34 +658,31 @@ where traverseNamedConfigs = traverse . traverse . traverseWithCommonOptions -type ParsePackageConfig = PackageConfigWithDefaults ParseCSources ParseCxxSources ParseJsSources+type ParsePackageConfig = PackageConfigWithDefaults ParseAsmSources ParseCSources ParseCxxSources ParseJsSources instance FromValue ParsePackageConfig -type Warnings m = WriterT [String] m-type Errors = ExceptT String+liftIOEither :: (MonadIO m, Errors m) => IO (Either HpackError a) -> m a+liftIOEither action = liftIO action >>= liftEither -decodeYaml :: FromValue a => ProgramName -> FilePath -> Warnings (Errors IO) a-decodeYaml programName file = do- (warnings, a) <- lift (ExceptT $ Yaml.decodeYaml file)+type FormatYamlParseError = FilePath -> Yaml.ParseException -> String++decodeYaml :: (FromValue a, MonadIO m, Warnings m, Errors m, State m) => FormatYamlParseError -> FilePath -> m a+decodeYaml formatYamlParseError file = do+ (warnings, a) <- liftIOEither $ first (ParseError . formatYamlParseError file) <$> Yaml.decodeYamlWithParseError file tell warnings- decodeValue programName file a+ decodeValue file a data DecodeOptions = DecodeOptions { decodeOptionsProgramName :: ProgramName , decodeOptionsTarget :: FilePath , decodeOptionsUserDataDir :: Maybe FilePath , decodeOptionsDecode :: FilePath -> IO (Either String ([String], Value))+, decodeOptionsFormatYamlParseError :: FilePath -> Yaml.ParseException -> String } -newtype ProgramName = ProgramName String- deriving (Eq, Show)--instance IsString ProgramName where- fromString = ProgramName- defaultDecodeOptions :: DecodeOptions-defaultDecodeOptions = DecodeOptions "hpack" packageConfig Nothing Yaml.decodeYaml+defaultDecodeOptions = DecodeOptions "hpack" packageConfig Nothing Yaml.decodeYaml Yaml.formatYamlParseError data DecodeResult = DecodeResult { decodeResultPackage :: Package@@ -601,16 +692,33 @@ } 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+readPackageConfig options = first (formatHpackError $ decodeOptionsProgramName options) <$> readPackageConfigWithError options++type Errors = MonadError HpackError+type Warnings = MonadWriter [String]+type State = MonadState SpecVersion++type ConfigM m = StateT SpecVersion (WriterT [String] (ExceptT HpackError m))++runConfigM :: Monad m => ConfigM m a -> m (Either HpackError (a, [String]))+runConfigM = runExceptT . runWriterT . (`evalStateT` NoSpecVersion)++readPackageConfigWithError :: DecodeOptions -> IO (Either HpackError DecodeResult)+readPackageConfigWithError (DecodeOptions _ file mUserDataDir readValue formatYamlParseError) = fmap (fmap addCabalFile) . runConfigM $ do+ (warnings, value) <- liftIOEither $ first ParseError <$> readValue file tell warnings- config <- decodeValue programName file value+ config <- decodeValue file value dir <- liftIO $ takeDirectory <$> canonicalizePath file userDataDir <- liftIO $ maybe (getAppUserDataDirectory "hpack") return mUserDataDir- toPackage programName userDataDir dir config+ toPackage formatYamlParseError userDataDir dir config where- addCabalFile :: ((Package, String), [String]) -> DecodeResult- addCabalFile ((pkg, cabalVersion), warnings) = DecodeResult pkg cabalVersion (takeDirectory_ file </> (packageName pkg ++ ".cabal")) warnings+ addCabalFile :: (Package, [String]) -> DecodeResult+ addCabalFile (pkg, warnings) = DecodeResult {+ decodeResultPackage = pkg+ , decodeResultCabalVersion = "cabal-version: " ++ showCabalVersion (packageCabalVersion pkg) ++ "\n\n"+ , decodeResultCabalFile = takeDirectory_ file </> packageName pkg <.> "cabal"+ , decodeResultWarnings = warnings+ } takeDirectory_ :: FilePath -> FilePath takeDirectory_ p@@ -629,19 +737,84 @@ 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"- )+addPathsModuleToGeneratedModules :: Package -> Package+addPathsModuleToGeneratedModules pkg+ | packageCabalVersion pkg < makeCabalVersion [2] = pkg+ | otherwise = pkg {+ packageLibrary = fmap mapLibrary <$> packageLibrary pkg+ , packageInternalLibraries = fmap mapLibrary <$> packageInternalLibraries pkg+ , packageExecutables = fmap mapExecutable <$> packageExecutables pkg+ , packageTests = fmap mapExecutable <$> packageTests pkg+ , packageBenchmarks = fmap mapExecutable <$> packageBenchmarks pkg+ } where+ pathsModule = pathsModuleFromPackageName (packageName pkg)++ mapLibrary :: Library -> Library+ mapLibrary lib+ | pathsModule `elem` getLibraryModules lib = lib {+ libraryGeneratedModules = if pathsModule `elem` generatedModules then generatedModules else pathsModule : generatedModules+ }+ | otherwise = lib+ where+ generatedModules = libraryGeneratedModules lib++ mapExecutable :: Executable -> Executable+ mapExecutable executable+ | pathsModule `elem` executableOtherModules executable = executable {+ executableGeneratedModules = if pathsModule `elem` generatedModules then generatedModules else pathsModule : generatedModules+ }+ | otherwise = executable+ where+ generatedModules = executableGeneratedModules executable++data CabalVersion = CabalVersion Version | VerbatimCabalVersion String+ deriving (Eq, Ord, Show)++makeCabalVersion :: [Int] -> CabalVersion+makeCabalVersion = CabalVersion . Version.makeVersion++showCabalVersion :: CabalVersion -> String+showCabalVersion = \ case+ CabalVersion v -> showVersion v+ VerbatimCabalVersion v -> v++extractVerbatimCabalVersion :: [Verbatim] -> (Maybe CabalVersion, [Verbatim])+extractVerbatimCabalVersion verbatim = case listToMaybe (mapMaybe extractCabalVersion verbatim) of+ Nothing -> (Nothing, verbatim)+ Just verbatimVersion -> (Just cabalVersion, deleteVerbatimField "cabal-version" verbatim)+ where+ cabalVersion :: CabalVersion+ cabalVersion = case parseVersion verbatimVersion of+ Nothing -> VerbatimCabalVersion verbatimVersion+ Just v -> CabalVersion v+ where+ extractCabalVersion :: Verbatim -> Maybe String+ extractCabalVersion = \ case+ VerbatimLiteral _ -> Nothing+ VerbatimObject o -> case Map.lookup "cabal-version" o of+ Just v -> Just (verbatimValueToString v)+ Nothing -> Nothing++ensureRequiredCabalVersion :: Maybe (License SPDX.License) -> Package -> Package+ensureRequiredCabalVersion inferredLicense pkg@Package{..} = pkg {+ packageCabalVersion = version+ , packageLicense = formatLicense <$> license+ , packageVerbatim = verbatim+ }+ where+ makeVersion :: [Int] -> CabalVersion+ makeVersion = makeCabalVersion++ (verbatimCabalVersion, verbatim) = extractVerbatimCabalVersion packageVerbatim++ license :: Maybe (License String) license = fmap prettyShow <$> (parsedLicense <|> inferredLicense) + parsedLicense :: Maybe (License SPDX.License) parsedLicense = parseLicense <$> packageLicense + formatLicense :: License String -> String formatLicense = \ case MustSPDX spdx -> spdx CanSPDX _ spdx | version >= makeVersion [2,2] -> spdx@@ -656,21 +829,15 @@ 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 :: CabalVersion+ version = fromMaybe inferredVersion verbatimCabalVersion - version = fromMaybe (makeVersion [1,12]) $ maximum [- packageCabalVersion+ inferredVersion :: CabalVersion+ inferredVersion = fromMaybe packageCabalVersion $ maximum [+ makeVersion [2,2] <$ guard mustSPDX+ , makeVersion [1,24] <$ packageCustomSetup+ , makeVersion [1,18] <$ guard (not (null packageExtraDocFiles))+ , makeVersion [3,14] <$ guard (not (null packageExtraFiles)) , packageLibrary >>= libraryCabalVersion , internalLibsCabalVersion packageInternalLibraries , executablesCabalVersion packageExecutables@@ -678,58 +845,84 @@ , 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 :: Section Library -> Maybe CabalVersion libraryCabalVersion sect = maximum [- makeVersion [1,22] <$ guard hasReexportedModules- , makeVersion [2,0] <$ guard hasSignatures- , makeVersion [2,0] <$ guard hasGeneratedModules- , sectionCabalVersion sect+ makeVersion [1,22] <$ guard (has libraryReexportedModules)+ , makeVersion [2,0] <$ guard (has librarySignatures)+ , makeVersion [2,0] <$ guard (has libraryGeneratedModules)+ , makeVersion [3,12] <$ guard (libraryHasPackageInfoModule sect)+ , makeVersion [3,0] <$ guard (has libraryVisibility)+ , sectionCabalVersion (concatMap getLibraryModules) sect ] where- hasReexportedModules = any (not . null . libraryReexportedModules) sect- hasSignatures = any (not . null . librarySignatures) sect- hasGeneratedModules = any (not . null . libraryGeneratedModules) sect+ has field = any (not . null . field) sect - internalLibsCabalVersion :: Map String (Section Library) -> Maybe Version+ libraryHasPackageInfoModule :: Section Library -> Bool+ libraryHasPackageInfoModule =+ any (hasPackageInfoModule . libraryGeneratedModules)++ packageInfoModule :: Module+ packageInfoModule =+ Module ("PackageInfo_" ++ moduleNameFromPackageName packageName)++ hasPackageInfoModule :: [Module] -> Bool+ hasPackageInfoModule = any (== packageInfoModule)++ internalLibsCabalVersion :: Map String (Section Library) -> Maybe CabalVersion 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 :: Map String (Section Executable) -> Maybe CabalVersion executablesCabalVersion = foldr max Nothing . map executableCabalVersion . Map.elems - executableCabalVersion :: Section Executable -> Maybe Version+ executableCabalVersion :: Section Executable -> Maybe CabalVersion executableCabalVersion sect = maximum [ makeVersion [2,0] <$ guard (executableHasGeneratedModules sect)- , sectionCabalVersion sect+ , makeVersion [3,12] <$ guard (executableHasPackageInfoModule sect)+ , sectionCabalVersion (concatMap getExecutableModules) sect ] executableHasGeneratedModules :: Section Executable -> Bool executableHasGeneratedModules = any (not . null . executableGeneratedModules) - sectionCabalVersion :: Section a -> Maybe Version- sectionCabalVersion sect = maximum $ [+ executableHasPackageInfoModule :: Section Executable -> Bool+ executableHasPackageInfoModule =+ any (hasPackageInfoModule . executableGeneratedModules)++ sectionCabalVersion :: (Section a -> [Module]) -> Section a -> Maybe CabalVersion+ sectionCabalVersion getMentionedModules sect = maximum $ [ makeVersion [2,2] <$ guard (sectionSatisfies (not . null . sectionCxxSources) sect) , makeVersion [2,2] <$ guard (sectionSatisfies (not . null . sectionCxxOptions) sect)+ , makeVersion [3,0] <$ guard (sectionSatisfies (not . null . sectionAsmOptions) sect)+ , makeVersion [3,0] <$ guard (sectionSatisfies (not . null . sectionAsmSources) sect) , makeVersion [2,0] <$ guard (sectionSatisfies (any hasMixins . unDependencies . sectionDependencies) sect)+ , makeVersion [3,0] <$ guard (sectionSatisfies (any hasSubcomponents . Map.keys . unDependencies . sectionDependencies) sect)+ , makeVersion [2,2] <$ guard (+ uses "RebindableSyntax"+ && (uses "OverloadedStrings" || uses "OverloadedLists")+ && pathsModule `elem` getMentionedModules sect) ] ++ map versionFromSystemBuildTool systemBuildTools where+ defaultExtensions :: [String]+ defaultExtensions = sectionAll sectionDefaultExtensions sect++ uses :: String -> Bool+ uses = (`elem` defaultExtensions)++ pathsModule :: Module+ pathsModule = pathsModuleFromPackageName packageName++ versionFromSystemBuildTool :: String -> Maybe CabalVersion 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 :: [String] known_1_10 = [ "ghc" , "ghc-pkg"@@ -757,9 +950,13 @@ , "lhc" , "lhc-pkg" ]++ known_1_14 :: [String] known_1_14 = [ "hpc" ]++ known_1_22 :: [String] known_1_22 = [ "ghcjs" , "ghcjs-pkg"@@ -775,33 +972,51 @@ 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) -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)+ hasSubcomponents :: String -> Bool+ hasSubcomponents = elem ':'++sectionAll :: Monoid b => (Section a -> b) -> Section a -> b+sectionAll f sect = f sect <> foldMap (foldMap $ sectionAll f) (sectionConditionals sect)++decodeValue :: (FromValue a, State m, Warnings m, Errors m) => FilePath -> Value -> m a+decodeValue file value = do+ (r, unknown, deprecated) <- liftEither $ first (DecodeValueError file) (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+ throwError $ HpackVersionNotSupported file v Hpack.version+ SupportedSpecVersion v a -> do tell (map formatUnknownField unknown)+ tell (map formatDeprecatedField deprecated)+ State.modify $ max v return a where+ prefix :: String prefix = file ++ ": "++ formatUnknownField :: String -> String formatUnknownField name = prefix ++ "Ignoring unrecognized field " ++ name -data CheckSpecVersion a = SupportedSpecVersion a | UnsupportedSpecVersion Version+ formatDeprecatedField :: (String, String) -> String+ formatDeprecatedField (name, substitute) = prefix <> name <> " is deprecated, use " <> substitute <> " instead" +data SpecVersion = NoSpecVersion | SpecVersion Version+ deriving (Eq, Show, Ord)++toSpecVersion :: Maybe ParseSpecVersion -> SpecVersion+toSpecVersion = maybe NoSpecVersion (SpecVersion . unParseSpecVersion)++data CheckSpecVersion a = SupportedSpecVersion SpecVersion 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)+ v -> SupportedSpecVersion (toSpecVersion v) <$> fromValue (Object o) -newtype ParseSpecVersion = ParseSpecVersion Version+newtype ParseSpecVersion = ParseSpecVersion {unParseSpecVersion :: Version} instance FromValue ParseSpecVersion where fromValue value = do@@ -814,13 +1029,14 @@ Nothing -> fail ("invalid value " ++ show s) data Package = Package {- packageName :: String+ packageCabalVersion :: CabalVersion+, packageName :: String , packageVersion :: String , packageSynopsis :: Maybe String , packageDescription :: Maybe String , packageHomepage :: Maybe String , packageBugReports :: Maybe String-, packageCategory :: Maybe String+, packageCategory :: [String] , packageStability :: Maybe String , packageAuthor :: [String] , packageMaintainer :: [String]@@ -828,10 +1044,11 @@ , packageBuildType :: BuildType , packageLicense :: Maybe String , packageLicenseFile :: [FilePath]-, packageTestedWith :: Maybe String+, packageTestedWith :: [String] , packageFlags :: [Flag] , packageExtraSourceFiles :: [Path] , packageExtraDocFiles :: [Path]+, packageExtraFiles :: [Path] , packageDataFiles :: [Path] , packageDataDir :: Maybe FilePath , packageSourceRepository :: Maybe SourceRepository@@ -850,17 +1067,18 @@ data Library = Library { libraryExposed :: Maybe Bool-, libraryExposedModules :: [String]-, libraryOtherModules :: [String]-, libraryGeneratedModules :: [String]+, libraryVisibility :: Maybe String+, libraryExposedModules :: [Module]+, libraryOtherModules :: [Module]+, libraryGeneratedModules :: [Module] , libraryReexportedModules :: [String] , librarySignatures :: [String] } deriving (Eq, Show) data Executable = Executable { executableMain :: Maybe FilePath-, executableOtherModules :: [String]-, executableGeneratedModules :: [String]+, executableOtherModules :: [Module]+, executableGeneratedModules :: [Module] } deriving (Eq, Show) data BuildTool = BuildTool String String | LocalBuildTool String@@ -873,10 +1091,15 @@ , sectionPkgConfigDependencies :: [String] , sectionDefaultExtensions :: [String] , sectionOtherExtensions :: [String]+, sectionLanguage :: Maybe Language+, sectionMhsOptions :: [GhcOption] , sectionGhcOptions :: [GhcOption] , sectionGhcProfOptions :: [GhcProfOption]+, sectionGhcSharedOptions :: [GhcOption] , sectionGhcjsOptions :: [GhcjsOption] , sectionCppOptions :: [CppOption]+, sectionAsmOptions :: [AsmOption]+, sectionAsmSources :: [Path] , sectionCcOptions :: [CcOption] , sectionCSources :: [Path] , sectionCxxOptions :: [CxxOption]@@ -897,7 +1120,7 @@ } deriving (Eq, Show, Functor, Foldable, Traversable) data Conditional a = Conditional {- conditionalCondition :: String+ conditionalCondition :: Cond , conditionalThen :: a , conditionalElse :: Maybe a } deriving (Eq, Show, Functor, Foldable, Traversable)@@ -923,55 +1146,63 @@ , sourceRepositorySubdir :: Maybe String } deriving (Eq, Show) -type Config cSources cxxSources jsSources =- Product (CommonOptions cSources cxxSources jsSources Empty) (PackageConfig cSources cxxSources jsSources)+type Config asmSources cSources cxxSources jsSources =+ Product (CommonOptions asmSources cSources cxxSources jsSources Empty) (PackageConfig asmSources cSources cxxSources jsSources) traverseConfig :: Traversal Config traverseConfig t = bitraverse (traverseCommonOptions t) (traversePackageConfig t) type ConfigWithDefaults = Product (CommonOptionsWithDefaults Empty)- (PackageConfigWithDefaults ParseCSources ParseCxxSources ParseJsSources)+ (PackageConfigWithDefaults ParseAsmSources ParseCSources ParseCxxSources ParseJsSources) -type CommonOptionsWithDefaults a = Product DefaultsConfig (CommonOptions ParseCSources ParseCxxSources ParseJsSources a)-type WithCommonOptionsWithDefaults a = Product DefaultsConfig (WithCommonOptions ParseCSources ParseCxxSources ParseJsSources a)+type CommonOptionsWithDefaults a = Product DefaultsConfig (CommonOptions ParseAsmSources ParseCSources ParseCxxSources ParseJsSources a)+type WithCommonOptionsWithDefaults a = Product DefaultsConfig (WithCommonOptions ParseAsmSources 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 :: FormatYamlParseError -> FilePath -> FilePath -> ConfigWithDefaults -> ConfigM IO Package+toPackage formatYamlParseError userDataDir dir =+ expandDefaultsInConfig formatYamlParseError userDataDir dir+ >=> setDefaultLanguage "Haskell2010"+ >>> traverseConfig (expandForeignSources dir) >=> toPackage_ dir+ where+ setDefaultLanguage language config = first setLanguage config+ where+ setLanguage = (mempty { commonOptionsLanguage = Alias . Last $ Just (Just language) } <>) expandDefaultsInConfig- :: ProgramName+ :: (MonadIO m, Warnings m, Errors m, State m) =>+ FormatYamlParseError -> FilePath -> FilePath -> ConfigWithDefaults- -> Warnings (Errors IO) (Config ParseCSources ParseCxxSources ParseJsSources)-expandDefaultsInConfig programName userDataDir dir = bitraverse (expandGlobalDefaults programName userDataDir dir) (expandSectionDefaults programName userDataDir dir)+ -> m (Config ParseAsmSources ParseCSources ParseCxxSources ParseJsSources)+expandDefaultsInConfig formatYamlParseError userDataDir dir = bitraverse (expandGlobalDefaults formatYamlParseError userDataDir dir) (expandSectionDefaults formatYamlParseError userDataDir dir) expandGlobalDefaults- :: ProgramName+ :: (MonadIO m, Warnings m, Errors m, State m) =>+ FormatYamlParseError -> 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+ -> m (CommonOptions ParseAsmSources ParseCSources ParseCxxSources ParseJsSources Empty)+expandGlobalDefaults formatYamlParseError userDataDir dir = do+ fmap (`Product` Empty) >>> expandDefaults formatYamlParseError userDataDir dir >=> \ (Product c Empty) -> return c expandSectionDefaults- :: ProgramName+ :: (MonadIO m, Warnings m, Errors m, State m) =>+ FormatYamlParseError -> 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+ -> PackageConfigWithDefaults ParseAsmSources ParseCSources ParseCxxSources ParseJsSources+ -> m (PackageConfig ParseAsmSources ParseCSources ParseCxxSources ParseJsSources)+expandSectionDefaults formatYamlParseError userDataDir dir p@PackageConfig{..} = do+ library <- traverse (expandDefaults formatYamlParseError userDataDir dir) packageConfigLibrary+ internalLibraries <- traverse (traverse (expandDefaults formatYamlParseError userDataDir dir)) packageConfigInternalLibraries+ executable <- traverse (expandDefaults formatYamlParseError userDataDir dir) packageConfigExecutable+ executables <- traverse (traverse (expandDefaults formatYamlParseError userDataDir dir)) packageConfigExecutables+ tests <- traverse (traverse (expandDefaults formatYamlParseError userDataDir dir)) packageConfigTests+ benchmarks <- traverse (traverse (expandDefaults formatYamlParseError userDataDir dir)) packageConfigBenchmarks return p{ packageConfigLibrary = library , packageConfigInternalLibraries = internalLibraries@@ -982,43 +1213,44 @@ } expandDefaults- :: (FromValue a, Semigroup a, Monoid a)- => ProgramName+ :: forall a m. (MonadIO m, Warnings m, Errors m, State m) =>+ (FromValue a, Monoid a)+ => FormatYamlParseError -> FilePath -> FilePath -> WithCommonOptionsWithDefaults a- -> Warnings (Errors IO) (WithCommonOptions ParseCSources ParseCxxSources ParseJsSources a)-expandDefaults programName userDataDir = expand []+ -> m (WithCommonOptions ParseAsmSources ParseCSources ParseCxxSources ParseJsSources a)+expandDefaults formatYamlParseError userDataDir = expand [] where- expand :: (FromValue a, Semigroup a, Monoid a) =>+ expand :: [FilePath] -> FilePath -> WithCommonOptionsWithDefaults a- -> Warnings (Errors IO) (WithCommonOptions ParseCSources ParseCxxSources ParseJsSources a)+ -> m (WithCommonOptions ParseAsmSources 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) =>+ get :: [FilePath] -> FilePath -> Defaults- -> Warnings (Errors IO) (WithCommonOptions ParseCSources ParseCxxSources ParseJsSources a)+ -> m (WithCommonOptions ParseAsmSources ParseCSources ParseCxxSources ParseJsSources a) get seen dir defaults = do- file <- lift $ ExceptT (ensure userDataDir dir defaults)- seen_ <- lift (checkCycle seen file)+ file <- liftIOEither (ensure userDataDir dir defaults)+ seen_ <- checkCycle seen file let dir_ = takeDirectory file- decodeYaml programName file >>= expand seen_ dir_+ decodeYaml formatYamlParseError file >>= expand seen_ dir_ - checkCycle :: [FilePath] -> FilePath -> Errors IO [FilePath]+ checkCycle :: [FilePath] -> FilePath -> m [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_) ++ ")")+ throwError $ CycleInDefaults (reverse seen_) return seen_ -toExecutableMap :: Monad m => String -> Maybe (Map String a) -> Maybe a -> Warnings m (Maybe (Map String a))+toExecutableMap :: Warnings m => String -> Maybe (Map String a) -> Maybe a -> m (Maybe (Map String a)) toExecutableMap name executables mExecutable = do case mExecutable of Just executable -> do@@ -1027,26 +1259,29 @@ return $ Just (Map.fromList [(name, executable)]) Nothing -> return executables -type GlobalOptions = CommonOptions CSources CxxSources JsSources Empty+type GlobalOptions = CommonOptions AsmSources CSources CxxSources JsSources Empty -toPackage_ :: MonadIO m => FilePath -> Product GlobalOptions (PackageConfig CSources CxxSources JsSources) -> Warnings m (Package, String)+toPackage_ :: (MonadIO m, Warnings m, State m) => FilePath -> Product GlobalOptions (PackageConfig AsmSources CSources CxxSources JsSources) -> m Package toPackage_ dir (Product g PackageConfig{..}) = do- executableMap <- toExecutableMap packageName_ packageConfigExecutables packageConfigExecutable+ 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) <>)+ toSect :: (Warnings m, Monoid a) => WithCommonOptions AsmSources CSources CxxSources JsSources a -> 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_)+ toSections :: (Warnings m, Monoid a) => Maybe (Map String (WithCommonOptions AsmSources CSources CxxSources JsSources a)) -> m (Map String (Section a))+ toSections = maybe (return mempty) (traverse toSect) - mLibrary <- traverse toLib packageConfigLibrary- internalLibraries <- maybe (return mempty) (traverse toLib) packageConfigInternalLibraries+ toLib = toLibrary dir packageName+ toExecutables = toSections >=> traverse (toExecutable dir packageName) + mLibrary <- traverse (toSect >=> toLib) packageConfigLibrary+ internalLibraries <- toSections packageConfigInternalLibraries >>= traverse toLib+ executables <- toExecutables executableMap tests <- toExecutables packageConfigTests benchmarks <- toExecutables packageConfigBenchmarks@@ -1063,6 +1298,7 @@ extraSourceFiles <- expandGlobs "extra-source-files" dir (fromMaybeList packageConfigExtraSourceFiles) extraDocFiles <- expandGlobs "extra-doc-files" dir (fromMaybeList packageConfigExtraDocFiles)+ extraFiles <- expandGlobs "extra-files" dir (fromMaybeList packageConfigExtraFiles) let dataBaseDir = maybe dir (dir </>) packageConfigDataDir @@ -1088,13 +1324,14 @@ defaultBuildType = maybe Simple (const Custom) mCustomSetup pkg = Package {- packageName = packageName_+ packageCabalVersion = CabalVersion defaultCabalVersion+ , packageName , packageVersion = maybe "0.0.0" unPackageVersion packageConfigVersion , packageSynopsis = packageConfigSynopsis , packageDescription = packageConfigDescription , packageHomepage = homepage , packageBugReports = bugReports- , packageCategory = packageConfigCategory+ , packageCategory = fromMaybeList packageConfigCategory , packageStability = packageConfigStability , packageAuthor = fromMaybeList packageConfigAuthor , packageMaintainer = fromMaybeList maintainer@@ -1102,10 +1339,11 @@ , packageBuildType = fromMaybe defaultBuildType packageConfigBuildType , packageLicense = join packageConfigLicense , packageLicenseFile = licenseFiles- , packageTestedWith = packageConfigTestedWith+ , packageTestedWith = fromMaybeList packageConfigTestedWith , packageFlags = flags , packageExtraSourceFiles = extraSourceFiles , packageExtraDocFiles = extraDocFiles+ , packageExtraFiles = extraFiles , packageDataFiles = dataFiles , packageDataDir = packageConfigDataDir , packageSourceRepository = sourceRepository@@ -1120,11 +1358,12 @@ tell nameWarnings tell (formatMissingSourceDirs missingSourceDirs)- return (determineCabalVersion inferredLicense pkg)++ return $ addPathsModuleToGeneratedModules $ ensureRequiredCabalVersion inferredLicense pkg where nameWarnings :: [String]- packageName_ :: String- (nameWarnings, packageName_) = case packageConfigName of+ packageName :: String+ (nameWarnings, packageName) = case packageConfigName of Nothing -> let inferredName = takeBaseName dir in (["Package name not specified, inferred " ++ show inferredName], inferredName) Just n -> ([], n)@@ -1142,29 +1381,34 @@ f name = "Specified source-dir " ++ show name ++ " does not exist" sourceRepository :: Maybe SourceRepository- sourceRepository = github <|> (`SourceRepository` Nothing) <$> packageConfigGit+ sourceRepository = codeberg <|> github <|> (`SourceRepository` Nothing) <$> packageConfigGit github :: Maybe SourceRepository- github = parseGithub <$> packageConfigGithub+ github = toSourceRepository <$> packageConfigGithub where- parseGithub :: Text -> SourceRepository- parseGithub input = case map T.unpack $ T.splitOn "/" input of- [owner, repo, subdir] ->- SourceRepository (githubBaseUrl ++ owner ++ "/" ++ repo) (Just subdir)- _ -> SourceRepository (githubBaseUrl ++ T.unpack input) Nothing+ toSourceRepository :: GitHub -> SourceRepository+ toSourceRepository (GitHub owner repo subdir) = SourceRepository (githubBaseUrl ++ owner ++ "/" ++ repo) subdir + codeberg :: Maybe SourceRepository+ codeberg = toSourceRepository <$> packageConfigCodeberg+ where+ toSourceRepository :: GitHub -> SourceRepository+ toSourceRepository (GitHub owner repo subdir) = SourceRepository (codebergBaseUrl ++ owner ++ "/" ++ repo) subdir+ homepage :: Maybe String homepage = case packageConfigHomepage of Just Nothing -> Nothing- _ -> join packageConfigHomepage <|> fromGithub+ _ -> join packageConfigHomepage <|> fromCodeberg <|> fromGithub where+ fromCodeberg = (++ "#readme") . sourceRepositoryUrl <$> codeberg fromGithub = (++ "#readme") . sourceRepositoryUrl <$> github bugReports :: Maybe String bugReports = case packageConfigBugReports of Just Nothing -> Nothing- _ -> join packageConfigBugReports <|> fromGithub+ _ -> join packageConfigBugReports <|> fromCodeberg <|> fromGithub where+ fromCodeberg = (++ "/issues") . sourceRepositoryUrl <$> codeberg fromGithub = (++ "/issues") . sourceRepositoryUrl <$> github maintainer :: Maybe (List String)@@ -1174,11 +1418,12 @@ _ -> Nothing expandForeignSources- :: MonadIO m+ :: (MonadIO m, Warnings m) => FilePath- -> Traverse (Warnings m) ParseCSources CSources ParseCxxSources CxxSources ParseJsSources JsSources+ -> Traverse m ParseAsmSources AsmSources ParseCSources CSources ParseCxxSources CxxSources ParseJsSources JsSources expandForeignSources dir = Traverse {- traverseCSources = expand "c-sources"+ traverseAsmSources = expand "asm-sources"+ , traverseCSources = expand "c-sources" , traverseCxxSources = expand "cxx-sources" , traverseJsSources = expand "js-sources" }@@ -1192,7 +1437,7 @@ instance IsString Path where fromString = Path -expandGlobs :: MonadIO m => String -> FilePath -> [String] -> Warnings m [Path]+expandGlobs :: (MonadIO m, Warnings m) => String -> FilePath -> [String] -> m [Path] expandGlobs name dir patterns = map Path <$> do (warnings, files) <- liftIO $ Util.expandGlobs name dir patterns tell warnings@@ -1215,29 +1460,51 @@ where traverseConditionals = traverse . traverse . traverseSectionAndConditionals fConditionals fConditionals -getMentionedLibraryModules :: LibrarySection -> [String]-getMentionedLibraryModules (LibrarySection _ exposedModules generatedExposedModules otherModules generatedOtherModules _ _)+getMentionedLibraryModules :: LibrarySection -> [Module]+getMentionedLibraryModules (LibrarySection _ _ exposedModules generatedExposedModules otherModules generatedOtherModules _ _) = fromMaybeList (exposedModules <> generatedExposedModules <> otherModules <> generatedOtherModules) -listModules :: FilePath -> Section a -> IO [String]+getLibraryModules :: Library -> [Module]+getLibraryModules Library{..} = libraryExposedModules ++ libraryOtherModules++getExecutableModules :: Executable -> [Module]+getExecutableModules Executable{..} = executableOtherModules++listModules :: FilePath -> Section a -> IO [Module] listModules dir Section{..} = concat <$> mapM (getModules dir) sectionSourceDirs -inferModules ::+removeConditionalsThatAreAlwaysFalse :: Section a -> Section a+removeConditionalsThatAreAlwaysFalse sect = sect {+ sectionConditionals = filter p $ sectionConditionals sect+ }+ where+ p = (/= CondBool False) . conditionalCondition++inferModules :: (MonadIO m, State m) => FilePath -> String- -> (a -> [String])- -> (b -> [String])- -> ([String] -> [String] -> a -> b)- -> ([String] -> a -> b)+ -> (a -> [Module])+ -> (b -> [Module])+ -> ([Module] -> [Module] -> a -> b)+ -> ([Module] -> a -> b) -> Section a- -> IO (Section b)-inferModules dir packageName_ getMentionedModules getInferredModules fromData fromConditionals = traverseSectionAndConditionals- (fromConfigSection fromData [pathsModuleFromPackageName packageName_])- (fromConfigSection (\ [] -> fromConditionals) [])- []+ -> m (Section b)+inferModules dir packageName_ getMentionedModules getInferredModules fromData fromConditionals sect_ = do+ specVersion <- State.get+ let+ pathsModule :: [Module]+ pathsModule = case specVersion of+ SpecVersion v | v >= Version.makeVersion [0,36,0] -> []+ _ -> [pathsModuleFromPackageName packageName_]++ removeConditionalsThatAreAlwaysFalse <$> traverseSectionAndConditionals+ (fromConfigSection fromData pathsModule)+ (fromConfigSection (\ [] -> fromConditionals) [])+ []+ sect_ where fromConfigSection fromConfig pathsModule_ outerModules sect@Section{sectionData = conf} = do- modules <- listModules dir sect+ modules <- liftIO $ listModules dir sect let mentionedModules = concatMap getMentionedModules sect inferableModules = (modules \\ outerModules) \\ mentionedModules@@ -1245,22 +1512,20 @@ r = fromConfig pathsModule inferableModules conf return (outerModules ++ getInferredModules r, r) -toLibrary :: FilePath -> String -> Section LibrarySection -> IO (Section Library)+toLibrary :: (MonadIO m, State m) => FilePath -> String -> Section LibrarySection -> m (Section Library) toLibrary dir name = inferModules dir name getMentionedLibraryModules getLibraryModules fromLibrarySectionTopLevel fromLibrarySectionInConditional where- getLibraryModules :: Library -> [String]- getLibraryModules Library{..} = libraryExposedModules ++ libraryOtherModules-+ fromLibrarySectionTopLevel :: [Module] -> [Module] -> LibrarySection -> Library fromLibrarySectionTopLevel pathsModule inferableModules LibrarySection{..} =- Library librarySectionExposed exposedModules otherModules generatedModules reexportedModules signatures+ 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 :: [Module] -> [Module] -> Maybe (List Module) -> Maybe (List Module) -> Maybe (List Module) -> Maybe (List Module) -> ([Module], [Module], [Module]) determineModules pathsModule inferable mExposed mGeneratedExposed mOther mGeneratedOther = (exposed, others, generated) where@@ -1268,8 +1533,8 @@ 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 _ _ _) =+fromLibrarySectionInConditional :: [Module] -> LibrarySection -> Library+fromLibrarySectionInConditional inferableModules lib@(LibrarySection _ _ exposedModules _ otherModules _ _ _) = case (exposedModules, otherModules) of (Nothing, Nothing) -> addToOtherModules inferableModules (fromLibrarySectionPlain lib) _ -> fromLibrarySectionPlain lib@@ -1279,6 +1544,7 @@ fromLibrarySectionPlain :: LibrarySection -> Library fromLibrarySectionPlain LibrarySection{..} = Library { libraryExposed = librarySectionExposed+ , libraryVisibility = librarySectionVisibility , libraryExposedModules = fromMaybeList (librarySectionExposedModules <> librarySectionGeneratedExposedModules) , libraryOtherModules = fromMaybeList (librarySectionOtherModules <> librarySectionGeneratedOtherModules) , libraryGeneratedModules = fromMaybeList (librarySectionGeneratedOtherModules <> librarySectionGeneratedExposedModules)@@ -1286,18 +1552,18 @@ , librarySignatures = fromMaybeList librarySectionSignatures } -getMentionedExecutableModules :: ExecutableSection -> [String]-getMentionedExecutableModules (ExecutableSection main otherModules generatedModules)=- maybe id (:) (main >>= toModule . splitDirectories) $ fromMaybeList (otherModules <> generatedModules)+getMentionedExecutableModules :: ExecutableSection -> [Module]+getMentionedExecutableModules (ExecutableSection (Alias (Last main)) otherModules generatedModules)=+ maybe id (:) (toModule . Path.fromFilePath <$> main) $ fromMaybeList (otherModules <> generatedModules) -toExecutable :: FilePath -> String -> Section ExecutableSection -> IO (Section Executable)+toExecutable :: (MonadIO m, State m) => FilePath -> String -> Section ExecutableSection -> m (Section Executable) toExecutable dir packageName_ =- inferModules dir packageName_ getMentionedExecutableModules executableOtherModules fromExecutableSection (fromExecutableSection [])+ inferModules dir packageName_ getMentionedExecutableModules getExecutableModules fromExecutableSection (fromExecutableSection []) . expandMain where- fromExecutableSection :: [String] -> [String] -> ExecutableSection -> Executable+ fromExecutableSection :: [Module] -> [Module] -> ExecutableSection -> Executable fromExecutableSection pathsModule inferableModules ExecutableSection{..} =- (Executable executableSectionMain (otherModules ++ generatedModules) generatedModules)+ (Executable (getLast $ unAlias executableSectionMain) (otherModules ++ generatedModules) generatedModules) where otherModules = maybe (inferableModules ++ pathsModule) fromList executableSectionOtherModules generatedModules = maybe [] fromList executableSectionGeneratedOtherModules@@ -1310,9 +1576,9 @@ where go exec@ExecutableSection{..} = let- (mainSrcFile, ghcOptions) = maybe (Nothing, []) (first Just . parseMain) executableSectionMain+ (mainSrcFile, ghcOptions) = maybe (Nothing, []) (first Just . parseMain) (getLast $ unAlias executableSectionMain) in- (ghcOptions, exec{executableSectionMain = mainSrcFile})+ (ghcOptions, exec{executableSectionMain = Alias $ Last mainSrcFile}) flatten :: Section ([GhcOption], ExecutableSection) -> Section ExecutableSection flatten sect@Section{sectionData = (ghcOptions, exec), ..} = sect{@@ -1321,22 +1587,29 @@ , sectionConditionals = map (fmap flatten) sectionConditionals } -toSection :: Monad m => String -> [String] -> WithCommonOptions CSources CxxSources JsSources a -> Warnings m (Section a)+toSection :: forall a m. Warnings m => String -> [String] -> WithCommonOptions AsmSources CSources CxxSources JsSources a -> m (Section a) toSection packageName_ executableNames = go where go (Product CommonOptions{..} a) = do- (systemBuildTools, buildTools) <- maybe (return mempty) toBuildTools commonOptionsBuildTools+ (systemBuildTools, buildTools) <- maybe (return mempty) toBuildTools (unAlias commonOptionsBuildTools) conditionals <- mapM toConditional (fromMaybeList commonOptionsWhen) return Section { sectionData = a- , sectionSourceDirs = fromMaybeList commonOptionsSourceDirs+ , sectionSourceDirs = nub $ fromMaybeList (unAlias commonOptionsSourceDirs)+ , sectionDependencies = fromMaybe mempty (unAlias commonOptionsDependencies)+ , sectionPkgConfigDependencies = fromMaybeList (unAlias commonOptionsPkgConfigDependencies) , sectionDefaultExtensions = fromMaybeList commonOptionsDefaultExtensions , sectionOtherExtensions = fromMaybeList commonOptionsOtherExtensions+ , sectionLanguage = join . getLast $ unAlias commonOptionsLanguage+ , sectionMhsOptions = fromMaybeList commonOptionsMhsOptions , sectionGhcOptions = fromMaybeList commonOptionsGhcOptions , sectionGhcProfOptions = fromMaybeList commonOptionsGhcProfOptions+ , sectionGhcSharedOptions = fromMaybeList commonOptionsGhcSharedOptions , sectionGhcjsOptions = fromMaybeList commonOptionsGhcjsOptions , sectionCppOptions = fromMaybeList commonOptionsCppOptions+ , sectionAsmOptions = fromMaybeList commonOptionsAsmOptions+ , sectionAsmSources = commonOptionsAsmSources , sectionCcOptions = fromMaybeList commonOptionsCcOptions , sectionCSources = commonOptionsCSources , sectionCxxOptions = fromMaybeList commonOptionsCxxOptions@@ -1349,33 +1622,30 @@ , sectionIncludeDirs = fromMaybeList commonOptionsIncludeDirs , sectionInstallIncludes = fromMaybeList commonOptionsInstallIncludes , sectionLdOptions = fromMaybeList commonOptionsLdOptions- , sectionBuildable = commonOptionsBuildable- , sectionDependencies = fromMaybe mempty commonOptionsDependencies- , sectionPkgConfigDependencies = fromMaybeList commonOptionsPkgConfigDependencies+ , sectionBuildable = getLast commonOptionsBuildable , 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+ toBuildTools :: BuildTools -> 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 :: ConditionalSection AsmSources CSources CxxSources JsSources a -> m (Conditional (Section a)) toConditional x = case x of- ThenElseConditional (Product (ThenElse then_ else_) c) -> conditional c <$> (go then_) <*> (Just <$> go else_)+ 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+ conditional = Conditional . conditionCondition type SystemBuildTool = (String, VersionConstraint) -toBuildTool :: Monad m => String -> [String] -> (ParseBuildTool, DependencyVersion)- -> Warnings m (Either SystemBuildTool (BuildTool, DependencyVersion))+toBuildTool :: Warnings m => String -> [String] -> (ParseBuildTool, DependencyVersion) -> m (Either SystemBuildTool (BuildTool, DependencyVersion)) toBuildTool packageName_ executableNames = \ case (QualifiedBuildTool pkg executable, v) | pkg == packageName_ && executable `elem` executableNames -> localBuildTool executable v@@ -1417,27 +1687,14 @@ , "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+ warnLegacySystemTool name = tell ["Listing " ++ show name ++ " under build-tools is deprecated! Please list system executables under system-build-tools instead!"] -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+pathsModuleFromPackageName :: String -> Module+pathsModuleFromPackageName name =+ Module ("Paths_" ++ moduleNameFromPackageName name) - removeSetup :: FilePath -> [String] -> [String]- removeSetup src- | src == dir = filter (/= "Setup")- | otherwise = id+moduleNameFromPackageName :: String -> String+moduleNameFromPackageName = map f+ where+ f '-' = '_'+ f x = x
src/Hpack/Defaults.hs view
@@ -12,19 +12,17 @@ #endif ) where -import Network.HTTP.Types+import Imports+ 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.Error import Hpack.Syntax.Defaults -type URL = String- defaultsUrl :: Github -> URL defaultsUrl Github{..} = "https://raw.githubusercontent.com/" ++ githubOwner ++ "/" ++ githubRepo ++ "/" ++ githubRef ++ "/" ++ intercalate "/" githubPath @@ -32,7 +30,7 @@ defaultsCachePath dir Github{..} = joinPath $ dir : "defaults" : githubOwner : githubRepo : githubRef : githubPath -data Result = Found | NotFound | Failed String+data Result = Found | NotFound | Failed Status deriving (Eq, Show) get :: URL -> FilePath -> IO Result@@ -46,12 +44,9 @@ 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+ status -> return (Failed status) -ensure :: FilePath -> FilePath -> Defaults -> IO (Either String FilePath)+ensure :: FilePath -> FilePath -> Defaults -> IO (Either HpackError FilePath) ensure userDataDir dir = \ case DefaultsGithub defaults -> do let@@ -59,14 +54,14 @@ file = defaultsCachePath userDataDir defaults ensureFile file url >>= \ case Found -> return (Right file)- NotFound -> return (Left $ notFound url)- Failed err -> return (Left err)+ NotFound -> notFound url+ Failed status -> return (Left $ DefaultsDownloadFailed url status) DefaultsLocal (Local ((dir </>) -> file)) -> do doesFileExist file >>= \ case True -> return (Right file)- False -> return (Left $ notFound file)+ False -> notFound file where- notFound file = "Invalid value for \"defaults\"! File " ++ file ++ " does not exist!"+ notFound = return . Left . DefaultsFileNotFound ensureFile :: FilePath -> URL -> IO Result ensureFile file url = do
+ src/Hpack/Error.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE LambdaCase #-}+module Hpack.Error (+-- | /__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@).+ HpackError (..)+, formatHpackError+, ProgramName (..)+, URL+, Status (..)+, formatStatus+) where++import qualified Data.ByteString.Char8 as B+import Data.List (intercalate)+import Data.String (IsString (..))+import Data.Version (Version (..), showVersion)+import Network.HTTP.Types.Status (Status (..))++type URL = String++data HpackError =+ HpackVersionNotSupported FilePath Version Version+ | DefaultsFileNotFound FilePath+ | DefaultsDownloadFailed URL Status+ | CycleInDefaults [FilePath]+ | ParseError String+ | DecodeValueError FilePath String+ deriving (Eq, Show)++newtype ProgramName = ProgramName {unProgramName :: String}+ deriving (Eq, Show)++instance IsString ProgramName where+ fromString = ProgramName++formatHpackError :: ProgramName -> HpackError -> String+formatHpackError (ProgramName progName) = \ case+ HpackVersionNotSupported file wanted supported ->+ "The file " ++ file ++ " requires version " ++ showVersion wanted +++ " of the Hpack package specification, however this version of " +++ progName ++ " only supports versions up to " ++ showVersion supported +++ ". Upgrading to the latest version of " ++ progName ++ " may resolve this issue."+ DefaultsFileNotFound file -> "Invalid value for \"defaults\"! File " ++ file ++ " does not exist!"+ DefaultsDownloadFailed url status -> "Error while downloading " ++ url ++ " (" ++ formatStatus status ++ ")"+ CycleInDefaults files -> "cycle in defaults (" ++ intercalate " -> " files ++ ")"+ ParseError err -> err+ DecodeValueError file err -> file ++ ": " ++ err++formatStatus :: Status -> String+formatStatus (Status code message) = show code ++ " " ++ B.unpack message
src/Hpack/Haskell.hs view
@@ -1,5 +1,6 @@ module Hpack.Haskell ( isModule+, isModuleNameComponent , isQualifiedIdentifier , isIdentifier ) where@@ -7,10 +8,10 @@ import Data.Char isModule :: [String] -> Bool-isModule name = (not . null) name && all isModuleName name+isModule name = (not . null) name && all isModuleNameComponent name -isModuleName :: String -> Bool-isModuleName name = case name of+isModuleNameComponent :: String -> Bool+isModuleNameComponent name = case name of x : xs -> isUpper x && all isIdChar xs _ -> False
src/Hpack/License.hs view
@@ -1,15 +1,16 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE LambdaCase #-} module Hpack.License where -import Control.Arrow ((&&&))+import Imports import Distribution.Pretty (prettyShow) import Distribution.Version (mkVersion) import qualified Distribution.License as Cabal import qualified Distribution.SPDX.License as SPDX-import Distribution.Parsec.Class (eitherParsec)+import Distribution.Parsec (eitherParsec) import qualified Data.License.Infer as Infer
+ src/Hpack/Module.hs view
@@ -0,0 +1,113 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE CPP #-}+module Hpack.Module (+ Module(..)+, toModule+, getModules+#ifdef TEST+, getModuleFilesRecursive+#endif+) where++import Imports++import System.FilePath+import qualified System.Directory as Directory++import Data.Aeson.Config.FromValue+import Hpack.Util+import Hpack.Haskell++import Path (Path(..), PathComponent(..))+import qualified Path++newtype Module = Module {unModule :: String}+ deriving (Eq, Ord)++instance Show Module where+ show = show . unModule++instance IsString Module where+ fromString = Module++instance FromValue Module where+ fromValue = fmap Module . fromValue++toModule :: Path -> Module+toModule path = case reverse $ Path.components path of+ [] -> Module ""+ file : dirs -> Module . intercalate "." . reverse $ dropExtension file : dirs++getModules :: FilePath -> FilePath -> IO [Module]+getModules dir literalSrc = sortModules <$> do+ exists <- Directory.doesDirectoryExist (dir </> literalSrc)+ if exists+ then do+ canonicalSrc <- Directory.canonicalizePath (dir </> literalSrc)++ let+ srcIsProjectRoot :: Bool+ srcIsProjectRoot = canonicalSrc == dir++ toModules :: [Path] -> [Module]+ toModules = removeSetup . nub . map toModule++ removeSetup :: [Module] -> [Module]+ removeSetup+ | srcIsProjectRoot = filter (/= "Setup")+ | otherwise = id++ toModules <$> getModuleFilesRecursive canonicalSrc+ else return []++sortModules :: [Module] -> [Module]+sortModules = map Module . sort . map unModule++isSourceFile :: PathComponent -> Bool+isSourceFile (splitExtension . unPathComponent -> (name, ext)) = ext `elem` extensions && isModuleNameComponent name+ where+ extensions :: [String]+ extensions = [+ ".hs"+ , ".lhs"+ , ".chs"+ , ".hsc"+ , ".y"+ , ".ly"+ , ".x"+ ]++isModuleComponent :: PathComponent -> Bool+isModuleComponent = isModuleNameComponent . unPathComponent++getModuleFilesRecursive :: FilePath -> IO [Path]+getModuleFilesRecursive baseDir = go (Path [])+ where+ addBaseDir :: Path -> FilePath+ addBaseDir = (baseDir </>) . Path.toFilePath++ listDirectory :: Path -> IO [PathComponent]+ listDirectory = fmap (map PathComponent) . Directory.listDirectory . addBaseDir++ doesFileExist :: Path -> IO Bool+ doesFileExist = Directory.doesFileExist . addBaseDir++ doesDirectoryExist :: Path -> IO Bool+ doesDirectoryExist = Directory.doesDirectoryExist . addBaseDir++ go :: Path -> IO [Path]+ go dir = do+ entries <- listDirectory dir++ files <- filterWith doesFileExist (filter isSourceFile entries)+ directories <- filterWith doesDirectoryExist (filter isModuleComponent entries)++ subdirsFiles <- concat <$> mapM go directories+ return (files ++ subdirsFiles)+ where+ filterWith :: (Path -> IO Bool) -> [PathComponent] -> IO [Path]+ filterWith p = filterM p . map addDir++ addDir :: PathComponent -> Path+ addDir entry = Path (unPath dir ++ [entry])
src/Hpack/Options.hs view
@@ -1,6 +1,9 @@ {-# LANGUAGE LambdaCase #-} module Hpack.Options where +import Imports++import Data.Maybe import System.FilePath import System.Directory @@ -13,11 +16,16 @@ data Force = Force | NoForce deriving (Eq, Show) +data OutputStrategy = CanonicalOutput | MinimizeDiffs+ deriving (Eq, Show)+ data ParseOptions = ParseOptions { parseOptionsVerbose :: Verbose , parseOptionsForce :: Force+, parseOptionsHash :: Maybe Bool , parseOptionsToStdout :: Bool , parseOptionsTarget :: FilePath+, parseOptionsOutputStrategy :: OutputStrategy } deriving (Eq, Show) parseOptions :: FilePath -> [String] -> IO ParseResult@@ -30,18 +38,34 @@ file <- expandTarget defaultTarget target let options- | toStdout = ParseOptions NoVerbose Force toStdout file- | otherwise = ParseOptions verbose force toStdout file+ | toStdout = ParseOptions NoVerbose Force hash toStdout file outputStrategy+ | otherwise = ParseOptions verbose force hash toStdout file outputStrategy return (Run options) Left err -> return err where silentFlag = "--silent" forceFlags = ["--force", "-f"]+ hashFlag = "--hash"+ noHashFlag = "--no-hash"+ canonicalFlag = "--canonical" - flags = silentFlag : forceFlags+ flags = canonicalFlag : hashFlag : noHashFlag : silentFlag : forceFlags + verbose :: Verbose verbose = if silentFlag `elem` args then NoVerbose else Verbose++ outputStrategy :: OutputStrategy+ outputStrategy = if canonicalFlag `elem` args then CanonicalOutput else MinimizeDiffs++ 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)
src/Hpack/Render.hs view
@@ -23,6 +23,7 @@ , Alignment(..) , CommaStyle(..) #ifdef TEST+, RenderEnv(..) , renderConditional , renderDependencies , renderLibraryFields@@ -30,44 +31,64 @@ , renderFlag , renderSourceRepository , renderDirectories-, formatDescription #endif ) where -import Control.Monad+import Imports+ import Data.Char import Data.Maybe-import Data.List import Data.Map.Lazy (Map) import qualified Data.Map.Lazy as Map+import Control.Monad.Reader -import Hpack.Util import Hpack.Config import Hpack.Render.Hints-import Hpack.Render.Dsl-import Hpack.Syntax.Dependencies+import Hpack.Render.Dsl hiding (RenderSettings(..), defaultRenderSettings, sortFieldsBy)+import qualified Hpack.Render.Dsl as Dsl +data RenderEnv = RenderEnv {+ renderEnvCabalVersion :: CabalVersion+, renderEnvPackageName :: String+}++type RenderM = Reader RenderEnv++getCabalVersion :: RenderM CabalVersion+getCabalVersion = asks renderEnvCabalVersion++getPackageName :: RenderM String+getPackageName = asks renderEnvPackageName+ renderPackage :: [String] -> Package -> String-renderPackage oldCabalFile = renderPackageWith settings alignment formattingHintsFieldOrder formattingHintsSectionsFieldOrder+renderPackage oldCabalFile = renderPackageWith settings headerFieldsAlignment formattingHintsFieldOrder formattingHintsSectionsFieldOrder where- FormattingHints{..} = sniffFormattingHints oldCabalFile- alignment = fromMaybe 16 formattingHintsAlignment- settings = formattingHintsRenderSettings+ hints@FormattingHints{..} = sniffFormattingHints oldCabalFile+ headerFieldsAlignment = fromMaybe 16 formattingHintsAlignment+ settings = formattingHintsRenderSettings hints renderPackageWith :: RenderSettings -> Alignment -> [String] -> [(String, [String])] -> Package -> String-renderPackageWith settings headerFieldsAlignment existingFieldOrder sectionsFieldOrder Package{..} = intercalate "\n" (unlines header : chunks)+renderPackageWith RenderSettings{..} headerFieldsAlignment existingFieldOrder sectionsFieldOrder Package{..} = intercalate "\n" (unlines header : chunks) where+ settings :: Dsl.RenderSettings+ settings = Dsl.RenderSettings {+ renderSettingsEmptyLinesAsDot = packageCabalVersion < makeCabalVersion [3]+ , ..+ }+ 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+ header = concatMap (render settings {Dsl.renderSettingsFieldAlignment = headerFieldsAlignment} 0) packageFields packageFields :: [Element] packageFields = addVerbatim packageVerbatim . sortFieldsBy existingFieldOrder $ headerFields ++ [- Field "extra-source-files" (renderPaths packageExtraSourceFiles)+ Field "tested-with" $ CommaSeparatedList packageTestedWith+ , Field "extra-source-files" (renderPaths packageExtraSourceFiles) , Field "extra-doc-files" (renderPaths packageExtraDocFiles)+ , Field "extra-files" (renderPaths packageExtraFiles) , Field "data-files" (renderPaths packageDataFiles) ] ++ maybe [] (return . Field "data-dir" . Literal) packageDataDir @@ -77,46 +98,52 @@ 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- ]+ stanzas = flip runReader (RenderEnv packageCabalVersion packageName) $ do+ library <- maybe (return []) (fmap return . renderLibrary) packageLibrary+ internalLibraries <- renderInternalLibraries packageInternalLibraries+ executables <- renderExecutables packageExecutables+ tests <- renderTests packageTests+ benchmarks <- renderBenchmarks packageBenchmarks+ return $ concat [+ sourceRepository+ , customSetup+ , map renderFlag packageFlags+ , library+ , internalLibraries+ , executables+ , tests+ , benchmarks+ ] headerFields :: [Element] headerFields = mapMaybe (\(name, value) -> Field name . Literal <$> value) $ [ ("name", Just packageName) , ("version", Just packageVersion) , ("synopsis", packageSynopsis)- , ("description", (formatDescription headerFieldsAlignment <$> packageDescription))- , ("category", packageCategory)+ , ("description", packageDescription)+ , formatList "category" packageCategory , ("stability", packageStability) , ("homepage", packageHomepage) , ("bug-reports", packageBugReports)- , ("author", formatList packageAuthor)- , ("maintainer", formatList packageMaintainer)- , ("copyright", formatList packageCopyright)+ , formatList "author" packageAuthor+ , formatList "maintainer" packageMaintainer+ , formatList "copyright" packageCopyright , ("license", packageLicense) , case packageLicenseFile of [file] -> ("license-file", Just file)- files -> ("license-files", formatList files)- , ("tested-with", packageTestedWith)+ files -> formatList "license-files" files , ("build-type", Just (show packageBuildType)) ] - formatList :: [String] -> Maybe String- formatList xs = guard (not $ null xs) >> (Just $ intercalate separator xs)+ formatList :: String -> [String] -> (String, Maybe String)+ formatList field = (,) field . formatValues where- separator = let Alignment n = headerFieldsAlignment in ",\n" ++ replicate n ' '+ formatValues :: [String] -> Maybe String+ formatValues values = guard (not $ null values) >> (Just $ intercalate separator values)+ where+ separator :: String+ separator = ",\n" sortStanzaFields :: [(String, [String])] -> [Element] -> [Element] sortStanzaFields sectionsFieldOrder = go@@ -126,20 +153,6 @@ 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"@@ -155,38 +168,38 @@ where description = maybe [] (return . Field "description" . Literal) flagDescription -renderInternalLibraries :: Map String (Section Library) -> [Element]-renderInternalLibraries = map renderInternalLibrary . Map.toList+renderInternalLibraries :: Map String (Section Library) -> RenderM [Element]+renderInternalLibraries = traverse renderInternalLibrary . Map.toList -renderInternalLibrary :: (String, Section Library) -> Element-renderInternalLibrary (name, sect) =- Stanza ("library " ++ name) (renderLibrarySection sect)+renderInternalLibrary :: (String, Section Library) -> RenderM Element+renderInternalLibrary (name, sect) = do+ Stanza ("library " ++ name) <$> renderLibrarySection sect -renderExecutables :: Map String (Section Executable) -> [Element]-renderExecutables = map renderExecutable . Map.toList+renderExecutables :: Map String (Section Executable) -> RenderM [Element]+renderExecutables = traverse renderExecutable . Map.toList -renderExecutable :: (String, Section Executable) -> Element-renderExecutable (name, sect@(sectionData -> Executable{..})) =- Stanza ("executable " ++ name) (renderExecutableSection [] sect)+renderExecutable :: (String, Section Executable) -> RenderM Element+renderExecutable (name, sect) = do+ Stanza ("executable " ++ name) <$> renderExecutableSection [] sect -renderTests :: Map String (Section Executable) -> [Element]-renderTests = map renderTest . Map.toList+renderTests :: Map String (Section Executable) -> RenderM [Element]+renderTests = traverse renderTest . Map.toList -renderTest :: (String, Section Executable) -> Element-renderTest (name, sect) =- Stanza ("test-suite " ++ name)- (renderExecutableSection [Field "type" "exitcode-stdio-1.0"] sect)+renderTest :: (String, Section Executable) -> RenderM Element+renderTest (name, sect) = do+ Stanza ("test-suite " ++ name) <$>+ renderExecutableSection [Field "type" "exitcode-stdio-1.0"] sect -renderBenchmarks :: Map String (Section Executable) -> [Element]-renderBenchmarks = map renderBenchmark . Map.toList+renderBenchmarks :: Map String (Section Executable) -> RenderM [Element]+renderBenchmarks = traverse renderBenchmark . Map.toList -renderBenchmark :: (String, Section Executable) -> Element-renderBenchmark (name, sect) =- Stanza ("benchmark " ++ name)- (renderExecutableSection [Field "type" "exitcode-stdio-1.0"] sect)+renderBenchmark :: (String, Section Executable) -> RenderM Element+renderBenchmark (name, sect) = do+ Stanza ("benchmark " ++ name) <$>+ renderExecutableSection [Field "type" "exitcode-stdio-1.0"] sect -renderExecutableSection :: [Element] -> Section Executable -> [Element]-renderExecutableSection extraFields = renderSection renderExecutableFields extraFields [defaultLanguage]+renderExecutableSection :: [Element] -> Section Executable -> RenderM [Element]+renderExecutableSection extraFields = renderSection renderExecutableFields extraFields renderExecutableFields :: Executable -> [Element] renderExecutableFields Executable{..} = mainIs ++ [otherModules, generatedModules]@@ -199,15 +212,16 @@ renderCustomSetup CustomSetup{..} = Stanza "custom-setup" $ renderDependencies "setup-depends" customSetupDependencies -renderLibrary :: Section Library -> Element-renderLibrary sect = Stanza "library" $ renderLibrarySection sect+renderLibrary :: Section Library -> RenderM Element+renderLibrary sect = Stanza "library" <$> renderLibrarySection sect -renderLibrarySection :: Section Library -> [Element]-renderLibrarySection = renderSection renderLibraryFields [] [defaultLanguage]+renderLibrarySection :: Section Library -> RenderM [Element]+renderLibrarySection = renderSection renderLibraryFields [] renderLibraryFields :: Library -> [Element] renderLibraryFields Library{..} =- maybe [] (return . renderExposed) libraryExposed ++ [+ maybe [] (return . renderExposed) libraryExposed +++ maybe [] (return . renderVisibility) libraryVisibility ++ [ renderExposedModules libraryExposedModules , renderOtherModules libraryOtherModules , renderGeneratedModules libraryGeneratedModules@@ -218,37 +232,48 @@ renderExposed :: Bool -> Element renderExposed = Field "exposed" . Literal . show -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+renderVisibility :: String -> Element+renderVisibility = Field "visibility" . Literal +renderSection :: (a -> [Element]) -> [Element] -> Section a -> RenderM [Element]+renderSection renderSectionData extraFieldsStart Section{..} = do+ buildTools <- renderBuildTools sectionBuildTools sectionSystemBuildTools+ conditionals <- traverse (renderConditional renderSectionData) sectionConditionals+ return . addVerbatim sectionVerbatim $+ extraFieldsStart+ ++ renderSectionData sectionData+ ++ [+ renderDirectories "hs-source-dirs" sectionSourceDirs+ , renderDefaultExtensions sectionDefaultExtensions+ , renderOtherExtensions sectionOtherExtensions+ , Field "mhs-options" $ WordList sectionMhsOptions+ , Field "ghc-options" $ WordList sectionGhcOptions+ , Field "ghc-prof-options" $ WordList sectionGhcProfOptions+ , Field "ghc-shared-options" $ WordList sectionGhcSharedOptions+ , Field "ghcjs-options" $ WordList sectionGhcjsOptions+ , Field "cpp-options" $ WordList sectionCppOptions+ , Field "asm-options" $ WordList sectionAsmOptions+ , Field "cc-options" $ WordList sectionCcOptions+ , Field "cxx-options" $ WordList sectionCxxOptions+ , renderDirectories "include-dirs" sectionIncludeDirs+ , Field "install-includes" (LineSeparatedList sectionInstallIncludes)+ , Field "asm-sources" (renderPaths sectionAsmSources)+ , 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)+ , Field "ld-options" $ WordList sectionLdOptions+ , Field "pkgconfig-depends" (CommaSeparatedList sectionPkgConfigDependencies)+ ]+ ++ buildTools+ ++ renderDependencies "build-depends" sectionDependencies+ ++ maybe [] (return . renderBuildable) sectionBuildable+ ++ maybe [] (return . renderLanguage) sectionLanguage+ ++ conditionals+ addVerbatim :: [Verbatim] -> [Element] -> [Element] addVerbatim verbatim fields = filterVerbatim verbatim fields ++ renderVerbatim verbatim @@ -278,35 +303,38 @@ [x] -> Field key (Literal x) xs -> Field key (LineSeparatedList xs) -renderConditional :: (a -> [Element]) -> Conditional (Section a) -> Element+renderConditional :: (a -> [Element]) -> Conditional (Section a) -> RenderM Element renderConditional renderSectionData (Conditional condition sect mElse) = case mElse of Nothing -> if_- Just else_ -> Group if_ (Stanza "else" $ renderSection renderSectionData [] [] else_)+ Just else_ -> Group <$> if_ <*> (Stanza "else" <$> renderSection renderSectionData [] else_) where- if_ = Stanza ("if " ++ condition) (renderSection renderSectionData [] [] sect)+ if_ = Stanza ("if " ++ renderCond condition) <$> renderSection renderSectionData [] sect -defaultLanguage :: Element-defaultLanguage = Field "default-language" "Haskell2010"+renderCond :: Cond -> String+renderCond = \ case+ CondExpression c -> c+ CondBool True -> "true"+ CondBool False -> "false" 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+renderExposedModules :: [Module] -> Element+renderExposedModules = Field "exposed-modules" . LineSeparatedList . map unModule -renderOtherModules :: [String] -> Element-renderOtherModules = Field "other-modules" . LineSeparatedList+renderOtherModules :: [Module] -> Element+renderOtherModules = Field "other-modules" . LineSeparatedList . map unModule -renderGeneratedModules :: [String] -> Element-renderGeneratedModules = Field "autogen-modules" . LineSeparatedList+renderGeneratedModules :: [Module] -> Element+renderGeneratedModules = Field "autogen-modules" . LineSeparatedList . map unModule renderReexportedModules :: [String] -> Element-renderReexportedModules = Field "reexported-modules" . LineSeparatedList+renderReexportedModules = Field "reexported-modules" . CommaSeparatedList renderSignatures :: [String] -> Element renderSignatures = Field "signatures" . CommaSeparatedList@@ -333,21 +361,32 @@ 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])- ]+renderBuildTools :: Map BuildTool DependencyVersion -> SystemBuildTools -> RenderM [Element]+renderBuildTools buildTools systemBuildTools = do+ xs <- traverse renderBuildTool $ Map.toList buildTools+ return [+ 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)+renderBuildTool :: (BuildTool, DependencyVersion) -> RenderM RenderBuildTool+renderBuildTool (buildTool, renderVersion -> version) = do+ cabalVersion <- getCabalVersion+ packageName <- getPackageName+ let supportsBuildTools = cabalVersion < makeCabalVersion [2]+ return $ case buildTool of+ LocalBuildTool executable+ | supportsBuildTools -> BuildTools (executable ++ version)+ | otherwise -> BuildToolDepends (packageName ++ ":" ++ executable ++ version)+ BuildTool pkg executable+ | supportsBuildTools && isknownBuildTool pkg executable -> BuildTools (executable ++ version)+ | otherwise -> BuildToolDepends (pkg ++ ":" ++ executable ++ version) where+ isknownBuildTool :: String -> String -> Bool+ isknownBuildTool pkg executable = pkg == executable && executable `elem` knownBuildTools+ knownBuildTools :: [String] knownBuildTools = [ "alex"@@ -366,35 +405,17 @@ 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+renderLanguage :: Language -> Element+renderLanguage (Language lang) = Field "default-language" (Literal lang) renderBuildable :: Bool -> Element renderBuildable = Field "buildable" . Literal . show renderDefaultExtensions :: [String] -> Element-renderDefaultExtensions = Field "default-extensions" . WordList+renderDefaultExtensions = Field "default-extensions" . LineSeparatedList renderOtherExtensions :: [String] -> Element-renderOtherExtensions = Field "other-extensions" . WordList+renderOtherExtensions = Field "other-extensions" . LineSeparatedList renderPaths :: [Path] -> Value renderPaths = LineSeparatedList . map renderPath@@ -406,3 +427,6 @@ needsQuoting :: FilePath -> Bool needsQuoting = any (\x -> isSpace x || x == ',')++sortFieldsBy :: [String] -> [Element] -> [Element]+sortFieldsBy existingFieldOrder = Dsl.sortFieldsBy ("import" : existingFieldOrder)
src/Hpack/Render/Dsl.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Hpack.Render.Dsl (@@ -19,14 +20,18 @@ #ifdef TEST , Lines (..)+, IndentOrAlign (..) , renderValue , addSortKey #endif ) where -import Data.String-import Data.List+import Imports+import Data.Char (isSpace) +data Element = Stanza String [Element] | Group Element Element | Field String Value | Verbatim String+ deriving (Eq, Show)+ data Value = Literal String | CommaSeparatedList [String]@@ -34,10 +39,26 @@ | WordList [String] deriving (Eq, Show) -data Element = Stanza String [Element] | Group Element Element | Field String Value | Verbatim String+data Lines = SingleLine String | MultipleLines IndentOrAlign [String] deriving (Eq, Show) -data Lines = SingleLine String | MultipleLines [String]+data IndentOrAlign =+ Indent+ -- ^+ -- Indent lines, e.g.+ --+ -- description:+ -- some+ -- multiline+ -- description+ |+ Align+ -- ^+ -- Align lines with field labels, e.g.+ --+ -- description: some+ -- multiline+ -- description deriving (Eq, Show) data CommaStyle = LeadingCommas | TrailingCommas@@ -47,52 +68,78 @@ deriving (Eq, Show, Num, Enum) newtype Alignment = Alignment Int- deriving (Eq, Show, Num)+ deriving (Eq, Ord, Show, Num) data RenderSettings = RenderSettings { renderSettingsIndentation :: Int , renderSettingsFieldAlignment :: Alignment , renderSettingsCommaStyle :: CommaStyle+, renderSettingsEmptyLinesAsDot :: Bool } deriving (Eq, Show) defaultRenderSettings :: RenderSettings-defaultRenderSettings = RenderSettings 2 0 LeadingCommas+defaultRenderSettings = RenderSettings 2 0 LeadingCommas True 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)+render settings nesting = \ case+ Stanza name elements -> indent settings nesting name : renderElements settings (succ nesting) elements+ Group a b -> render settings nesting a ++ render settings nesting b+ Field name value -> map (indent settings nesting) $ renderField settings name value+ 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+renderField :: RenderSettings -> String -> Value -> [String]+renderField settings@RenderSettings{..} name = renderValue settings >>> \ case SingleLine "" -> []- SingleLine x -> [indent settings nesting (name ++ ": " ++ padding ++ x)]- MultipleLines [] -> []- MultipleLines xs -> (indent settings nesting name ++ ":") : map (indent settings $ succ nesting) xs+ SingleLine value -> [fieldName ++ value]+ MultipleLines _ [] -> []+ MultipleLines Indent values -> (name ++ ":") : map (indent settings 1) values+ MultipleLines Align (value : values) -> (fieldName ++ value) : map align values where Alignment fieldAlignment = renderSettingsFieldAlignment- padding = replicate (fieldAlignment - length name - 2) ' ' + fieldName :: String+ fieldName = name ++ ": " ++ fieldNamePadding++ fieldNamePadding :: String+ fieldNamePadding = replicate (fieldAlignment - length name - 2) ' '++ align :: String -> String+ align = \ case+ "" -> ""+ value -> padding ++ value++ padding :: String+ padding = replicate (length fieldName) ' '+ renderValue :: RenderSettings -> Value -> Lines-renderValue RenderSettings{..} v = case v of- Literal s -> SingleLine s+renderValue RenderSettings{..} = \ case+ Literal string -> case lines string of+ [value] -> SingleLine value+ values -> MultipleLines Align $ map emptyLineToDot values WordList ws -> SingleLine $ unwords ws LineSeparatedList xs -> renderLineSeparatedList renderSettingsCommaStyle xs CommaSeparatedList xs -> renderCommaSeparatedList renderSettingsCommaStyle xs+ where+ emptyLineToDot :: String -> String+ emptyLineToDot xs+ | isEmptyLine xs && renderSettingsEmptyLinesAsDot = "."+ | otherwise = xs + isEmptyLine :: String -> Bool+ isEmptyLine = all isSpace+ renderLineSeparatedList :: CommaStyle -> [String] -> Lines-renderLineSeparatedList style = MultipleLines . map (padding ++)+renderLineSeparatedList style = MultipleLines Indent . map (padding ++) where padding = case style of LeadingCommas -> " " TrailingCommas -> "" renderCommaSeparatedList :: CommaStyle -> [String] -> Lines-renderCommaSeparatedList style = MultipleLines . case style of+renderCommaSeparatedList style = MultipleLines Indent . case style of LeadingCommas -> map renderLeadingComma . zip (True : repeat False) TrailingCommas -> map renderTrailingComma . reverse . zip (True : repeat False) . reverse where@@ -110,7 +157,9 @@ fromString = Literal indent :: RenderSettings -> Nesting -> String -> String-indent RenderSettings{..} (Nesting nesting) s = replicate (nesting * renderSettingsIndentation) ' ' ++ s+indent RenderSettings{..} (Nesting nesting) = \ case+ "" -> ""+ s -> replicate (nesting * renderSettingsIndentation) ' ' ++ s sortFieldsBy :: [String] -> [Element] -> [Element] sortFieldsBy existingFieldOrder =
src/Hpack/Render/Hints.hs view
@@ -1,8 +1,12 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE RecordWildCards #-} module Hpack.Render.Hints ( FormattingHints (..) , sniffFormattingHints+, RenderSettings (..)+, defaultRenderSettings+, formattingHintsRenderSettings #ifdef TEST , extractFieldOrder , extractSectionsFieldOrder@@ -15,18 +19,21 @@ #endif ) where +import Imports+ import Data.Char import Data.Maybe-import Data.List-import Control.Applicative -import Hpack.Render.Dsl+import Hpack.Render.Dsl (Alignment(..), CommaStyle(..))+import qualified Hpack.Render.Dsl as Dsl+import Hpack.Util data FormattingHints = FormattingHints { formattingHintsFieldOrder :: [String] , formattingHintsSectionsFieldOrder :: [(String, [String])] , formattingHintsAlignment :: Maybe Alignment-, formattingHintsRenderSettings :: RenderSettings+, formattingHintsIndentation :: Maybe Int+, formattingHintsCommaStyle :: Maybe CommaStyle } deriving (Eq, Show) sniffFormattingHints :: [String] -> FormattingHints@@ -34,7 +41,8 @@ formattingHintsFieldOrder = extractFieldOrder input , formattingHintsSectionsFieldOrder = extractSectionsFieldOrder input , formattingHintsAlignment = sniffAlignment input-, formattingHintsRenderSettings = sniffRenderSettings input+, formattingHintsIndentation = sniffIndentation input+, formattingHintsCommaStyle = sniffCommaStyle input } sanitize :: [String] -> [String]@@ -66,16 +74,32 @@ where indentation = minimum $ map (length . takeWhile isSpace) input +data Indentation = Indentation {+ indentationFieldNameLength :: Int+, indentationPadding :: Int+}++indentationTotal :: Indentation -> Int+indentationTotal (Indentation fieldName padding) = fieldName + padding+ sniffAlignment :: [String] -> Maybe Alignment-sniffAlignment input = case nub . catMaybes . map indentation . catMaybes . map splitField $ input of- [n] -> Just (Alignment n)- _ -> Nothing+sniffAlignment input = case indentations of+ [] -> Nothing+ _ | all (indentationPadding >>> (== 1)) indentations -> Just 0+ _ -> case nub (map indentationTotal indentations) of+ [n] -> Just (Alignment n)+ _ -> Nothing where+ indentations :: [Indentation]+ indentations = catMaybes . map (splitField >=> indentation) $ input - indentation :: (String, String) -> Maybe Int+ indentation :: (String, String) -> Maybe Indentation indentation (name, value) = case span isSpace value of (_, "") -> Nothing- (xs, _) -> (Just . succ . length $ name ++ xs)+ (padding, _) -> Just Indentation {+ indentationFieldNameLength = succ $ length name+ , indentationPadding = length padding+ } splitField :: String -> Maybe (String, String) splitField field = case span isNameChar field of@@ -106,9 +130,20 @@ 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)+data RenderSettings = RenderSettings {+ renderSettingsIndentation :: Int+, renderSettingsFieldAlignment :: Alignment+, renderSettingsCommaStyle :: CommaStyle+} deriving (Eq, Show)++defaultRenderSettings :: RenderSettings+defaultRenderSettings = let Dsl.RenderSettings{..} = Dsl.defaultRenderSettings in RenderSettings{..}++formattingHintsRenderSettings :: FormattingHints -> RenderSettings+formattingHintsRenderSettings FormattingHints{..} = defaultRenderSettings {+ renderSettingsIndentation = indentation+, renderSettingsCommaStyle = commaStyle+} where+ indentation = max def $ fromMaybe def formattingHintsIndentation+ where def = renderSettingsIndentation defaultRenderSettings+ commaStyle = fromMaybe (renderSettingsCommaStyle defaultRenderSettings) formattingHintsCommaStyle
src/Hpack/Syntax/BuildTools.hs view
@@ -7,11 +7,10 @@ , SystemBuildTools(..) ) where -import Data.Text (Text)+import Imports++import qualified Control.Monad.Fail as Fail 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@@ -53,7 +52,7 @@ buildToolFromString :: Text -> Parser (ParseBuildTool, DependencyVersion) buildToolFromString s = parseQualifiedBuildTool s <|> parseUnqualifiedBuildTool s - parseQualifiedBuildTool :: Monad m => Text -> m (ParseBuildTool, DependencyVersion)+ parseQualifiedBuildTool :: Fail.MonadFail m => Text -> m (ParseBuildTool, DependencyVersion) parseQualifiedBuildTool = fmap fromCabal . cabalParse "build tool" . T.unpack where fromCabal :: D.ExeDependency -> (ParseBuildTool, DependencyVersion)@@ -62,7 +61,7 @@ , DependencyVersion Nothing $ versionConstraintFromCabal version ) - parseUnqualifiedBuildTool :: Monad m => Text -> m (ParseBuildTool, DependencyVersion)+ parseUnqualifiedBuildTool :: Fail.MonadFail m => Text -> m (ParseBuildTool, DependencyVersion) parseUnqualifiedBuildTool = fmap (first UnqualifiedBuildTool) . parseDependency "build tool" newtype SystemBuildTools = SystemBuildTools {@@ -80,7 +79,7 @@ , parseName = T.unpack } - parseSystemBuildTool :: Monad m => Text -> m (String, VersionConstraint)+ parseSystemBuildTool :: Fail.MonadFail m => Text -> m (String, VersionConstraint) parseSystemBuildTool = fmap fromCabal . cabalParse "system build tool" . T.unpack where fromCabal :: D.LegacyExeDependency -> (String, VersionConstraint)
src/Hpack/Syntax/Defaults.hs view
@@ -13,8 +13,9 @@ #endif ) where -import Data.HashMap.Lazy (member)-import Data.List+import Imports++import Data.Aeson.Config.KeyMap (member) import qualified Data.Text as T import System.FilePath.Posix (splitDirectories)
src/Hpack/Syntax/Dependencies.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-}@@ -7,14 +8,23 @@ , parseDependency ) where -import Data.Text (Text)+import Imports++import qualified Control.Monad.Fail as Fail 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 +#if MIN_VERSION_Cabal(3,4,0)+import qualified Distribution.Compat.NonEmptySet as DependencySet+#else+import qualified Data.Set as DependencySet+#endif+ import Data.Aeson.Config.FromValue import Data.Aeson.Config.Types @@ -46,7 +56,7 @@ data DependencyInfo = DependencyInfo { dependencyInfoMixins :: [String] , dependencyInfoVersion :: DependencyVersion-} deriving (Eq, Show)+} deriving (Eq, Ord, Show) addMixins :: Object -> DependencyVersion -> Parser DependencyInfo addMixins o version = do@@ -59,8 +69,19 @@ dependencyInfo :: Value -> Parser DependencyInfo dependencyInfo = withDependencyVersion (DependencyInfo []) addMixins -parseDependency :: Monad m => String -> Text -> m (String, DependencyVersion)+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 = (D.unPackageName $ D.depPkgName d, DependencyVersion Nothing . versionConstraintFromCabal $ D.depVerRange d)+ fromCabal (D.Dependency pkgName verRange libraries) =+ (depName, DependencyVersion Nothing $ versionConstraintFromCabal verRange)+ where+ depName :: String+ depName = prettyShow pkgName <> case DependencySet.toList libraries of+ [D.LMainLibName] -> ""+ [D.LSubLibName name] -> ":" <> prettyShow name+ xs -> ":{" <> intercalate "," (map renderComponent xs) <> "}"++ renderComponent :: D.LibraryName -> String+ renderComponent D.LMainLibName = prettyShow pkgName+ renderComponent (D.LSubLibName name) = prettyShow name
src/Hpack/Syntax/DependencyVersion.hs view
@@ -1,7 +1,10 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ViewPatterns #-} module Hpack.Syntax.DependencyVersion ( githubBaseUrl+, codebergBaseUrl , GitRef , GitUrl @@ -23,29 +26,34 @@ , cabalParse ) where -import Control.Applicative+import Imports++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 qualified Data.Aeson.Config.KeyMap as KeyMap import Text.PrettyPrint (renderStyle, Style(..), Mode(..)) -import Distribution.Version (VersionRangeF(..))-import qualified Distribution.Text as D import qualified Distribution.Version as D-import qualified Distribution.Parsec.Class as D +import qualified Distribution.Parsec as D+import qualified Distribution.Pretty as D+import qualified Distribution.Types.VersionRange.Internal as D+ import Data.Aeson.Config.FromValue githubBaseUrl :: String githubBaseUrl = "https://github.com/" +codebergBaseUrl :: String+codebergBaseUrl = "https://codeberg.org/"+ type GitUrl = String type GitRef = String data VersionConstraint = AnyVersion | VersionRange String- deriving (Eq, Show)+ deriving (Eq, Ord, Show) instance FromValue VersionConstraint where fromValue = versionConstraint@@ -64,7 +72,7 @@ versionRange = DependencyVersion Nothing . VersionRange data DependencyVersion = DependencyVersion (Maybe SourceDependency) VersionConstraint- deriving (Eq, Show)+ deriving (Eq, Ord, Show) withDependencyVersion :: (DependencyVersion -> a)@@ -82,7 +90,7 @@ dependencyVersion = withDependencyVersion id (const return) data SourceDependency = GitRef GitUrl GitRef (Maybe FilePath) | Local FilePath- deriving (Eq, Show)+ deriving (Eq, Ord, Show) objectDependency :: Object -> Parser DependencyVersion objectDependency o = let@@ -109,7 +117,7 @@ source :: Parser (Maybe SourceDependency) source- | any (`HashMap.member` o) ["path", "git", "github", "ref", "subdir"] = Just <$> (local <|> git)+ | any (`KeyMap.member` o) ["path", "git", "github", "ref", "subdir"] = Just <$> (local <|> git) | otherwise = return Nothing in DependencyVersion <$> source <*> version@@ -133,41 +141,53 @@ | otherwise = 0 e = base10Exponent n -parseVersionRange :: Monad m => String -> m VersionConstraint+parseVersionRange :: Fail.MonadFail m => String -> m VersionConstraint parseVersionRange = fmap versionConstraintFromCabal . parseCabalVersionRange -parseCabalVersionRange :: Monad m => String -> m D.VersionRange+parseCabalVersionRange :: Fail.MonadFail m => String -> m D.VersionRange parseCabalVersionRange = cabalParse "constraint" -cabalParse :: (Monad m, D.Parsec a) => String -> String -> m a+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] +renderVersionRange :: D.VersionRange -> String+renderVersionRange = \ case+ D.IntersectVersionRanges (D.OrLaterVersion x) (D.EarlierVersion y) | differByOneInLeastPosition (x, y) -> "==" ++ render x ++ ".*"+ v -> render v+ where+ differByOneInLeastPosition = \ case+ (reverse . D.versionNumbers -> x : xs, reverse . D.versionNumbers -> y : ys) -> xs == ys && succ x == y+ _ -> False++render :: D.Pretty a => a -> String+render = renderStyle (Style OneLineMode 0 0) . D.pretty+ versionConstraintFromCabal :: D.VersionRange -> VersionConstraint versionConstraintFromCabal range | D.isAnyVersion range = AnyVersion- | otherwise = VersionRange . renderStyle style . D.disp $ toPreCabal2VersionRange range+ | otherwise = VersionRange . renderVersionRange $ 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 :: D.VersionRangeF (D.VersionRangeF D.VersionRange) -> D.VersionRangeF D.VersionRange f = \ case- MajorBoundVersionF v -> IntersectVersionRangesF (D.embedVersionRange lower) (D.embedVersionRange upper)+ D.MajorBoundVersionF v -> D.IntersectVersionRangesF (D.embedVersionRange lower) (D.embedVersionRange upper) where- lower = OrLaterVersionF v- upper = EarlierVersionF (D.majorUpperBound v)+ lower = D.OrLaterVersionF v+ upper = D.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)+ D.ThisVersionF v -> D.ThisVersionF v+ D.LaterVersionF v -> D.LaterVersionF v+ D.OrLaterVersionF v -> D.OrLaterVersionF v+ D.EarlierVersionF v -> D.EarlierVersionF v+ D.OrEarlierVersionF v -> D.OrEarlierVersionF v+ D.UnionVersionRangesF a b -> D.UnionVersionRangesF (D.embedVersionRange a) (D.embedVersionRange b)+ D.IntersectVersionRangesF a b -> D.IntersectVersionRangesF (D.embedVersionRange a) (D.embedVersionRange b)+#if !MIN_VERSION_Cabal(3,4,0)+ D.WildcardVersionF v -> D.WildcardVersionF v+ D.VersionRangeParensF a -> D.VersionRangeParensF (D.embedVersionRange a)+ D.AnyVersionF -> D.AnyVersionF+#endif
src/Hpack/Syntax/Git.hs view
@@ -2,8 +2,9 @@ isValidRef ) where +import Imports+ import Data.Char (chr)-import Data.List import System.FilePath.Posix -- https://git-scm.com/docs/git-check-ref-format
src/Hpack/Syntax/ParseDependencies.hs view
@@ -2,9 +2,10 @@ {-# LANGUAGE RecordWildCards #-} module Hpack.Syntax.ParseDependencies where -import Data.Text (Text)-import Data.Bifunctor+import Imports+ import Data.Aeson.Config.FromValue+import qualified Data.Aeson.Config.Key as Key data Parse k v = Parse { parseString :: Text -> Parser (k, v)@@ -17,7 +18,7 @@ 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+ Object o -> map (first (parseName . Key.toText)) <$> traverseObject parseDictItem o _ -> typeMismatch "Array, Object, or String" v buildToolFromValue :: Parse k v -> Value -> Parser (k, v)
src/Hpack/Utf8.hs view
@@ -1,7 +1,9 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-} module Hpack.Utf8 ( encodeUtf8 , readFile-, writeFile+, ensureFile , putStr , hPutStr , hPutStrLn@@ -9,6 +11,8 @@ import Prelude hiding (readFile, writeFile, putStr) +import Control.Monad+import Control.Exception (try, IOException) import qualified Data.Text as T import qualified Data.Text.Encoding as Encoding import Data.Text.Encoding.Error (lenientDecode)@@ -48,8 +52,13 @@ readFile :: FilePath -> IO String readFile = fmap decodeText . B.readFile -writeFile :: FilePath -> String -> IO ()-writeFile name xs = withFile name WriteMode (`hPutStr` xs)+ensureFile :: FilePath -> String -> IO ()+ensureFile name new = do+ try (readFile name) >>= \ case+ Left (_ :: IOException) -> do+ withFile name WriteMode (`hPutStr` new)+ Right old -> unless (old == new) $ do+ withFile name WriteMode (`hPutStr` new) putStr :: String -> IO () putStr = hPutStr stdout
src/Hpack/Util.hs view
@@ -1,34 +1,38 @@+{-# LANGUAGE LambdaCase #-} module Hpack.Util ( GhcOption , GhcProfOption , GhcjsOption , CppOption+, AsmOption , CcOption , CxxOption , LdOption , parseMain-, toModule-, getModuleFilesRecursive+ , tryReadFile , expandGlobs , sort , lexicographically , Hash , sha256++, nub+, nubOn ) where +import Imports+ import Control.Exception-import Control.Monad import Data.Char-import Data.Bifunctor-import Data.List hiding (sort) import Data.Ord+import qualified Data.Set as Set 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 qualified Crypto.Hash.SHA256 as SHA256 import Hpack.Haskell import Hpack.Utf8 as Utf8@@ -43,6 +47,7 @@ type GhcProfOption = String type GhcjsOption = String type CppOption = String+type AsmOption = String type CcOption = String type CxxOption = String type LdOption = String@@ -62,38 +67,6 @@ (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)@@ -157,4 +130,18 @@ type Hash = String sha256 :: String -> Hash-sha256 c = show (hash (Utf8.encodeUtf8 c) :: Digest SHA256)+sha256 c = show (SHA256.hash (Utf8.encodeUtf8 c))++nub :: Ord a => [a] -> [a]+nub = nubOn id++nubOn :: Ord b => (a -> b) -> [a] -> [a]+nubOn f = go mempty+ where+ go seen = \ case+ [] -> []+ a : as+ | b `Set.member` seen -> go seen as+ | otherwise -> a : go (Set.insert b seen) as+ where+ b = f a
src/Hpack/Yaml.hs view
@@ -14,28 +14,37 @@ -- tool that supports Hpack (e.g. @stack@ or @cabal2nix@). decodeYaml+, decodeYamlWithParseError+, ParseException+, formatYamlParseError+, formatWarning , module Data.Aeson.Config.FromValue ) where -import Data.Bifunctor+import Imports+ 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) +decodeYaml :: FilePath -> IO (Either String ([String], Value))+decodeYaml file = first (formatYamlParseError file) <$> decodeYamlWithParseError file++decodeYamlWithParseError :: FilePath -> IO (Either ParseException ([String], Value))+decodeYamlWithParseError file = do+ result <- decodeFileWithWarnings file+ return $ fmap (first (map $ formatWarning file)) result++formatYamlParseError :: FilePath -> ParseException -> String+formatYamlParseError file 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+ _ -> ": " ++ displayException err+ 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
+ src/Imports.hs view
@@ -0,0 +1,18 @@+{-# LANGUAGE CPP #-}+module Imports (module Imports) where++import Control.Applicative as Imports+import Control.Arrow as Imports ((>>>), (&&&))+import Control.Exception as Imports (Exception(..))+import Control.Monad as Imports+import Control.Monad.IO.Class as Imports+import Data.Bifunctor as Imports+#if MIN_VERSION_base(4,20,0)+import Data.List as Imports hiding (List, sort, nub)+#else+import Data.List as Imports hiding (sort, nub)+#endif+import Data.Monoid as Imports (Monoid(..))+import Data.Semigroup as Imports (Semigroup(..))+import Data.String as Imports+import Data.Text as Imports (Text)
+ src/Path.hs view
@@ -0,0 +1,26 @@+module Path where++import Imports++import System.FilePath++fromFilePath :: FilePath -> Path+fromFilePath = Path . map PathComponent . splitDirectories++toFilePath :: Path -> FilePath+toFilePath = joinPath . components++components :: Path -> [String]+components = map unPathComponent . unPath++newtype Path = Path {unPath :: [PathComponent]}+ deriving Eq++instance Show Path where+ show = show . toFilePath++instance IsString Path where+ fromString = fromFilePath++newtype PathComponent = PathComponent {unPathComponent :: String}+ deriving Eq
test/Data/Aeson/Config/FromValueSpec.hs view
@@ -3,12 +3,14 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-} module Data.Aeson.Config.FromValueSpec where import Helper import GHC.Generics import qualified Data.Map.Lazy as Map+import Data.Monoid (Last(..)) import Data.Aeson.Config.FromValue @@ -16,7 +18,7 @@ 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, [])+shouldDecodeTo_ value expected = decodeValue value `shouldBe` Right (expected, [], []) data Person = Person { personName :: String@@ -34,6 +36,30 @@ , jobSalary :: Int } deriving (Eq, Show, Generic, FromValue) +data FlatMaybe = FlatMaybe {+ flatMaybeValue :: Maybe String+} deriving (Eq, Show, Generic, FromValue)++data AliasMaybe = AliasMaybe {+ aliasMaybeValue :: Alias 'False "some-alias" (Maybe String)+} deriving (Eq, Show, Generic, FromValue)++data NestedMaybe = NestedMaybe {+ nestedMaybeValue :: Maybe (Maybe String)+} deriving (Eq, Show, Generic, FromValue)++data AliasNestedMaybe = AliasNestedMaybe {+ aliasNestedMaybeValue :: Alias 'False "some-alias" (Maybe (Maybe String))+} deriving (Eq, Show, Generic, FromValue)++data FlatLast = FlatLast {+ flatLastValue :: Last String+} deriving (Eq, Show, Generic, FromValue)++data AliasLast = AliasLast {+ aliasLastValue :: Alias 'False "some-alias" (Last String)+} deriving (Eq, Show, Generic, FromValue)+ spec :: Spec spec = do describe "fromValue" $ do@@ -52,7 +78,7 @@ name: "Joe" age: 23 foo: bar- |] `shouldDecodeTo` Right (Person "Joe" 23 Nothing, ["$.foo"])+ |] `shouldDecodeTo` Right (Person "Joe" 23 Nothing, ["$.foo"], []) it "captures nested unrecognized fields" $ do [yaml|@@ -63,7 +89,7 @@ zip: "123456" foo: bar: 23- |] `shouldDecodeTo` Right (Person "Joe" 23 (Just (Address "somewhere" "123456")), ["$.address.foo"])+ |] `shouldDecodeTo` Right (Person "Joe" 23 (Just (Address "somewhere" "123456")), ["$.address.foo"], []) it "ignores fields that start with an underscore" $ do [yaml|@@ -85,8 +111,137 @@ [yaml| name: "Joe" age: "23"- |] `shouldDecodeTo` left "Error while parsing $.age - expected Int, encountered String"+ |] `shouldDecodeTo` left "Error while parsing $.age - parsing Int failed, expected Number, but encountered String" + context "when parsing a field of type (Maybe a)" $ do+ it "accepts a value" $ do+ [yaml|+ value: some value+ |] `shouldDecodeTo_` FlatMaybe (Just "some value")++ it "allows the field to be omitted" $ do+ [yaml|+ {}+ |] `shouldDecodeTo_` FlatMaybe Nothing++ it "rejects null" $ do+ [yaml|+ value: null+ |] `shouldDecodeTo` (Left "Error while parsing $.value - expected String, but encountered Null" :: Result FlatMaybe)++ context "when parsing a field of type (Maybe (Maybe a))" $ do+ it "accepts a value" $ do+ [yaml|+ value: some value+ |] `shouldDecodeTo_` NestedMaybe (Just $ Just "some value")++ it "allows the field to be omitted" $ do+ [yaml|+ {}+ |] `shouldDecodeTo_` NestedMaybe Nothing++ it "accepts null" $ do+ [yaml|+ value: null+ |] `shouldDecodeTo_` NestedMaybe (Just Nothing)++ context "when parsing a field of type (Alias (Maybe a))" $ do+ it "accepts a value" $ do+ [yaml|+ value: some value+ |] `shouldDecodeTo_` AliasMaybe (Alias $ Just "some value")++ it "allows the field to be accessed by its alias" $ do+ [yaml|+ some-alias: some alias value+ |] `shouldDecodeTo_` AliasMaybe (Alias $ Just "some alias value")++ it "gives the primary name precedence" $ do+ [yaml|+ value: some value+ some-alias: some alias value+ |] `shouldDecodeTo` Right (AliasMaybe (Alias $ Just "some value"), ["$.some-alias"], [])++ it "allows the field to be omitted" $ do+ [yaml|+ {}+ |] `shouldDecodeTo_` AliasMaybe (Alias Nothing)++ it "rejects null" $ do+ [yaml|+ value: null+ |] `shouldDecodeTo` (Left "Error while parsing $.value - expected String, but encountered Null" :: Result AliasMaybe)++ context "when parsing a field of type (Alias (Maybe (Maybe a)))" $ do+ it "accepts a value" $ do+ [yaml|+ value: some value+ |] `shouldDecodeTo_` AliasNestedMaybe (Alias . Just $ Just "some value")++ it "allows the field to be accessed by its alias" $ do+ [yaml|+ some-alias: some value+ |] `shouldDecodeTo_` AliasNestedMaybe (Alias . Just $ Just "some value")++ it "gives the primary name precedence" $ do+ [yaml|+ value: some value+ some-alias: some alias value+ |] `shouldDecodeTo` Right (AliasNestedMaybe (Alias . Just $ Just "some value"), ["$.some-alias"], [])++ it "allows the field to be omitted" $ do+ [yaml|+ {}+ |] `shouldDecodeTo_` AliasNestedMaybe (Alias Nothing)++ it "accepts null" $ do+ [yaml|+ value: null+ |] `shouldDecodeTo_` AliasNestedMaybe (Alias $ Just Nothing)++ context "when parsing a field of type (Last a)" $ do+ it "accepts a value" $ do+ [yaml|+ value: some value+ |] `shouldDecodeTo_` FlatLast (Last $ Just "some value")++ it "allows the field to be omitted" $ do+ [yaml|+ {}+ |] `shouldDecodeTo_` FlatLast (Last Nothing)++ it "rejects null" $ do+ [yaml|+ value: null+ |] `shouldDecodeTo` (Left "Error while parsing $.value - expected String, but encountered Null" :: Result FlatLast)++ context "when parsing a field of type (Alias (Last a))" $ do+ it "accepts a value" $ do+ [yaml|+ value: some value+ |] `shouldDecodeTo_` AliasLast (Alias . Last $ Just "some value")++ it "allows the field to be accessed by its alias" $ do+ [yaml|+ some-alias: some value+ |] `shouldDecodeTo_` AliasLast (Alias . Last $ Just "some value")++ it "gives the primary name precedence" $ do+ [yaml|+ value: some value+ some-alias: some alias value+ |] `shouldDecodeTo` Right (AliasLast (Alias . Last $ Just "some value"), ["$.some-alias"], [])++ it "allows the field to be omitted" $ do+ [yaml|+ {}+ |] `shouldDecodeTo_` AliasLast (Alias $ Last Nothing)++ it "rejects null" $ do+ [yaml|+ value: null+ |] `shouldDecodeTo` (Left "Error while parsing $.value - expected String, but encountered Null" :: Result AliasLast)+ context "with (,)" $ do it "captures unrecognized fields" $ do [yaml|@@ -95,7 +250,7 @@ role: engineer salary: 100000 foo: bar- |] `shouldDecodeTo` Right ((Person "Joe" 23 Nothing, Job "engineer" 100000), ["$.foo"])+ |] `shouldDecodeTo` Right ((Person "Joe" 23 Nothing, Job "engineer" 100000), ["$.foo"], []) context "with []" $ do it "captures unrecognized fields" $ do@@ -111,7 +266,7 @@ - name: "Marry" age: 25 bar: 42- |] `shouldDecodeTo` Right (expected, ["$[1].bar", "$[0].address.foo"])+ |] `shouldDecodeTo` Right (expected, ["$[1].bar", "$[0].address.foo"], []) context "with Map" $ do it "captures unrecognized fields" $ do@@ -120,4 +275,4 @@ region: somewhere zip: '123456' foo: bar- |] `shouldDecodeTo` Right (Map.fromList [("Joe", Address "somewhere" "123456")], ["$.Joe.foo"])+ |] `shouldDecodeTo` Right (Map.fromList [("Joe", Address "somewhere" "123456")], ["$.Joe.foo"], [])
test/Data/Aeson/Config/TypesSpec.hs view
@@ -13,7 +13,7 @@ context "List" $ do let parseError :: String -> Result (List Int)- parseError prefix = Left (prefix ++ " - expected Int, encountered String")+ 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
test/EndToEndSpec.hs view
@@ -11,1633 +11,2257 @@ 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- dependencies: foo == bar- |] `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: hspec/hspec- |] `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- |]-- 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- |]-- 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, 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, 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 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"-- 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, encountered Null"-- it "rejects invalid conditionals" $ do- [i|- dependencies:- - foo- - 23- |] `shouldFailWith` "package.yaml: Error while parsing $.dependencies[1] - expected Object or String, 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 <sol@typeful.net>+import System.Directory (canonicalizePath)+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(..), defaultDecodeOptions, DecodeResult(..))+import Hpack.Render.Hints (FormattingHints(..), sniffFormattingHints, formattingHintsRenderSettings)++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 "my-package") $ do+ describe "hpack" $ do+ it "ignores fields that start with an underscore" $ do+ [i|+ _foo:+ bar: 23+ library: {}+ |] `shouldRenderTo` library_ [i|+ |]+ it "warns on duplicate fields" $ do+ [i|+ name: foo+ name: foo+ |] `shouldWarn` [+ "package.yaml: Duplicate field $.name"+ ]++ describe "tested-with" $ do+ it "accepts a string" $ do+ [i|+ tested-with: GHC == 7.0.4+ |] `shouldRenderTo` package [i|+ tested-with:+ GHC == 7.0.4+ |]++ it "accepts a list" $ do+ [i|+ tested-with:+ - GHC == 7.0.4+ - GHC == 7.2.2+ - GHC == 7.4.2+ |] `shouldRenderTo` package [i|+ tested-with:+ GHC == 7.0.4+ , GHC == 7.2.2+ , GHC == 7.4.2+ |]++ describe "description" $ do+ it "renders empty lines as dots" $ do+ [i|+ description: |+ foo++ bar++ baz+ |] `shouldRenderTo` package [i|+ description: foo+ .+ bar+ .+ baz+ |]++ context "when cabal-version is >= 3" $ do+ it "preserves empty lines" $ do+ [i|+ verbatim:+ cabal-version: 3.0+ description: |+ foo++ bar++ baz+ |] `shouldRenderTo` (package [i|+ description: foo++ bar++ baz+ |]) { packageCabalVersion = "3.0" }++ describe "category" $ do+ it "accepts a single category" $ do+ [i|+ category: Testing+ |] `shouldRenderTo` package [i|+ category: Testing+ |]++ it "accepts a list of categories" $ do+ [i|+ category:+ - Development+ - Testing+ |] `shouldRenderTo` package [i|+ category: Development,+ Testing+ |]++ describe "handling of Paths_ module" $ do+ it "adds Paths_ to other-modules" $ do+ [i|+ library: {}+ |] `shouldRenderTo` library [i|+ other-modules:+ Paths_my_package+ default-language: Haskell2010+ |]++ context "when spec-version is >= 0.36.0" $ do+ it "does not add Paths_" $ do+ [i|+ spec-version: 0.36.0+ library: {}+ |] `shouldRenderTo` library [i|+ default-language: Haskell2010+ |]++ context "when cabal-version is >= 2" $ do+ it "adds Paths_ to autogen-modules" $ do+ [i|+ verbatim:+ cabal-version: 2.0+ library: {}+ |] `shouldRenderTo` (library [i|+ other-modules:+ Paths_my_package+ autogen-modules:+ Paths_my_package+ default-language: Haskell2010+ |]) { packageCabalVersion = "2.0" }++ context "when Paths_ module is listed explicitly under generated-other-modules" $ do+ it "adds Paths_ to autogen-modules only once" $ do+ [i|+ verbatim:+ cabal-version: 2.0+ library:+ generated-other-modules: Paths_my_package+ |] `shouldRenderTo` (library [i|+ other-modules:+ Paths_my_package+ autogen-modules:+ Paths_my_package+ default-language: Haskell2010+ |]) { packageCabalVersion = "2.0" }++ context "when Paths_ module is listed explicitly under generated-exposed-modules" $ do+ it "adds Paths_ to autogen-modules only once" $ do+ [i|+ verbatim:+ cabal-version: 2.0+ library:+ generated-exposed-modules: Paths_my_package+ |] `shouldRenderTo` (library [i|+ exposed-modules:+ Paths_my_package+ autogen-modules:+ Paths_my_package+ default-language: Haskell2010+ |]) { packageCabalVersion = "2.0" }++ context "when Paths_ is mentioned in a conditional that is always false" $ do+ it "does not add Paths_" $ do+ [i|+ library:+ when:+ - condition: false+ other-modules: Paths_my_package+ |] `shouldRenderTo` library [i|+ default-language: Haskell2010+ |]++ context "when Paths_ is used with RebindableSyntax and (OverloadedStrings or OverloadedLists)" $ do+ it "infers cabal-version 2.2" $ do+ [i|+ default-extensions: [RebindableSyntax, OverloadedStrings]+ library: {}+ |] `shouldRenderTo` (library [i|+ default-extensions:+ RebindableSyntax+ OverloadedStrings+ other-modules:+ Paths_my_package+ autogen-modules:+ Paths_my_package+ default-language: Haskell2010+ |]) {packageCabalVersion = "2.2"}++ context "when Paths_ is mentioned in a conditional that is always false" $ do+ it "does not infer cabal-version 2.2" $ do+ [i|+ default-extensions: [RebindableSyntax, OverloadedStrings]+ library:+ when:+ - condition: false+ other-modules: Paths_my_package+ |] `shouldRenderTo` (library [i|+ default-extensions:+ RebindableSyntax+ OverloadedStrings+ default-language: Haskell2010+ |])++ 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 "codeberg" $ do+ it "accepts owner/repo" $ do+ [i|+ codeberg: sol/hpack+ |] `shouldRenderTo` package [i|+ homepage: https://codeberg.org/sol/hpack#readme+ bug-reports: https://codeberg.org/sol/hpack/issues+ source-repository head+ type: git+ location: https://codeberg.org/sol/hpack+ |]++ 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 "flags" $ do+ it "accepts multi-line flag descriptions" $ do+ [i|+ flags:+ some-flag:+ description: |+ some+ flag+ description+ manual: True+ default: False+ |] `shouldRenderTo` package [i|+ flag some-flag+ description: some+ flag+ description+ manual: True+ default: False+ |]++ 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+ |]++ it "accepts executable defaults" $ do+ writeFile "defaults/sol/hpack-template/2017/.hpack/defaults.yaml" [i|+ main: Foo.hs+ |]++ [i|+ executable:+ defaults: sol/hpack-template@2017+ |] `shouldRenderTo` executable_ "my-package" [i|+ main-is: Foo.hs+ |]++ it "gives `main` from executable section precedence" $ do+ writeFile "defaults/sol/hpack-template/2017/.hpack/defaults.yaml" [i|+ main: Foo.hs+ |]++ [i|+ executable:+ main: Bar.hs+ defaults: sol/hpack-template@2017+ |] `shouldRenderTo` executable_ "my-package" [i|+ main-is: Bar.hs+ |]++ 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+ [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|+ 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_my_package+ autogen-modules:+ Paths_my_package+ 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_my_package+ autogen-modules:+ Paths_my_package+ 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 "extra-files" $ do+ it "accepts extra-files" $ do+ touch "CHANGES.markdown"+ touch "README.markdown"+ [i|+ extra-files:+ - CHANGES.markdown+ - README.markdown+ |] `shouldRenderTo` (package [i|+ extra-files:+ CHANGES.markdown+ README.markdown+ |]) {packageCabalVersion = "3.14"}++ describe "build-tools" $ do+ context "with known build tools" $ do+ context "when cabal-version < 2" $ do+ it "adds them to build-tools" $ do+ [i|+ executable:+ build-tools:+ alex == 0.1.0+ |] `shouldRenderTo` executable_ "my-package" [i|+ build-tools:+ alex ==0.1.0+ |]++ context "when cabal-version >= 2" $ do+ it "adds them to build-tool-depends" $ do+ [i|+ verbatim:+ cabal-version: 2.0+ executable:+ build-tools:+ alex == 0.1.0+ |] `shouldRenderTo` (executable_ "my-package" [i|+ autogen-modules:+ Paths_my_package+ build-tool-depends:+ alex:alex ==0.1.0+ |]) {+ packageCabalVersion = "2.0"+ }++ context "with other build tools" $ do+ it "adds them to build-tool-depends" $ do+ [i|+ executable:+ build-tools:+ hspec-discover: 0.1.0+ |] `shouldRenderTo` (executable_ "my-package" [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"+ }++ it "accepts build-tool-depends as an alias" $ do+ [i|+ executable:+ build-tool-depends:+ hspec-discover: 0.1.0+ |] `shouldRenderTo` (executable_ "my-package" [i|+ build-tool-depends:+ hspec-discover:hspec-discover ==0.1.0+ |]) {+ packageCabalVersion = "1.12"+ , packageWarnings = ["package.yaml: $.executable.build-tool-depends is deprecated, use $.executable.build-tools instead"]+ }++ 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:+ - my-package: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:+ - my-package:bar == 0.2.0+ |] `shouldRenderTo` executable_ "bar" [i|+ build-tools:+ bar ==0.2.0+ |]++ context "when cabal-version >= 2" $ do+ it "adds it to build-tool-depends" $ do+ [i|+ verbatim:+ cabal-version: 2.0+ executables:+ bar:+ build-tools:+ - bar+ |] `shouldRenderTo` (executable_ "bar" [i|+ autogen-modules:+ Paths_my_package+ build-tool-depends:+ my-package:bar+ |]) {packageCabalVersion = "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_ "my-package" [i|+ build-tools:+ ghc >=7.10+ |]) { packageWarnings = ["Listing \"ghc\" under build-tools is deprecated! 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_ "my-package" [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_ "my-package" [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_ "my-package" [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_ "my-package" [i|+ autogen-modules:+ Paths_my_package+ build-tools:+ g++ >=5.4.0+ |]) {packageCabalVersion = "2.0"}++ describe "dependencies" $ do+ it "accepts single dependency" $ do+ [i|+ executable:+ dependencies: base+ |] `shouldRenderTo` executable_ "my-package" [i|+ build-depends:+ base+ |]++ it "accepts build-depends as an alias" $ do+ [i|+ executable:+ build-depends: base+ |] `shouldRenderTo` (executable_ "my-package" [i|+ build-depends:+ base+ |]) {+ packageWarnings = ["package.yaml: $.executable.build-depends is deprecated, use $.executable.dependencies instead"]+ }++ it "accepts dependencies with subcomponents" $ do+ [i|+ executable:+ dependencies: foo:bar+ |] `shouldRenderTo` (executable_ "my-package" [i|+ autogen-modules:+ Paths_my_package+ build-depends:+ foo:bar+ |]) {packageCabalVersion = "3.0"}++ it "accepts list of dependencies" $ do+ [i|+ executable:+ dependencies:+ - base+ - transformers+ |] `shouldRenderTo` executable_ "my-package" [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_ "my-package" [i|+ build-depends:+ base+ , hspec+ |]++ it "gives section specific dependencies precedence" $ do+ [i|+ dependencies:+ - base+ executable:+ dependencies: base >= 2+ |] `shouldRenderTo` executable_ "my-package" [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_ "my-package" [i|+ pkgconfig-depends:+ QtWebKit+ , weston+ |]++ it "accepts pkgconfig-depends as an alias" $ do+ [i|+ pkgconfig-depends:+ - QtWebKit+ - weston+ executable: {}+ |] `shouldRenderTo` executable_ "my-package" [i|+ pkgconfig-depends:+ QtWebKit+ , weston+ |]++ describe "include-dirs" $ do+ it "accepts include-dirs" $ do+ [i|+ include-dirs:+ - foo+ - bar+ executable: {}+ |] `shouldRenderTo` executable_ "my-package" [i|+ include-dirs:+ foo+ bar+ |]++ describe "install-includes" $ do+ it "accepts install-includes" $ do+ [i|+ install-includes:+ - foo.h+ - bar.h+ executable: {}+ |] `shouldRenderTo` executable_ "my-package" [i|+ install-includes:+ foo.h+ bar.h+ |]++ describe "ghc-shared-options" $ do+ it "accepts ghc-shared-options" $ do+ [i|+ ghc-shared-options: -Wall+ executable: {}+ |] `shouldRenderTo` executable_ "my-package" [i|+ ghc-shared-options: -Wall+ |]++ 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_ "my-package" [i|+ js-sources:+ foo.js+ jsbits/bar.js+ |]++ it "accepts global js-sources" $ do+ [i|+ js-sources:+ - foo.js+ - jsbits/*.js+ executable: {}+ |] `shouldRenderTo` executable_ "my-package" [i|+ js-sources:+ foo.js+ jsbits/bar.js+ |]++ describe "asm-options" $ do+ it "accepts asm-options" $ do+ [i|+ executable:+ asm-options: -Wall+ |] `shouldRenderTo` (executable_ "my-package" [i|+ autogen-modules:+ Paths_my_package+ asm-options: -Wall+ |]) {packageCabalVersion = "3.0"}++ describe "asm-sources" $ before_ (touch "foo.asm" >> touch "asmbits/bar.asm") $ do+ it "accepts asm-sources" $ do+ [i|+ executable:+ asm-sources:+ - foo.asm+ - asmbits/*.asm+ |] `shouldRenderTo` (executable_ "my-package" [i|+ autogen-modules:+ Paths_my_package+ asm-sources:+ foo.asm+ asmbits/bar.asm+ |]) {packageCabalVersion = "3.0"}++ describe "cxx-options" $ do+ it "accepts cxx-options" $ do+ [i|+ executable:+ cxx-options: -Wall+ |] `shouldRenderTo` (executable_ "my-package" [i|+ autogen-modules:+ Paths_my_package+ 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 "my-package" [i|+ other-modules:+ Paths_my_package+ autogen-modules:+ Paths_my_package+ default-language: Haskell2010+ 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_ "my-package" [i|+ autogen-modules:+ Paths_my_package+ cxx-sources:+ foo.cc+ cxxbits/bar.cc+ |]) {packageCabalVersion = "2.2"}++ describe "language" $ do+ it "accepts language" $ do+ [i|+ language: GHC2021+ executable: {}+ |] `shouldRenderTo` executable "my-package" [i|+ other-modules:+ Paths_my_package+ default-language: GHC2021+ |]++ it "omits language if it is null" $ do+ [i|+ language: null+ executable: {}+ |] `shouldRenderTo` executable "my-package" [i|+ other-modules:+ Paths_my_package+ |]++ it "accepts default-language as an alias" $ do+ [i|+ default-language: GHC2021+ executable: {}+ |] `shouldRenderTo` (executable "my-package" [i|+ other-modules:+ Paths_my_package+ default-language: GHC2021+ |]) {+ packageWarnings = ["package.yaml: $.default-language is deprecated, use $.language instead"]+ }++ it "gives section-level language precedence" $ do+ [i|+ language: Haskell2010+ executable:+ language: GHC2021+ |] `shouldRenderTo` executable "my-package" [i|+ other-modules:+ Paths_my_package+ default-language: GHC2021+ |]++ it "accepts language from defaults" $ do+ writeFile "defaults/sol/hpack-template/2017/.hpack/defaults.yaml" [i|+ language: GHC2021+ |]++ [i|+ defaults: sol/hpack-template@2017+ library: {}+ |] `shouldRenderTo` library [i|+ other-modules:+ Paths_my_package+ default-language: GHC2021+ |]++ describe "extra-lib-dirs" $ do+ it "accepts extra-lib-dirs" $ do+ [i|+ extra-lib-dirs:+ - foo+ - bar+ executable: {}+ |] `shouldRenderTo` executable_ "my-package" [i|+ extra-lib-dirs:+ foo+ bar+ |]++ describe "extra-libraries" $ do+ it "accepts extra-libraries" $ do+ [i|+ extra-libraries:+ - foo+ - bar+ executable: {}+ |] `shouldRenderTo` executable_ "my-package" [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_ "my-package" [i|+ extra-frameworks-dirs:+ foo+ bar+ |]++ describe "frameworks" $ do+ it "accepts frameworks" $ do+ [i|+ frameworks:+ - foo+ - bar+ executable: {}+ |] `shouldRenderTo` executable_ "my-package" [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|+ autogen-modules:+ Paths_my_package+ 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+ default-language: Haskell2010+ |]++ context "with mixins" $ do+ it "infers cabal-version 2.0" $ do+ [i|+ library:+ dependencies:+ foo:+ mixin:+ - (Blah as Etc)+ |] `shouldRenderTo` (library [i|+ other-modules:+ Paths_my_package+ autogen-modules:+ Paths_my_package+ build-depends:+ foo+ mixins:+ foo (Blah as Etc)+ default-language: Haskell2010+ |]) {packageCabalVersion = "2.0"}++ context "with PackageInfo_my_package" $ do+ it "infers cabal-version 3.12" $ do+ [i|+ spec-version: 0.36.0+ library:+ generated-other-modules: PackageInfo_my_package+ |] `shouldRenderTo` (library [i|+ other-modules:+ PackageInfo_my_package+ autogen-modules:+ PackageInfo_my_package+ default-language: Haskell2010+ |]) {packageCabalVersion = "3.12"}++ 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_my_package+ autogen-modules:+ Paths_my_package+ 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_my_package+ autogen-modules:+ Paths_my_package+ |]) {packageCabalVersion = "3.0"}++ context "when inferring modules" $ do+ context "with a library" $ do+ it "ignores duplicate source directories" $ do+ touch "src/Foo.hs"+ [i|+ source-dirs: src+ library:+ source-dirs: src+ |] `shouldRenderTo` library [i|+ hs-source-dirs:+ src+ exposed-modules:+ Foo+ other-modules:+ Paths_my_package+ default-language: Haskell2010+ |]++ it "ignores duplicate modules" $ do+ touch "src/Foo.hs"+ touch "src/Foo.x"+ [i|+ library:+ source-dirs: src+ |] `shouldRenderTo` library [i|+ hs-source-dirs:+ src+ exposed-modules:+ Foo+ other-modules:+ Paths_my_package+ default-language: Haskell2010+ |]++ 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_my_package+ default-language: Haskell2010+ |]++ 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+ default-language: Haskell2010+ |]++ 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+ default-language: Haskell2010+ |]++ 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_my_package+ default-language: Haskell2010+ |]++ 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_my_package+ |] `shouldRenderTo` package [i|+ library+ hs-source-dirs:+ src+ exposed-modules:+ Bar+ default-language: Haskell2010+ if os(windows)+ exposed-modules:+ Foo+ Paths_my_package+ |]++ 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` package [i|+ library+ other-modules:+ Paths_my_package+ default-language: Haskell2010+ 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` package [i|+ library+ exposed-modules:+ Foo+ other-modules:+ Paths_my_package+ default-language: Haskell2010+ 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_my_package+ Bar+ autogen-modules:+ Paths_my_package+ Foo+ Bar+ default-language: Haskell2010+ |]) {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_my_package+ Other+ autogen-modules:+ Paths_my_package+ Exposed+ Other+ default-language: Haskell2010+ |]) {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` (package [i|+ library+ other-modules:+ Paths_my_package+ autogen-modules:+ Paths_my_package+ hs-source-dirs:+ src+ default-language: Haskell2010+ if os(windows)+ exposed-modules:+ Exposed+ other-modules:+ Other+ autogen-modules:+ Other+ Exposed+ |]) {packageCabalVersion = "2.0"}++ context "with an executable" $ 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_my_package+ default-language: Haskell2010+ |]++ 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+ default-language: Haskell2010+ |]++ 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_my_package+ Foo+ autogen-modules:+ Paths_my_package+ Foo+ default-language: Haskell2010+ |]) {packageCabalVersion = "2.0"}++ context "with PackageInfo_my_package" $ do+ it "infers cabal-version 3.12" $ do+ [i|+ spec-version: 0.36.0+ executables:+ foo:+ main: Main.hs+ generated-other-modules: PackageInfo_my_package+ |] `shouldRenderTo` (executable "foo" [i|+ main-is: Main.hs+ other-modules:+ PackageInfo_my_package+ autogen-modules:+ PackageInfo_my_package+ default-language: Haskell2010+ |]) {packageCabalVersion = "3.12"}++ 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|+ executables:+ foo:+ source-dirs: src+ when:+ condition: os(windows)+ other-modules: Foo+ |] `shouldRenderTo` executable "foo" [i|+ other-modules:+ Bar+ Paths_my_package+ hs-source-dirs:+ src+ default-language: Haskell2010+ 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_my_package+ hs-source-dirs:+ src+ default-language: Haskell2010+ if os(windows)+ other-modules:+ Bar+ hs-source-dirs:+ windows+ |]++ describe "executables" $ do+ it "accepts main-is as an alias for main" $ do+ [i|+ executable:+ main-is: Foo.hs+ |] `shouldRenderTo` (executable_ "my-package" [i|+ main-is: Foo.hs+ |]) {+ packageWarnings = ["package.yaml: $.executable.main-is is deprecated, use $.executable.main instead"]+ }++ 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_my_package+ default-language: Haskell2010+ |]++ context "with a 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+ other-modules:+ Paths_my_package+ default-language: Haskell2010+ 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|+ other-modules:+ Paths_my_package+ default-language: Haskell2010+ 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 "my-package" [i|+ other-modules:+ Paths_my_package+ default-language: Haskell2010+ 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 "my-package" [i|+ other-modules:+ Paths_my_package+ default-language: Haskell2010+ if os(windows)+ build-depends:+ Win32+ else+ build-depends:+ unix+ |]++ context "with empty then-branch" $ do+ it "provides a hint" $ do+ [i|+ when:+ condition: os(windows)+ then: {}+ else:+ dependencies: unix+ executable: {}+ |] `shouldFailWith` unlines [+ "package.yaml: Error while parsing $.when - an empty \"then\" section is not allowed, try the following instead:"+ , ""+ , "when:"+ , " condition: '!(os(windows))'"+ , " dependencies: unix"+ ]++ context "with empty else-branch" $ do+ it "provides a hint" $ do+ [i|+ when:+ condition: os(windows)+ then:+ dependencies: Win32+ else: {}+ executable: {}+ |] `shouldFailWith` unlines [+ "package.yaml: Error while parsing $.when - an empty \"else\" section is not allowed, try the following instead:"+ , ""+ , "when:"+ , " condition: os(windows)"+ , " dependencies: Win32"+ ]++ 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:+ dependencies: foo+ 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_my_package+ 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_my_package+ 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_my_package+ |]++ context "when specified globally" $ do+ it "overrides header fields" $ do+ [i|+ verbatim:+ build-type: foo+ |] `shouldRenderTo` (package "") {packageBuildType = "foo"}++ context "with cabal-version" $ do+ context "with a string value" $ do+ it "takes precedence over inferred version" $ do+ [i|+ license: BSD-3-Clause+ verbatim:+ cabal-version: foo+ |] `shouldRenderTo` (package "license: BSD-3-Clause") {packageCabalVersion = "foo"}++ context "with a version" $ do+ it "takes precedence over inferred version" $ do+ [i|+ license: BSD-3-Clause+ verbatim:+ cabal-version: 0.8+ |] `shouldRenderTo` (package "license: BSD-3-Clause") {packageCabalVersion = "0.8"}++ 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_my_package+ 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_my_package+ 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+ hints@FormattingHints{..} = sniffFormattingHints (lines old)+ alignment = fromMaybe 0 formattingHintsAlignment+ settings = formattingHintsRenderSettings hints+ 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: my-package\n" ++ unindent input)+ (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_my_package+#{indentBy 2 $ unindent l}+ default-language: Haskell2010+|]++library :: String -> Package+library l = package content+ where+ content = [i|+library+#{indentBy 2 $ unindent l}+|]++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_my_package+#{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}+|]++package :: String -> Package+package c = Package "my-package" "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-2023 Simon Hengel <sol@typeful.net> Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal
test/Helper.hs view
@@ -1,7 +1,9 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ConstraintKinds #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} module Helper (- module Test.Hspec+ module Imports+, module Test.Hspec , module Test.Mockery.Directory , module Control.Monad , module Control.Applicative@@ -9,12 +11,16 @@ , module System.FilePath , withCurrentDirectory , yaml+, makeVersion ) where +import Imports+ import Test.Hspec import Test.Mockery.Directory import Control.Monad import Control.Applicative+import Data.Version (Version(..)) import System.Directory (getCurrentDirectory, setCurrentDirectory, canonicalizePath) import Control.Exception import qualified System.IO.Temp as Temp@@ -23,6 +29,11 @@ import Data.Yaml.TH (yamlQQ) import Language.Haskell.TH.Quote (QuasiQuoter) +import Hpack.Config++instance IsString Cond where+ fromString = CondExpression+ withCurrentDirectory :: FilePath -> IO a -> IO a withCurrentDirectory dir action = do bracket getCurrentDirectory setCurrentDirectory $ \ _ -> do@@ -35,3 +46,6 @@ yaml :: Language.Haskell.TH.Quote.QuasiQuoter yaml = yamlQQ++makeVersion :: [Int] -> Version+makeVersion v = Version v []
test/Hpack/CabalFileSpec.hs view
@@ -9,9 +9,15 @@ 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@@ -21,13 +27,13 @@ it "includes hash" $ do inTempDirectory $ do- writeFile file $ header "package.yaml" version hash- readCabalFile file `shouldReturn` Just (CabalFile (Just version) (Just hash) [])+ writeFile file $ mkHeader "package.yaml" version hash+ readCabalFile file `shouldReturn` Just (CabalFile [] (Just version) (Just hash) [] DoesNotHaveGitConflictMarkers) it "accepts cabal-version at the beginning of the file" $ do inTempDirectory $ do- writeFile file $ ("cabal-version: 2.2\n" ++ header "package.yaml" version hash)- readCabalFile file `shouldReturn` Just (CabalFile (Just version) (Just hash) ["cabal-version: 2.2"])+ 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) [] DoesNotHaveGitConflictMarkers) describe "extractVersion" $ do it "extracts Hpack version from a cabal file" $ do
test/Hpack/ConfigSpec.hs view
@@ -19,7 +19,6 @@ 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@@ -29,12 +28,14 @@ import Hpack.Syntax.Dependencies import Hpack.Syntax.DependencyVersion import Hpack.Syntax.BuildTools-import Hpack.Config hiding (package)+import Hpack.Config hiding (section, package) import qualified Hpack.Config as Config import Data.Aeson.Config.Types import Data.Aeson.Config.FromValue +section :: a -> Section a+section a = (Config.section a) {sectionLanguage = Just $ Language "Haskell2010"} instance Exts.IsList (Maybe (List a)) where type Item (Maybe (List a)) = a@@ -54,7 +55,7 @@ executable main_ = Executable (Just main_) ["Paths_foo"] [] library :: Library-library = Library Nothing [] ["Paths_foo"] [] [] []+library = Library Nothing Nothing [] ["Paths_foo"] [] [] [] testDecodeOptions :: FilePath -> DecodeOptions testDecodeOptions file = defaultDecodeOptions {decodeOptionsTarget = file, decodeOptionsUserDataDir = Just undefined}@@ -90,6 +91,7 @@ let sect = LibrarySection { librarySectionExposed = Nothing+ , librarySectionVisibility = Nothing , librarySectionExposedModules = Nothing , librarySectionGeneratedExposedModules = Nothing , librarySectionOtherModules = Nothing@@ -99,6 +101,7 @@ } lib = Library { libraryExposed = Nothing+ , libraryVisibility = Nothing , libraryExposedModules = [] , libraryOtherModules = [] , libraryGeneratedModules = []@@ -146,25 +149,6 @@ } 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@@ -182,7 +166,7 @@ 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!"])+ toBuildTool_ (UnqualifiedBuildTool "ghc") `shouldBe` (Left ("ghc", AnyVersion), ["Listing \"ghc\" under build-tools is deprecated! Please list system executables under system-build-tools instead!"]) context "with a QualifiedBuildTool" $ do context "when only package matches the current package" $ do@@ -241,7 +225,7 @@ withPackageConfig_ [i| category: Data |]- (`shouldBe` package {packageCategory = Just "Data"})+ (`shouldBe` package {packageCategory = ["Data"]}) it "accepts author" $ do withPackageConfig_ [i|@@ -441,6 +425,15 @@ |] (packageLibrary >>> (`shouldBe` Just (section library) {sectionSourceDirs = ["foo", "bar"]})) + it "accepts hs-source-dirs as an alias for source-dirs" $ do+ withPackageConfig_ [i|+ library:+ hs-source-dirs:+ - foo+ - bar+ |]+ (packageLibrary >>> (`shouldBe` Just (section library) {sectionSourceDirs = ["foo", "bar"]}))+ it "accepts default-extensions" $ do withPackageConfig_ [i| library:@@ -660,22 +653,22 @@ it "accepts Strings" $ do [yaml| os(windows)- |] `shouldDecodeTo_` Cond "os(windows)"+ |] `shouldDecodeTo_` CondExpression "os(windows)" it "accepts True" $ do [yaml| yes- |] `shouldDecodeTo_` Cond "true"+ |] `shouldDecodeTo_` CondBool True it "accepts False" $ do [yaml| no- |] `shouldDecodeTo_` Cond "false"+ |] `shouldDecodeTo_` CondBool False it "rejects other values" $ do [yaml| 23- |] `shouldDecodeTo` (Left "Error while parsing $ - expected Boolean or String, encountered Number" :: Result Cond)+ |] `shouldDecodeTo` (Left "Error while parsing $ - expected Boolean or String, but encountered Number" :: Result Cond) describe "formatOrList" $ do it "formats a singleton list" $ do
test/Hpack/DefaultsSpec.hs view
@@ -4,6 +4,7 @@ import Helper import System.Directory +import Hpack.Error import Hpack.Syntax.Defaults import Hpack.Defaults @@ -12,7 +13,7 @@ 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!"+ let expected = Left (DefaultsFileNotFound $ cwd </> "foo") ensure undefined cwd (DefaultsLocal $ Local "foo") `shouldReturn` expected describe "ensureFile" $ do@@ -21,7 +22,6 @@ 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@@ -40,7 +40,6 @@ 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
test/Hpack/LicenseSpec.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE QuasiQuotes #-} module Hpack.LicenseSpec (spec) where @@ -6,7 +7,7 @@ import Data.String.Interpolate import Distribution.Pretty (prettyShow)-import Distribution.Parsec.Class (simpleParsec)+import Distribution.Parsec (simpleParsec) import qualified Distribution.License as Cabal import Hpack.License
+ test/Hpack/ModuleSpec.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE OverloadedStrings #-}+module Hpack.ModuleSpec (spec) where++import Helper++import Hpack.Module++spec :: Spec+spec = do+ 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 "toModule" $ do+ it "maps a Path to a Module" $ do+ toModule "Foo/Bar/Baz.hs" `shouldBe` "Foo.Bar.Baz"++ describe "getModuleFilesRecursive" $ do+ it "gets all Haskell source files from given directory" $ do+ inTempDirectory $ do+ touch "foo/Bar.hs"+ touch "foo/Baz.chs"+ actual <- getModuleFilesRecursive "foo"+ actual `shouldMatchList` [+ "Bar.hs"+ , "Baz.chs"+ ]++ it "ignores other files" $ do+ inTempDirectory $ do+ touch "foo/Bar.js"+ getModuleFilesRecursive "foo" `shouldReturn` []++ it "descends into subdirectories" $ do+ inTempDirectory $ do+ touch "foo/Bar/Baz.hs"+ getModuleFilesRecursive "foo" `shouldReturn` ["Bar/Baz.hs"]++ context "when a subdirectory is not a valid module name" $ do+ it "does not descend" $ do+ inTempDirectory $ do+ touch "foo/bar/Baz.hs"+ getModuleFilesRecursive "foo" `shouldReturn` empty
test/Hpack/OptionsSpec.hs view
@@ -18,10 +18,10 @@ context "by default" $ do it "returns Run" $ do- parseOptions defaultTarget [] `shouldReturn` Run (ParseOptions Verbose NoForce False defaultTarget)+ parseOptions defaultTarget [] `shouldReturn` Run (ParseOptions Verbose NoForce Nothing False defaultTarget MinimizeDiffs) it "includes target" $ do- parseOptions defaultTarget ["foo.yaml"] `shouldReturn` Run (ParseOptions Verbose NoForce False "foo.yaml")+ parseOptions defaultTarget ["foo.yaml"] `shouldReturn` Run (ParseOptions Verbose NoForce Nothing False "foo.yaml" MinimizeDiffs) context "with superfluous arguments" $ do it "returns ParseError" $ do@@ -29,19 +29,31 @@ context "with --silent" $ do it "sets optionsVerbose to NoVerbose" $ do- parseOptions defaultTarget ["--silent"] `shouldReturn` Run (ParseOptions NoVerbose NoForce False defaultTarget)+ parseOptions defaultTarget ["--silent"] `shouldReturn` Run (ParseOptions NoVerbose NoForce Nothing False defaultTarget MinimizeDiffs) context "with --force" $ do it "sets optionsForce to Force" $ do- parseOptions defaultTarget ["--force"] `shouldReturn` Run (ParseOptions Verbose Force False defaultTarget)+ parseOptions defaultTarget ["--force"] `shouldReturn` Run (ParseOptions Verbose Force Nothing False defaultTarget MinimizeDiffs) context "with -f" $ do it "sets optionsForce to Force" $ do- parseOptions defaultTarget ["-f"] `shouldReturn` Run (ParseOptions Verbose Force False defaultTarget)+ parseOptions defaultTarget ["-f"] `shouldReturn` Run (ParseOptions Verbose Force Nothing False defaultTarget MinimizeDiffs) + context "when determining parseOptionsHash" $ do++ it "assumes True on --hash" $ do+ parseOptions defaultTarget ["--hash"] `shouldReturn` Run (ParseOptions Verbose NoForce (Just True) False defaultTarget MinimizeDiffs)++ it "assumes False on --no-hash" $ do+ parseOptions defaultTarget ["--no-hash"] `shouldReturn` Run (ParseOptions Verbose NoForce (Just False) False defaultTarget MinimizeDiffs)++ it "gives last occurrence precedence" $ do+ parseOptions defaultTarget ["--no-hash", "--hash"] `shouldReturn` Run (ParseOptions Verbose NoForce (Just True) False defaultTarget MinimizeDiffs)+ parseOptions defaultTarget ["--hash", "--no-hash"] `shouldReturn` Run (ParseOptions Verbose NoForce (Just False) False defaultTarget MinimizeDiffs)+ context "with -" $ do it "sets optionsToStdout to True, implies Force and NoVerbose" $ do- parseOptions defaultTarget ["-"] `shouldReturn` Run (ParseOptions NoVerbose Force True defaultTarget)+ parseOptions defaultTarget ["-"] `shouldReturn` Run (ParseOptions NoVerbose Force Nothing True defaultTarget MinimizeDiffs) it "rejects - for target" $ do parseOptions defaultTarget ["-", "-"] `shouldReturn` ParseError
test/Hpack/Render/DslSpec.hs view
@@ -55,7 +55,79 @@ ] context "when rendering a Field" $ do- context "when rendering a MultipleLines value" $ do+ context "with a Literal value" $ do+ let+ description :: [String] -> Element+ description = Field "description" . Literal . unlines++ values :: [String]+ values = [+ "foo"+ , "bar"+ , "baz"+ ]++ it "renders field" $ do+ render_ (Field "description" "foo") `shouldBe` ["description: foo"]++ it "formats multi-line values" $ do+ render_ (description values) `shouldBe` [+ "description: foo"+ , " bar"+ , " baz"+ ]++ it "formats empty lines" $ do+ let+ field = description [+ "foo"+ , " "+ , "baz"+ ]+ render_ field `shouldBe` [+ "description: foo"+ , " ."+ , " baz"+ ]++ it "correctly handles empty lines at the beginning" $ do+ render_ (description $ "" : values) `shouldBe` [+ "description: ."+ , " foo"+ , " bar"+ , " baz"+ ]++ it "takes alignment into account" $ do+ let+ settings :: RenderSettings+ settings = defaultRenderSettings { renderSettingsFieldAlignment = 15 }++ render settings 0 (description values) `shouldBe` [+ "description: foo"+ , " bar"+ , " baz"+ ]++ context "when cabal-version is >= 3" $ do+ let+ settings :: RenderSettings+ settings = defaultRenderSettings { renderSettingsEmptyLinesAsDot = False }++ it "preserves empty lines" $ do+ let+ field = description [+ "foo"+ , ""+ , "baz"+ ]+ render settings 0 field `shouldBe` [+ "description: foo"+ , ""+ , " baz"+ ]++ context "with MultipleLines" $ do it "takes nesting into account" $ do let field = Field "foo" (CommaSeparatedList ["bar", "baz"]) render defaultRenderSettings 1 field `shouldBe` [@@ -92,14 +164,14 @@ renderValue defaultRenderSettings (WordList ["foo", "bar", "baz"]) `shouldBe` SingleLine "foo bar baz" it "renders CommaSeparatedList" $ do- renderValue defaultRenderSettings (CommaSeparatedList ["foo", "bar", "baz"]) `shouldBe` MultipleLines [+ renderValue defaultRenderSettings (CommaSeparatedList ["foo", "bar", "baz"]) `shouldBe` MultipleLines Indent [ " foo" , ", bar" , ", baz" ] it "renders LineSeparatedList" $ do- renderValue defaultRenderSettings (LineSeparatedList ["foo", "bar", "baz"]) `shouldBe` MultipleLines [+ renderValue defaultRenderSettings (LineSeparatedList ["foo", "bar", "baz"]) `shouldBe` MultipleLines Indent [ " foo" , " bar" , " baz"@@ -109,14 +181,14 @@ let settings = defaultRenderSettings{renderSettingsCommaStyle = TrailingCommas} it "renders CommaSeparatedList with trailing commas" $ do- renderValue settings (CommaSeparatedList ["foo", "bar", "baz"]) `shouldBe` MultipleLines [+ renderValue settings (CommaSeparatedList ["foo", "bar", "baz"]) `shouldBe` MultipleLines Indent [ "foo," , "bar," , "baz" ] it "renders LineSeparatedList without padding" $ do- renderValue settings (LineSeparatedList ["foo", "bar", "baz"]) `shouldBe` MultipleLines [+ renderValue settings (LineSeparatedList ["foo", "bar", "baz"]) `shouldBe` MultipleLines Indent [ "foo" , "bar" , "baz"
test/Hpack/Render/HintsSpec.hs view
@@ -3,14 +3,26 @@ import Test.Hspec import Hpack.Render.Hints-import Hpack.Render.Dsl+import Hpack.Render.Dsl (CommaStyle(..)) spec :: Spec spec = do+ describe "formattingHintsRenderSettings" $ do+ context "when sniffed indentation is < default" $ do+ it "uses default instead" $ do+ let input = [+ "library"+ , "exposed-modules:"+ , " Foo"+ ]+ hints = sniffFormattingHints input+ formattingHintsIndentation hints `shouldBe` Just 0+ renderSettingsIndentation (formattingHintsRenderSettings hints) `shouldBe` 2+ describe "extractFieldOrder" $ do it "extracts field order hints" $ do let input = [- "name: cabalize"+ "name: hpack" , "version: 0.0.0" , "license:" , "license-file: "@@ -27,7 +39,7 @@ describe "extractSectionsFieldOrder" $ do it "splits input into sections" $ do let input = [- "name: cabalize"+ "name: hpack" , "version: 0.0.0" , "" , "library"@@ -77,7 +89,7 @@ describe "sniffAlignment" $ do it "sniffs field alignment from given cabal file" $ do let input = [- "name: cabalize"+ "name: hpack" , "version: 0.0.0" , "license: MIT" , "license-file: LICENSE"@@ -87,7 +99,7 @@ it "ignores fields without a value on the same line" $ do let input = [- "name: cabalize"+ "name: hpack" , "version: 0.0.0" , "description: " , " foo"@@ -95,6 +107,22 @@ ] sniffAlignment input `shouldBe` Just 16 + context "when all fields are padded with exactly one space" $ do+ it "returns 0" $ do+ let input = [+ "name: hpack"+ , "version: 0.0.0"+ , "license: MIT"+ , "license-file: LICENSE"+ , "build-type: Simple"+ ]+ sniffAlignment input `shouldBe` Just 0++ context "with an empty input list" $ do+ it "returns Nothing" $ do+ let input = []+ sniffAlignment input `shouldBe` Nothing+ describe "splitField" $ do it "splits fields" $ do splitField "foo: bar" `shouldBe` Just ("foo", " bar")@@ -109,7 +137,7 @@ splitField "foo bar" `shouldBe` Nothing describe "sniffIndentation" $ do- it "sniff alignment from executable section" $ do+ it "sniffs indentation from executable section" $ do let input = [ "name: foo" , "version: 0.0.0"@@ -119,7 +147,7 @@ ] sniffIndentation input `shouldBe` Just 4 - it "sniff alignment from library section" $ do+ it "sniffs indentation from library section" $ do let input = [ "name: foo" , "version: 0.0.0"
test/Hpack/RenderSpec.hs view
@@ -3,24 +3,33 @@ module Hpack.RenderSpec (spec) where import Helper-import Data.List +import Control.Monad.Reader (runReader)+ import Hpack.Syntax.DependencyVersion import Hpack.ConfigSpec hiding (spec) import Hpack.Config hiding (package)-import Hpack.Render.Dsl+import Hpack.Render.Dsl hiding (RenderSettings, defaultRenderSettings, render)+import qualified Hpack.Render.Dsl as Dsl import Hpack.Render-import Hpack.Syntax.Dependencies library :: Library-library = Library Nothing [] [] [] [] []+library = Library Nothing Nothing [] [] [] [] [] executable :: Section Executable-executable = section (Executable (Just "Main.hs") [] [])+executable = (section $ Executable (Just "Main.hs") [] []) {+ sectionLanguage = Just $ Language "Haskell2010"+} renderEmptySection :: Empty -> [Element] renderEmptySection Empty = [] +cabalVersion :: CabalVersion+cabalVersion = makeCabalVersion [1,12]++render :: Element -> [FilePath]+render = Dsl.render Dsl.defaultRenderSettings 0+ spec :: Spec spec = do describe "renderPackageWith" $ do@@ -119,20 +128,8 @@ , "" , "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 [@@ -232,9 +229,11 @@ ] describe "renderConditional" $ do+ let run = flip runReader (RenderEnv cabalVersion "foo")+ it "renders conditionals" $ do let conditional = Conditional "os(windows)" (section Empty) {sectionDependencies = deps ["Win32"]} Nothing- render defaultRenderSettings 0 (renderConditional renderEmptySection conditional) `shouldBe` [+ render (run $ renderConditional renderEmptySection conditional) `shouldBe` [ "if os(windows)" , " build-depends:" , " Win32"@@ -242,7 +241,7 @@ 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` [+ render (run $ renderConditional renderEmptySection conditional) `shouldBe` [ "if os(windows)" , " build-depends:" , " Win32"@@ -254,7 +253,7 @@ 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` [+ render (run $ renderConditional renderEmptySection conditional) `shouldBe` [ "if arch(i386)" , " ghc-options: -threaded" , " if os(windows)"@@ -265,7 +264,7 @@ 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` [+ render (run $ renderConditional renderEmptySection conditional) `shouldBe` [ "if os(windows)" , " build-depends:" , " Win32"@@ -276,52 +275,17 @@ describe "renderFlag" $ do it "renders flags" $ do let flag = (Flag "foo" (Just "some flag") True False)- render defaultRenderSettings 0 (renderFlag flag) `shouldBe` [+ render (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)+ (render $ renderSourceRepository repository) `shouldBe` [ "source-repository head" , " type: git"@@ -330,7 +294,7 @@ it "renders source-repository with subdir" $ do let repository = SourceRepository "https://github.com/hspec/hspec" (Just "hspec-core")- (render defaultRenderSettings 0 $ renderSourceRepository repository)+ (render $ renderSourceRepository repository) `shouldBe` [ "source-repository head" , " type: git"@@ -340,10 +304,10 @@ describe "renderDirectories" $ do it "replaces . with ./. (for compatibility with cabal syntax)" $ do- (render defaultRenderSettings 0 $ renderDirectories "name" ["."])+ (render $ renderDirectories "name" ["."]) `shouldBe` [ "name:"- , " ./."+ , " ./" ] describe "renderDependencies" $ do
test/Hpack/Syntax/DefaultsSpec.hs view
@@ -151,4 +151,4 @@ it "fails" $ do [yaml| 10- |] `shouldDecodeTo` left "Error while parsing $ - expected Object or String, encountered Number"+ |] `shouldDecodeTo` left "Error while parsing $ - expected Object or String, but encountered Number"
test/Hpack/Syntax/DependenciesSpec.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-} module Hpack.Syntax.DependenciesSpec (spec) where import Helper@@ -18,6 +19,19 @@ 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)++ it "accepts dependencies with multiple subcomponents including the main library" $ do+ parseDependency "dependency" "foo:{foo,bar,baz}" `shouldReturn` ("foo:{foo,bar,baz}", DependencyVersion Nothing AnyVersion)+ describe "fromValue" $ do context "when parsing Dependencies" $ do context "with a scalar" $ do@@ -28,8 +42,8 @@ it "accepts dependencies with constraints" $ do [yaml|- hpack >= 2 && < 3- |] `shouldDecodeTo_` Dependencies [("hpack", defaultInfo { dependencyInfoVersion = versionRange ">=2 && <3" })]+ hpack >= 2 && < 4+ |] `shouldDecodeTo_` Dependencies [("hpack", defaultInfo { dependencyInfoVersion = versionRange ">=2 && <4" })] context "with invalid constraint" $ do it "returns an error message" $ do@@ -45,8 +59,8 @@ it "accepts dependencies with constraints" $ do [yaml|- - hpack >= 2 && < 3- |] `shouldDecodeTo_` Dependencies [("hpack", defaultInfo { dependencyInfoVersion = versionRange ">=2 && <3" })]+ - hpack >= 2 && < 4+ |] `shouldDecodeTo_` Dependencies [("hpack", defaultInfo { dependencyInfoVersion = versionRange ">=2 && <4" })] it "accepts ^>=" $ do [yaml|@@ -125,7 +139,7 @@ it "rejects invalid values" $ do [yaml| hpack: []- |] `shouldDecodeTo` left "Error while parsing $.hpack - expected Null, Object, Number, or String, encountered Array"+ |] `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@@ -201,7 +215,7 @@ outer-name: name: inner-name path: somewhere- |] `shouldDecodeTo` Right (Dependencies [("outer-name", defaultInfo { dependencyInfoVersion = DependencyVersion source AnyVersion })], ["$.outer-name.name"])+ |] `shouldDecodeTo` Right (Dependencies [("outer-name", defaultInfo { dependencyInfoVersion = DependencyVersion source AnyVersion })], ["$.outer-name.name"], []) it "defaults to any version" $ do [yaml|@@ -213,7 +227,7 @@ [yaml| foo: version: {}- |] `shouldDecodeTo` left "Error while parsing $.foo.version - expected Null, Number, or String, encountered Object"+ |] `shouldDecodeTo` left "Error while parsing $.foo.version - expected Null, Number, or String, but encountered Object" it "accepts a string" $ do [yaml|
test/Hpack/Syntax/GitSpec.hs view
@@ -21,7 +21,7 @@ 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+ it "rejects . at the beginning of a component" $ do isValidRef "foo/.bar/baz" `shouldBe` False it "rejects two consecutive dots .." $ do
test/Hpack/Utf8Spec.hs view
@@ -18,7 +18,7 @@ B.writeFile name "foo\r\nbar" Utf8.readFile name `shouldReturn` "foo\nbar" - describe "writeFile" $ do+ describe "ensureFile" $ do it "uses system specific newline encoding" $ do inTempDirectory $ do let@@ -28,5 +28,5 @@ writeFile name c systemSpecific <- B.readFile name - Utf8.writeFile name c+ Utf8.ensureFile name c B.readFile name `shouldReturn` systemSpecific
test/Hpack/UtilSpec.hs view
@@ -30,41 +30,6 @@ 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
test/HpackSpec.hs view
@@ -1,102 +1,180 @@+{-# LANGUAGE OverloadedStrings #-} module HpackSpec (spec) where import Helper import Prelude hiding (readFile) import qualified Prelude as Prelude+import System.Exit (die) import Control.DeepSeq import Hpack.Config import Hpack.CabalFile-import Hpack hiding (hpack)+import Hpack.Error (formatHpackError)+import Hpack readFile :: FilePath -> IO String readFile name = Prelude.readFile name >>= (return $!!) spec :: Spec spec = do- describe "hpackResult" $ do- context "with existing cabal file" $ around_ inTempDirectory $ before_ (writeFile packageConfig "name: foo") $ do- let- file = "foo.cabal"+ 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"+ , ""+ ] - hpackWithVersion v = hpackResultWithVersion v defaultOptions- hpack = hpackResult defaultOptions- hpackForce = hpackResult defaultOptions {optionsForce = Force}+ 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"+ , ""+ ] - generated = Result [] file Generated- modifiedManually = Result [] file ExistingCabalFileWasModifiedManually- outputUnchanged = Result [] file OutputUnchanged- alreadyGeneratedByNewerHpack = Result [] file AlreadyGeneratedByNewerHpack+ 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"+ , ""+ ] - context "when cabal file was created manually" $ do- it "does not overwrite existing cabal file" $ do- let existing = "some existing cabal file"- writeFile file existing- hpack `shouldReturn` modifiedManually+ describe "renderCabalFile" $ do+ it "is inverse to readCabalFile" $ do+ expected <- lines <$> readFile "resources/test/hpack.cabal"+ Just c <- readCabalFile "resources/test/hpack.cabal"+ renderCabalFile "package.yaml" c {cabalFileGitConflictMarkers = ()} `shouldBe` expected++ describe "hpackResult" $ around_ inTempDirectory $ before_ (writeFile packageConfig "name: foo") $ do+ let+ file = "foo.cabal"++ hpackWithVersion v = hpackResultWithVersion (makeVersion v) defaultOptions >>= either (die . formatHpackError "hpack") return+ 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 - context "with --force" $ do- it "overwrites existing cabal file" $ do- _ <- hpack- expected <- readFile file- writeFile file "some existing cabal file"- hpackForce `shouldReturn` generated- readFile file `shouldReturn` expected+ with strategy item = context ("with " ++ show strategy) $ item strategy - context "when cabal file was created with hpack < 0.20.0" $ do- it "overwrites existing cabal file" $ do- _ <- hpack- expected <- readFile file- writeFile file "-- This file has been generated from package.yaml by hpack version 0.19.3."- hpack `shouldReturn` generated- readFile file `shouldReturn` expected+ context "without an existing cabal file" $ do+ with ForceHash generatesHash+ with PreferHash generatesHash+ with ForceNoHash doesNotGenerateHash+ with PreferNoHash doesNotGenerateHash - context "when cabal file was created with hpack >= 0.20.0" $ do- context "when hash is missing" $ do- it "does not overwrite existing cabal file" $ do- let existing = "-- This file has been generated from package.yaml by hpack version 0.20.0."- writeFile file existing- hpack `shouldReturn` modifiedManually- readFile file `shouldReturn` existing+ 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 "when hash is present" $ do- context "when exsting cabal file was generated with a newer version of hpack" $ do- it "does not overwrite existing cabal file" $ do- writeFile packageConfig $ unlines [- "name: foo"- , "version: 0.1.0"- ]- _ <- hpackWithVersion (makeVersion [0,22,0])- old <- readFile file+ context "with a hash" $ before_ (hpackWithStrategy ForceHash >> modifyPackageConfig) $ do+ with ForceHash generatesHash+ with PreferHash generatesHash+ with ForceNoHash doesNotGenerateHash+ with PreferNoHash generatesHash - writeFile packageConfig $ unlines [- "name: foo"- , "version: 0.2.0"- ]+ context "with manual modifications" $ before_ modifyCabalFile $ do+ with ForceHash doesNotOverwrite+ with PreferHash doesNotOverwrite+ with ForceNoHash doesNotGenerateHash+ with PreferNoHash doesNotOverwrite - hpackWithVersion (makeVersion [0,20,0]) `shouldReturn` alreadyGeneratedByNewerHpack- readFile file `shouldReturn` old+ context "when created manually" $ before_ manuallyCreateCabalFile $ do+ with ForceHash doesNotOverwrite+ with PreferHash doesNotOverwrite+ with ForceNoHash doesNotOverwrite+ with PreferNoHash doesNotOverwrite - context "when cabal file was modified manually" $ do- it "does not overwrite existing cabal file" $ do- _ <- hpack- old <- readFile file- let modified = old ++ "foo\n"- writeFile file modified- _ <- hpack- readFile file `shouldReturn` modified+ context "with --force" $ do+ it "overwrites cabal file" $ do+ hpackForce `shouldReturn` generated - context "when only the hpack version in the cabal file header changed" $ do- it "does not overwrite existing cabal file" $ do- _ <- hpackWithVersion (makeVersion [0,20,0])- old <- readFile file- hpack `shouldReturn` outputUnchanged- readFile file `shouldReturn` old+ 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 - it "does not complain if it's newer" $ do- _ <- hpackWithVersion (makeVersion [999,999,0])- old <- readFile file- hpack `shouldReturn` outputUnchanged- 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++ context "with git conflict markers" $ do+ context "when the new and the existing .cabal file are essentially the same" $ do+ it "still removes the conflict markers" $ do+ writeFile file $ unlines [+ "--"+ , "name: foo"+ ]+ hpack NoVerbose defaultOptions {optionsForce = Force}+ old <- readFile file+ let+ modified :: String+ modified = unlines $ case break (== "version: 0.0.0") $ lines old of+ (xs, v : ys) -> xs +++ "<<<<<<< ours" :+ v :+ "=======" :+ "version: 0.1.0" :+ ">>>>>>> theirs" : ys+ _ -> undefined+ writeFile file modified+ hpack NoVerbose defaultOptions+ readFile file `shouldReturn` old
+ test/SpecHook.hs view
@@ -0,0 +1,8 @@+{-# LANGUAGE OverloadedStrings #-}+module SpecHook where++import Test.Hspec+import qualified VCR++hook :: Spec -> Spec+hook = aroundAll_ (VCR.with "test/fixtures/vcr-tape.yaml")