hpack 0.34.5 → 0.39.6
raw patch · 37 files changed
Files
- CHANGELOG.md +88/−1
- LICENSE +1/−1
- driver/Main.hs +14/−2
- hpack.cabal +84/−63
- resources/test/hpack.cabal +231/−0
- src/Data/Aeson/Config/FromValue.hs +52/−6
- src/Data/Aeson/Config/Parser.hs +21/−7
- src/Hpack.hs +100/−40
- src/Hpack/CabalFile.hs +40/−14
- src/Hpack/Config.hs +421/−220
- src/Hpack/Defaults.hs +8/−14
- src/Hpack/Error.hs +59/−0
- src/Hpack/Options.hs +11/−3
- src/Hpack/Render.hs +155/−140
- src/Hpack/Render/Dsl.hs +69/−19
- src/Hpack/Render/Hints.hs +47/−16
- src/Hpack/Syntax/Dependencies.hs +11/−6
- src/Hpack/Syntax/DependencyVersion.hs +4/−0
- src/Hpack/Utf8.hs +12/−3
- src/Hpack/Util.hs +4/−2
- src/Hpack/Yaml.hs +20/−12
- src/Imports.hs +7/−0
- test/Data/Aeson/Config/FromValueSpec.hs +161/−6
- test/EndToEndSpec.hs +611/−152
- test/Helper.hs +5/−0
- test/Hpack/CabalFileSpec.hs +2/−2
- test/Hpack/ConfigSpec.hs +14/−3
- test/Hpack/DefaultsSpec.hs +2/−3
- test/Hpack/OptionsSpec.hs +10/−10
- test/Hpack/Render/DslSpec.hs +77/−5
- test/Hpack/Render/HintsSpec.hs +25/−8
- test/Hpack/RenderSpec.hs +23/−57
- test/Hpack/Syntax/DependenciesSpec.hs +4/−1
- test/Hpack/Syntax/GitSpec.hs +1/−1
- test/Hpack/Utf8Spec.hs +2/−2
- test/HpackSpec.hs +31/−5
- test/SpecHook.hs +8/−0
CHANGELOG.md view
@@ -1,3 +1,90 @@+## 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.*` @@ -11,7 +98,7 @@ - Reject empty `then` / `else` sections (see #362) - Omit conditionals that are always `false` from generated `.cabal` file (see #404)- - Infer correct `cabal-version` when `Path_` is used with `RebindableSyntax`+ - 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)
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,21 +1,24 @@-cabal-version: 1.12+cabal-version: 2.0 --- This file has been generated from package.yaml by hpack version 0.34.4.+-- This file has been generated from package.yaml by hpack version 0.39.1. -- -- see: https://github.com/sol/hpack name: hpack-version: 0.34.5+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@@ -23,37 +26,12 @@ location: https://github.com/sol/hpack library- hs-source-dirs:- src- ghc-options: -Wall- build-depends:- Cabal >=3.0.0.0 && <3.6- , Glob >=0.9.0- , aeson >=1.4.3.0- , base >=4.9 && <5- , bifunctors- , bytestring- , containers- , cryptonite- , deepseq- , directory >=1.2.5.0- , 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@@ -80,30 +58,28 @@ 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 >=3.0.0.0 && <3.6+ Cabal >=3.0.0.0 && <3.17 , Glob >=0.9.0 , aeson >=1.4.3.0- , base >=4.9 && <5+ , base >=4.13 && <5 , bifunctors , bytestring , containers- , cryptonite+ , cryptohash-sha256 , deepseq , 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@@ -111,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 >=3.0.0.0 && <3.6+ Cabal >=3.0.0.0 && <3.17 , Glob >=0.9.0- , HUnit >=1.6.0.0- , QuickCheck , aeson >=1.4.3.0- , base >=4.9 && <5+ , base >=4.13 && <5 , bifunctors , bytestring , containers- , cryptonite+ , cryptohash-sha256 , deepseq , 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@@ -178,6 +153,7 @@ Hpack.Utf8Spec Hpack.UtilSpec HpackSpec+ SpecHook Data.Aeson.Config.FromValue Data.Aeson.Config.Key Data.Aeson.Config.KeyMap@@ -188,6 +164,7 @@ Hpack.CabalFile Hpack.Config Hpack.Defaults+ Hpack.Error Hpack.Haskell Hpack.License Hpack.Module@@ -207,4 +184,48 @@ 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@@ -38,17 +41,24 @@ , Value(..) , Object , Array++, Alias(..)+, unAlias ) where import Imports +import Data.Monoid (Last(..)) import GHC.Generics+import GHC.TypeLits+import Data.Proxy import Data.Map.Lazy (Map) import qualified Data.Map.Lazy as Map import qualified Data.Vector as V 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(..))@@ -56,7 +66,7 @@ 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@@ -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 -> Key -> Parser a) -> Options -> Value -> Parser (S1 sel (Rec0 a) p)+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+ 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 :: S1 sel (Rec0 a) p)+ 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/Parser.hs view
@@ -28,6 +28,8 @@ , fromAesonPath , formatPath++, markDeprecated ) where import Imports@@ -45,7 +47,11 @@ 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@@ -56,6 +62,9 @@ type JSONPath = [JSONPathElement] +data Path = Consumed JSONPath | Deprecated JSONPath JSONPath+ deriving (Eq, Ord, Show)+ fromAesonPath :: Aeson.JSONPath -> JSONPath fromAesonPath = reverse . map fromAesonPathElement @@ -64,16 +73,16 @@ Aeson.Key k -> Key (Key.toText k) Aeson.Index n -> Index n -newtype Parser a = Parser {unParser :: WriterT (Set JSONPath) Aeson.Parser a}+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@@ -84,12 +93,12 @@ 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 ()@@ -110,7 +119,12 @@ 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)
src/Hpack.hs view
@@ -1,6 +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@@ -20,6 +21,7 @@ -- * Running Hpack , hpack , hpackResult+, hpackResultWithError , printResult , Result(..) , Status(..)@@ -29,11 +31,13 @@ , setProgramName , setTarget , setDecode+, setFormatYamlParseError , getOptions , Verbose(..) , Options(..) , Force(..) , GenerateHashStrategy(..)+, OutputStrategy(..) #ifdef TEST , hpackResultWithVersion@@ -56,10 +60,12 @@ 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 :: Maybe Version -> String programVersion Nothing = "hpack"@@ -79,6 +85,7 @@ , optionsForce :: Force , optionsGenerateHashStrategy :: GenerateHashStrategy , optionsToStdout :: Bool+, optionsOutputStrategy :: OutputStrategy } data GenerateHashStrategy = ForceHash | ForceNoHash | PreferHash | PreferNoHash@@ -97,12 +104,12 @@ Help -> do printHelp return Nothing- Run (ParseOptions verbose force hash toStdout file) -> do+ 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)+ return $ Just (verbose, Options defaultDecodeOptions {decodeOptionsTarget = file} force generateHash toStdout outputStrategy) ParseError -> do printHelp exitFailure@@ -111,7 +118,7 @@ printHelp = do name <- getProgName Utf8.hPutStrLn stderr $ unlines [- "Usage: " ++ name ++ " [ --silent ] [ --force | -f ] [ --[no-]hash ] [ PATH ] [ - ]"+ "Usage: " ++ name ++ " [ --silent ] [ --canonical ] [ --force | -f ] [ --[no-]hash ] [ PATH ] [ - ]" , " " ++ name ++ " --version" , " " ++ name ++ " --numeric-version" , " " ++ name ++ " --help"@@ -121,7 +128,7 @@ hpack verbose options = hpackResult options >>= printResult verbose defaultOptions :: Options-defaultOptions = Options defaultDecodeOptions NoForce PreferNoHash False+defaultOptions = Options defaultDecodeOptions NoForce PreferNoHash False MinimizeDiffs setTarget :: FilePath -> Options -> Options setTarget target options@Options{..} =@@ -135,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@@ -166,8 +208,8 @@ printWarnings :: [String] -> IO () printWarnings = mapM_ $ Utf8.hPutStrLn stderr . ("WARNING: " ++) -mkStatus :: CabalFile -> CabalFile -> Status-mkStatus new@(CabalFile _ mNewVersion mNewHash _) existing@(CabalFile _ mExistingVersion _ _)+mkStatus :: NewCabalFile -> ExistingCabalFile -> Status+mkStatus new@(CabalFile _ mNewVersion mNewHash _ _) existing@(CabalFile _ mExistingVersion _ _ _) | new `hasSameContent` existing = OutputUnchanged | otherwise = case mExistingVersion of Nothing -> ExistingCabalFileWasModifiedManually@@ -176,59 +218,77 @@ | isJust mNewHash && hashMismatch existing -> ExistingCabalFileWasModifiedManually | otherwise -> Generated -hasSameContent :: CabalFile -> CabalFile -> Bool-hasSameContent (CabalFile cabalVersionA _ _ a) (CabalFile cabalVersionB _ _ b) = cabalVersionA == cabalVersionB && a == b+hasSameContent :: NewCabalFile -> ExistingCabalFile -> Bool+hasSameContent (CabalFile cabalVersionA _ _ a ()) (CabalFile cabalVersionB _ _ b gitConflictMarkers) =+ cabalVersionA == cabalVersionB+ && a == b+ && gitConflictMarkers == DoesNotHaveGitConflictMarkers -hashMismatch :: CabalFile -> Bool+hashMismatch :: ExistingCabalFile -> Bool hashMismatch cabalFile = case cabalFileHash cabalFile of Nothing -> False- Just hash -> hash /= calculateHash cabalFile+ Just hash -> cabalFileGitConflictMarkers cabalFile == HasGitConflictMarkers || hash /= calculateHash cabalFile -calculateHash :: CabalFile -> Hash-calculateHash (CabalFile cabalVersion _ _ body) = sha256 (unlines $ cabalVersion ++ body)+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 generateHashStrategy toStdout) = do- DecodeResult pkg (lines -> cabalVersion) cabalFileName warnings <- readPackageConfig options >>= either die return- mExistingCabalFile <- readCabalFile cabalFileName- let- newCabalFile = makeCabalFile generateHashStrategy mExistingCabalFile cabalVersion v pkg+hpackResultWithError :: Options -> IO (Either HpackError Result)+hpackResultWithError = hpackResultWithVersion version - status = case force of- Force -> Generated- NoForce -> maybe Generated (mkStatus newCabalFile) mExistingCabalFile+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 - case status of- Generated -> writeCabalFile options toStdout cabalFileName newCabalFile- _ -> return ()+ status = case force of+ Force -> Generated+ NoForce -> maybe Generated (mkStatus newCabalFile) mExistingCabalFile - return Result {- resultWarnings = warnings- , resultCabalFile = cabalFileName- , resultStatus = status- }+ case status of+ Generated -> writeCabalFile options toStdout cabalFileName newCabalFile+ _ -> return () -writeCabalFile :: DecodeOptions -> Bool -> FilePath -> CabalFile -> IO ()+ 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.writeFile name+ write = if toStdout then Utf8.putStr else Utf8.ensureFile name -makeCabalFile :: GenerateHashStrategy -> Maybe CabalFile -> [String] -> Version -> Package -> CabalFile-makeCabalFile strategy mExistingCabalFile cabalVersion v pkg = cabalFile+makeCabalFile :: OutputStrategy -> GenerateHashStrategy -> Maybe ExistingCabalFile -> [String] -> Version -> Package -> NewCabalFile+makeCabalFile outputStrategy generateHashStrategy mExistingCabalFile cabalVersion v pkg = cabalFile where- cabalFile = CabalFile cabalVersion (Just v) hash body+ 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 strategy = Just $ calculateHash cabalFile+ | shouldGenerateHash mExistingCabalFile generateHashStrategy = Just $ calculateHash cabalFile | otherwise = Nothing - body = lines $ renderPackage (maybe [] cabalFileContents mExistingCabalFile) pkg+ body :: [String]+ body = lines $ renderPackage hints pkg -shouldGenerateHash :: Maybe CabalFile -> GenerateHashStrategy -> Bool+shouldGenerateHash :: Maybe ExistingCabalFile -> GenerateHashStrategy -> Bool shouldGenerateHash mExistingCabalFile strategy = case (strategy, mExistingCabalFile) of (ForceHash, _) -> True (ForceNoHash, _) -> False@@ -237,5 +297,5 @@ (_, Just CabalFile {cabalFileHash = Nothing}) -> False (_, Just CabalFile {cabalFileHash = Just _}) -> True -renderCabalFile :: FilePath -> CabalFile -> [String]-renderCabalFile file (CabalFile cabalVersion hpackVersion hash body) = cabalVersion ++ header file hpackVersion hash ++ body+renderCabalFile :: FilePath -> NewCabalFile -> [String]+renderCabalFile file (CabalFile cabalVersion hpackVersion hash body _) = cabalVersion ++ header file hpackVersion hash ++ body
src/Hpack/CabalFile.hs view
@@ -1,7 +1,19 @@+{-# 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 Imports @@ -12,28 +24,42 @@ import Hpack.Util -makeVersion :: [Int] -> Version-makeVersion v = Version v []--data CabalFile = CabalFile {+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 -> (cabalVersion, h, c)) = CabalFile cabalVersion (extractVersion h) (extractHash h) c+ clean :: [String]+ clean = removeGitConflictMarkers input - splitHeader :: String -> ([String], [String], [String])- splitHeader (removeGitConflictMarkers . lines -> c) =- case span (not . isComment) c of- (cabalVersion, xs) -> case span isComment xs of- (header, body) -> (cabalVersion, header, dropWhile null body)+ gitConflictMarkers :: GitConflictMarkers+ gitConflictMarkers+ | input == clean = DoesNotHaveGitConflictMarkers+ | otherwise = HasGitConflictMarkers + isComment :: String -> Bool isComment = ("--" `isPrefixOf`) extractHash :: [String] -> Maybe Hash
src/Hpack/Config.hs view
@@ -1,18 +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@@ -32,12 +35,15 @@ , packageConfig , DecodeResult(..) , readPackageConfig+, readPackageConfigWithError , renamePackage , packageDependencies , package , section , Package(..)+, CabalVersion(..)+, makeCabalVersion , Dependencies(..) , DependencyInfo(..) , VersionConstraint(..)@@ -59,10 +65,12 @@ , Cond(..) , Flag(..) , SourceRepository(..)+, Language(..) , BuildType(..) , GhcProfOption , GhcjsOption , CppOption+, AsmOption , CcOption , LdOption , Path(..)@@ -88,17 +96,19 @@ import qualified Data.Map.Lazy as Map import qualified Data.Aeson.Config.KeyMap as KeyMap import Data.Maybe+import Data.Monoid (Last(..)) import Data.Ord 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@@ -109,6 +119,7 @@ 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@@ -125,15 +136,19 @@ 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 = []@@ -145,6 +160,7 @@ , packageFlags = [] , packageExtraSourceFiles = [] , packageExtraDocFiles = []+ , packageExtraFiles = [] , packageDataFiles = [] , packageDataDir = Nothing , packageSourceRepository = Nothing@@ -185,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"@@ -222,18 +238,18 @@ } data ExecutableSection = ExecutableSection {- executableSectionMain :: Maybe FilePath+ 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 }@@ -265,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@@ -287,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@@ -320,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@@ -351,47 +382,52 @@ , 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@@ -411,16 +447,16 @@ 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@@ -474,17 +510,17 @@ 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) @@ -501,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@@ -524,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} @@ -549,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))@@ -561,9 +606,11 @@ , 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 GitHub+, packageConfigCodeberg :: Maybe GitHub , packageConfigGit :: Maybe String , packageConfigCustomSetup :: Maybe CustomSetupSection , packageConfigLibrary :: Maybe library@@ -611,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@@ -648,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@@ -676,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@@ -703,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@@ -725,48 +845,59 @@ , 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 (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 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)+ , makeVersion [3,12] <$ guard (executableHasPackageInfoModule sect) , sectionCabalVersion (concatMap getExecutableModules) sect ] executableHasGeneratedModules :: Section Executable -> Bool executableHasGeneratedModules = any (not . null . executableGeneratedModules) - sectionCabalVersion :: (Section a -> [Module]) -> Section a -> Maybe Version+ 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 (@@ -775,17 +906,23 @@ && 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"@@ -813,9 +950,13 @@ , "lhc" , "lhc-pkg" ]++ known_1_14 :: [String] known_1_14 = [ "hpc" ]++ known_1_22 :: [String] known_1_22 = [ "ghcjs" , "ghcjs-pkg"@@ -838,30 +979,44 @@ hasSubcomponents :: String -> Bool hasSubcomponents = elem ':' -sectionAll :: (Semigroup b, Monoid b) => (Section a -> b) -> Section a -> b+sectionAll :: Monoid b => (Section a -> b) -> Section a -> b sectionAll f sect = f sect <> foldMap (foldMap $ sectionAll f) (sectionConditionals sect) -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)+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@@ -874,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]@@ -892,6 +1048,7 @@ , packageFlags :: [Flag] , packageExtraSourceFiles :: [Path] , packageExtraDocFiles :: [Path]+, packageExtraFiles :: [Path] , packageDataFiles :: [Path] , packageDataDir :: Maybe FilePath , packageSourceRepository :: Maybe SourceRepository@@ -934,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]@@ -984,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@@ -1043,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@@ -1088,25 +1259,25 @@ 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) <>) - toSections :: (Monad m, Monoid a) => Maybe (Map String (WithCommonOptions CSources CxxSources JsSources a)) -> Warnings m (Map String (Section a))+ 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) - toLib = liftIO . toLibrary dir packageName_- toExecutables = toSections >=> traverse (liftIO . toExecutable dir packageName_)+ toLib = toLibrary dir packageName+ toExecutables = toSections >=> traverse (toExecutable dir packageName) mLibrary <- traverse (toSect >=> toLib) packageConfigLibrary internalLibraries <- toSections packageConfigInternalLibraries >>= traverse toLib@@ -1127,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 @@ -1152,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@@ -1170,6 +1343,7 @@ , packageFlags = flags , packageExtraSourceFiles = extraSourceFiles , packageExtraDocFiles = extraDocFiles+ , packageExtraFiles = extraFiles , packageDataFiles = dataFiles , packageDataDir = packageConfigDataDir , packageSourceRepository = sourceRepository@@ -1184,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)@@ -1206,7 +1381,7 @@ 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 = toSourceRepository <$> packageConfigGithub@@ -1214,18 +1389,26 @@ 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)@@ -1235,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" }@@ -1253,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@@ -1296,7 +1480,7 @@ where p = (/= CondBool False) . conditionalCondition -inferModules ::+inferModules :: (MonadIO m, State m) => FilePath -> String -> (a -> [Module])@@ -1304,14 +1488,23 @@ -> ([Module] -> [Module] -> a -> b) -> ([Module] -> a -> b) -> Section a- -> IO (Section b)-inferModules dir packageName_ getMentionedModules getInferredModules fromData fromConditionals = fmap removeConditionalsThatAreAlwaysFalse . 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@@ -1319,7 +1512,7 @@ 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@@ -1360,17 +1553,17 @@ } getMentionedExecutableModules :: ExecutableSection -> [Module]-getMentionedExecutableModules (ExecutableSection main otherModules generatedModules)=+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 getExecutableModules fromExecutableSection (fromExecutableSection []) . expandMain where 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@@ -1383,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{@@ -1394,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 = nub $ 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@@ -1422,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 = 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@@ -1490,10 +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!"]+ warnLegacySystemTool name = tell ["Listing " ++ show name ++ " under build-tools is deprecated! Please list system executables under system-build-tools instead!"] pathsModuleFromPackageName :: String -> Module-pathsModuleFromPackageName name = Module ("Paths_" ++ map f name)- where- f '-' = '_'- f x = x+pathsModuleFromPackageName name =+ Module ("Paths_" ++ moduleNameFromPackageName name)++moduleNameFromPackageName :: String -> String+moduleNameFromPackageName = map f+ where+ f '-' = '_'+ f x = x
src/Hpack/Defaults.hs view
@@ -14,18 +14,15 @@ import Imports -import Network.HTTP.Types import Network.HTTP.Client import Network.HTTP.Client.TLS 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 @@ -33,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@@ -47,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@@ -60,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/Options.hs view
@@ -16,12 +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@@ -34,8 +38,8 @@ file <- expandTarget defaultTarget target let options- | toStdout = ParseOptions NoVerbose Force hash toStdout file- | otherwise = ParseOptions verbose force hash 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@@ -43,11 +47,15 @@ forceFlags = ["--force", "-f"] hashFlag = "--hash" noHashFlag = "--no-hash"+ canonicalFlag = "--canonical" - flags = hashFlag : noHashFlag : 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
src/Hpack/Render.hs view
@@ -23,6 +23,7 @@ , Alignment(..) , CommaStyle(..) #ifdef TEST+, RenderEnv(..) , renderConditional , renderDependencies , renderLibraryFields@@ -30,7 +31,6 @@ , renderFlag , renderSourceRepository , renderDirectories-, formatDescription #endif ) where @@ -40,27 +40,47 @@ import Data.Maybe 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.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 $@@ -68,6 +88,7 @@ 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,45 +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)+ 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@@ -125,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"@@ -154,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) =- 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]@@ -198,11 +212,11 @@ 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{..} =@@ -221,36 +235,44 @@ renderVisibility :: String -> Element renderVisibility = Field "visibility" . Literal -renderSection :: (a -> [Element]) -> [Element] -> [Element] -> Section a -> [Element]-renderSection renderSectionData extraFieldsStart extraFieldsEnd Section{..} = addVerbatim sectionVerbatim $- extraFieldsStart- ++ renderSectionData sectionData ++ [- renderDirectories "hs-source-dirs" sectionSourceDirs- , renderDefaultExtensions sectionDefaultExtensions- , renderOtherExtensions sectionOtherExtensions- , renderGhcOptions sectionGhcOptions- , renderGhcProfOptions sectionGhcProfOptions- , renderGhcjsOptions sectionGhcjsOptions- , renderCppOptions sectionCppOptions- , renderCcOptions sectionCcOptions- , renderCxxOptions sectionCxxOptions- , renderDirectories "include-dirs" sectionIncludeDirs- , Field "install-includes" (LineSeparatedList sectionInstallIncludes)- , Field "c-sources" (renderPaths sectionCSources)- , Field "cxx-sources" (renderPaths sectionCxxSources)- , Field "js-sources" (renderPaths sectionJsSources)- , renderDirectories "extra-lib-dirs" sectionExtraLibDirs- , Field "extra-libraries" (LineSeparatedList sectionExtraLibraries)- , renderDirectories "extra-frameworks-dirs" sectionExtraFrameworksDirs- , Field "frameworks" (LineSeparatedList sectionFrameworks)- , renderLdOptions sectionLdOptions- , Field "pkgconfig-depends" (CommaSeparatedList sectionPkgConfigDependencies)- ]- ++ renderBuildTools sectionBuildTools sectionSystemBuildTools- ++ renderDependencies "build-depends" sectionDependencies- ++ maybe [] (return . renderBuildable) sectionBuildable- ++ map (renderConditional renderSectionData) sectionConditionals- ++ extraFieldsEnd+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@@ -281,12 +303,12 @@ [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 " ++ renderCond condition) (renderSection renderSectionData [] [] sect)+ if_ = Stanza ("if " ++ renderCond condition) <$> renderSection renderSectionData [] sect renderCond :: Cond -> String renderCond = \ case@@ -294,9 +316,6 @@ CondBool True -> "true" CondBool False -> "false" -defaultLanguage :: Element-defaultLanguage = Field "default-language" "Haskell2010"- renderDirectories :: String -> [String] -> Element renderDirectories name = Field name . LineSeparatedList . replaceDots where@@ -342,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"@@ -375,26 +405,8 @@ 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@@ -415,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,13 +20,18 @@ #ifdef TEST , Lines (..)+, IndentOrAlign (..) , renderValue , addSortKey #endif ) where 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]@@ -33,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@@ -46,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@@ -109,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,10 +1,13 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE RecordWildCards #-} module Hpack.Render.Hints ( FormattingHints (..) , sniffFormattingHints+, RenderSettings (..)+, defaultRenderSettings+, formattingHintsRenderSettings #ifdef TEST-, sniffRenderSettings , extractFieldOrder , extractSectionsFieldOrder , sanitize@@ -21,14 +24,16 @@ import Data.Char import Data.Maybe -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@@ -36,7 +41,8 @@ formattingHintsFieldOrder = extractFieldOrder input , formattingHintsSectionsFieldOrder = extractSectionsFieldOrder input , formattingHintsAlignment = sniffAlignment input-, formattingHintsRenderSettings = sniffRenderSettings input+, formattingHintsIndentation = sniffIndentation input+, formattingHintsCommaStyle = sniffCommaStyle input } sanitize :: [String] -> [String]@@ -68,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@@ -108,11 +130,20 @@ where startsWithComma = isPrefixOf "," . dropWhile isSpace -sniffRenderSettings :: [String] -> RenderSettings-sniffRenderSettings input = RenderSettings indentation fieldAlignment commaStyle- where- indentation = max def $ fromMaybe def (sniffIndentation input)- where def = renderSettingsIndentation defaultRenderSettings+data RenderSettings = RenderSettings {+ renderSettingsIndentation :: Int+, renderSettingsFieldAlignment :: Alignment+, renderSettingsCommaStyle :: CommaStyle+} deriving (Eq, Show) - fieldAlignment = renderSettingsFieldAlignment defaultRenderSettings- commaStyle = fromMaybe (renderSettingsCommaStyle defaultRenderSettings) (sniffCommaStyle input)+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/Dependencies.hs view
@@ -73,10 +73,15 @@ parseDependency subject = fmap fromCabal . cabalParse subject . T.unpack where fromCabal :: D.Dependency -> (String, DependencyVersion)- fromCabal d = (toName (D.depPkgName d) (DependencySet.toList $ D.depLibraries 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) <> "}" - toName :: D.PackageName -> [D.LibraryName] -> String- toName package components = prettyShow package <> case components of- [D.LMainLibName] -> ""- [D.LSubLibName lib] -> ":" <> prettyShow lib- xs -> ":{" <> (intercalate "," $ map prettyShow [name | D.LSubLibName name <- xs]) <> "}"+ renderComponent :: D.LibraryName -> String+ renderComponent D.LMainLibName = prettyShow pkgName+ renderComponent (D.LSubLibName name) = prettyShow name
src/Hpack/Syntax/DependencyVersion.hs view
@@ -4,6 +4,7 @@ {-# LANGUAGE ViewPatterns #-} module Hpack.Syntax.DependencyVersion ( githubBaseUrl+, codebergBaseUrl , GitRef , GitUrl @@ -44,6 +45,9 @@ githubBaseUrl :: String githubBaseUrl = "https://github.com/"++codebergBaseUrl :: String+codebergBaseUrl = "https://codeberg.org/" type GitUrl = String type GitRef = String
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
@@ -4,6 +4,7 @@ , GhcProfOption , GhcjsOption , CppOption+, AsmOption , CcOption , CxxOption , LdOption@@ -31,7 +32,7 @@ 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@@ -46,6 +47,7 @@ type GhcProfOption = String type GhcjsOption = String type CppOption = String+type AsmOption = String type CcOption = String type CxxOption = String type LdOption = String@@ -128,7 +130,7 @@ 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
src/Hpack/Yaml.hs view
@@ -14,6 +14,10 @@ -- tool that supports Hpack (e.g. @stack@ or @cabal2nix@). decodeYaml+, decodeYamlWithParseError+, ParseException+, formatYamlParseError+, formatWarning , module Data.Aeson.Config.FromValue ) where @@ -25,18 +29,22 @@ 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
@@ -1,10 +1,17 @@+{-# 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
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|@@ -87,6 +113,135 @@ age: "23" |] `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/EndToEndSpec.hs view
@@ -11,7 +11,7 @@ import Helper import Test.HUnit -import System.Directory (canonicalizePath, createDirectory)+import System.Directory (canonicalizePath) import Data.Maybe import Data.List import Data.String.Interpolate@@ -19,8 +19,8 @@ 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 Hpack.Config (packageConfig, readPackageConfig, DecodeOptions(..), defaultDecodeOptions, DecodeResult(..))+import Hpack.Render.Hints (FormattingHints(..), sniffFormattingHints, formattingHintsRenderSettings) import qualified Paths_hpack as Hpack (version) @@ -28,17 +28,22 @@ writeFile file c = touch file >> Prelude.writeFile file c spec :: Spec-spec = around_ (inTempDirectoryNamed "foo") $ do+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|- other-modules:- Paths_foo+ |] `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@@ -62,34 +67,135 @@ , GHC == 7.4.2 |] - it "warns on duplicate fields" $ do- [i|- name: foo- name: foo- |] `shouldWarn` [- "package.yaml: Duplicate field $.name"- ]+ 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_foo+ 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_foo+ other-modules: Paths_my_package |] `shouldRenderTo` library [i|+ default-language: Haskell2010 |] - context "with RebindableSyntax and OverloadedStrings or OverloadedStrings" $ do+ context "when Paths_ is used with RebindableSyntax and (OverloadedStrings or OverloadedLists)" $ do it "infers cabal-version 2.2" $ do [i| default-extensions: [RebindableSyntax, OverloadedStrings]@@ -99,7 +205,10 @@ RebindableSyntax OverloadedStrings other-modules:- Paths_foo+ 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@@ -109,11 +218,12 @@ library: when: - condition: false- other-modules: Paths_foo+ other-modules: Paths_my_package |] `shouldRenderTo` (library [i| default-extensions: RebindableSyntax OverloadedStrings+ default-language: Haskell2010 |]) describe "spec-version" $ do@@ -204,6 +314,18 @@ 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|@@ -268,6 +390,26 @@ 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|@@ -299,13 +441,36 @@ github: sol/hpack-template path: defaults.yaml ref: "2017"- |] `shouldRenderTo` library [i|+ |] `shouldRenderTo` library_ [i| exposed-modules: Foo- other-modules:- Paths_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"@@ -345,7 +510,6 @@ |] `shouldFailWith` [i|cycle in defaults (#{canonic1} -> #{canonic2} -> #{canonic1})|] it "fails if defaults don't exist" $ do- pending [i| defaults: github: sol/foo@@ -396,9 +560,7 @@ defaults: local: defaults/foo.yaml library: {}- |] `shouldRenderTo` library [i|- other-modules:- Paths_foo+ |] `shouldRenderTo` library_ [i| default-extensions: RecordWildCards DeriveFunctor@@ -454,7 +616,9 @@ license: BSD-3-Clause library other-modules:- Paths_foo+ Paths_my_package+ autogen-modules:+ Paths_my_package cxx-options: -Wall default-language: Haskell2010 |]) {packageCabalVersion = "2.2"}@@ -468,7 +632,9 @@ license: some-license library other-modules:- Paths_foo+ Paths_my_package+ autogen-modules:+ Paths_my_package cxx-options: -Wall default-language: Haskell2010 |]) {packageCabalVersion = "2.2"}@@ -557,31 +723,78 @@ - "*.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+ describe "extra-files" $ do+ it "accepts extra-files" $ do+ touch "CHANGES.markdown"+ touch "README.markdown" [i|- executable:- build-tools:- alex == 0.1.0- |] `shouldRenderTo` executable_ "foo" [i|- build-tools:- alex ==0.1.0- |]+ extra-files:+ - CHANGES.markdown+ - README.markdown+ |] `shouldRenderTo` (package [i|+ extra-files:+ CHANGES.markdown+ README.markdown+ |]) {packageCabalVersion = "3.14"} - 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"- }+ 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|@@ -597,7 +810,7 @@ it "gives per-section unqualified names precedence over global qualified names" $ do [i| build-tools:- - foo:bar == 0.1.0+ - my-package:bar == 0.1.0 executables: bar: build-tools:@@ -614,22 +827,38 @@ executables: bar: build-tools:- - foo:bar == 0.2.0+ - 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_ "foo" [i|+ |] `shouldRenderTo` (executable_ "my-package" [i| build-tools: ghc >=7.10- |]) { packageWarnings = ["Listing \"ghc\" under build-tools is deperecated! Please list system executables under system-build-tools instead!"] }+ |]) { 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@@ -637,7 +866,7 @@ executable: system-build-tools: ghc >= 7.10- |] `shouldRenderTo` executable_ "foo" [i|+ |] `shouldRenderTo` executable_ "my-package" [i| build-tools: ghc >=7.10 |]@@ -648,7 +877,7 @@ executable: system-build-tools: hpc- |] `shouldRenderTo` (executable_ "foo" [i|+ |] `shouldRenderTo` (executable_ "my-package" [i| build-tools: hpc |]) {packageCabalVersion = "1.14"}@@ -659,7 +888,7 @@ executable: system-build-tools: ghcjs- |] `shouldRenderTo` (executable_ "foo" [i|+ |] `shouldRenderTo` (executable_ "my-package" [i| build-tools: ghcjs |]) {packageCabalVersion = "1.22"}@@ -670,7 +899,9 @@ executable: system-build-tools: g++ >= 5.4.0- |] `shouldRenderTo` (executable_ "foo" [i|+ |] `shouldRenderTo` (executable_ "my-package" [i|+ autogen-modules:+ Paths_my_package build-tools: g++ >=5.4.0 |]) {packageCabalVersion = "2.0"}@@ -680,16 +911,29 @@ [i| executable: dependencies: base- |] `shouldRenderTo` executable_ "foo" [i|+ |] `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_ "foo" [i|+ |] `shouldRenderTo` (executable_ "my-package" [i|+ autogen-modules:+ Paths_my_package build-depends: foo:bar |]) {packageCabalVersion = "3.0"}@@ -700,7 +944,7 @@ dependencies: - base - transformers- |] `shouldRenderTo` executable_ "foo" [i|+ |] `shouldRenderTo` executable_ "my-package" [i| build-depends: base , transformers@@ -713,7 +957,7 @@ - base executable: dependencies: hspec- |] `shouldRenderTo` executable_ "foo" [i|+ |] `shouldRenderTo` executable_ "my-package" [i| build-depends: base , hspec@@ -725,7 +969,7 @@ - base executable: dependencies: base >= 2- |] `shouldRenderTo` executable_ "foo" [i|+ |] `shouldRenderTo` executable_ "my-package" [i| build-depends: base >=2 |]@@ -737,12 +981,24 @@ - QtWebKit - weston executable: {}- |] `shouldRenderTo` executable_ "foo" [i|+ |] `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|@@ -750,7 +1006,7 @@ - foo - bar executable: {}- |] `shouldRenderTo` executable_ "foo" [i|+ |] `shouldRenderTo` executable_ "my-package" [i| include-dirs: foo bar@@ -763,12 +1019,21 @@ - foo.h - bar.h executable: {}- |] `shouldRenderTo` executable_ "foo" [i|+ |] `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|@@ -776,7 +1041,7 @@ js-sources: - foo.js - jsbits/*.js- |] `shouldRenderTo` executable_ "foo" [i|+ |] `shouldRenderTo` executable_ "my-package" [i| js-sources: foo.js jsbits/bar.js@@ -788,18 +1053,46 @@ - foo.js - jsbits/*.js executable: {}- |] `shouldRenderTo` executable_ "foo" [i|+ |] `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_ "foo" [i|+ |] `shouldRenderTo` (executable_ "my-package" [i|+ autogen-modules:+ Paths_my_package cxx-options: -Wall |]) {packageCabalVersion = "2.2"} @@ -814,7 +1107,12 @@ when: condition: True cxx-options: -Wall- |] `shouldRenderTo` (executable_ "foo" [i|+ |] `shouldRenderTo` (executable "my-package" [i|+ other-modules:+ Paths_my_package+ autogen-modules:+ Paths_my_package+ default-language: Haskell2010 if true if true if true@@ -828,12 +1126,71 @@ cxx-sources: - foo.cc - cxxbits/*.cc- |] `shouldRenderTo` (executable_ "foo" [i|+ |] `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|@@ -841,7 +1198,7 @@ - foo - bar executable: {}- |] `shouldRenderTo` executable_ "foo" [i|+ |] `shouldRenderTo` executable_ "my-package" [i| extra-lib-dirs: foo bar@@ -854,7 +1211,7 @@ - foo - bar executable: {}- |] `shouldRenderTo` executable_ "foo" [i|+ |] `shouldRenderTo` executable_ "my-package" [i| extra-libraries: foo bar@@ -867,7 +1224,7 @@ - foo - bar executable: {}- |] `shouldRenderTo` executable_ "foo" [i|+ |] `shouldRenderTo` executable_ "my-package" [i| extra-frameworks-dirs: foo bar@@ -880,7 +1237,7 @@ - foo - bar executable: {}- |] `shouldRenderTo` executable_ "foo" [i|+ |] `shouldRenderTo` executable_ "my-package" [i| frameworks: foo bar@@ -979,6 +1336,8 @@ library: signatures: Foo |] `shouldRenderTo` (library_ [i|+ autogen-modules:+ Paths_my_package signatures: Foo |]) {packageCabalVersion = "2.0"}@@ -995,6 +1354,7 @@ Foo other-modules: Foo+ default-language: Haskell2010 |] context "with mixins" $ do@@ -1007,13 +1367,30 @@ - (Blah as Etc) |] `shouldRenderTo` (library [i| other-modules:- Paths_foo+ 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"@@ -1025,7 +1402,9 @@ exposed-modules: Foo other-modules:- Paths_foo+ Paths_my_package+ autogen-modules:+ Paths_my_package hs-source-dirs: src |]@@ -1054,7 +1433,9 @@ |] `shouldRenderTo` (internalLibrary "bar" [i| visibility: public other-modules:- Paths_foo+ Paths_my_package+ autogen-modules:+ Paths_my_package |]) {packageCabalVersion = "3.0"} context "when inferring modules" $ do@@ -1071,7 +1452,8 @@ exposed-modules: Foo other-modules:- Paths_foo+ Paths_my_package+ default-language: Haskell2010 |] it "ignores duplicate modules" $ do@@ -1086,7 +1468,8 @@ exposed-modules: Foo other-modules:- Paths_foo+ Paths_my_package+ default-language: Haskell2010 |] context "with exposed-modules" $ do@@ -1104,7 +1487,8 @@ Foo other-modules: Bar- Paths_foo+ Paths_my_package+ default-language: Haskell2010 |] context "with other-modules" $ do@@ -1122,6 +1506,7 @@ Foo other-modules: Bar+ default-language: Haskell2010 |] context "with both exposed-modules and other-modules" $ do@@ -1140,6 +1525,7 @@ Foo other-modules: Bar+ default-language: Haskell2010 |] context "with neither exposed-modules nor other-modules" $ do@@ -1156,7 +1542,8 @@ Bar Foo other-modules:- Paths_foo+ Paths_my_package+ default-language: Haskell2010 |] context "with a conditional" $ do@@ -1170,16 +1557,18 @@ condition: os(windows) exposed-modules: - Foo- - Paths_foo- |] `shouldRenderTo` library [i|- hs-source-dirs:- src- if os(windows)+ - Paths_my_package+ |] `shouldRenderTo` package [i|+ library+ hs-source-dirs:+ src exposed-modules:- Foo- Paths_foo- exposed-modules:- Bar+ Bar+ default-language: Haskell2010+ if os(windows)+ exposed-modules:+ Foo+ Paths_my_package |] context "with a source-dir inside the conditional" $ do@@ -1190,14 +1579,16 @@ when: condition: os(windows) source-dirs: windows- |] `shouldRenderTo` library [i|- other-modules:- Paths_foo- if os(windows)+ |] `shouldRenderTo` package [i|+ library other-modules:- Foo- hs-source-dirs:- windows+ Paths_my_package+ default-language: Haskell2010+ if os(windows)+ other-modules:+ Foo+ hs-source-dirs:+ windows |] it "does not infer outer modules" $ do@@ -1213,17 +1604,19 @@ 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/+ |] `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@@ -1236,11 +1629,13 @@ exposed-modules: Foo other-modules:- Paths_foo+ 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@@ -1257,11 +1652,13 @@ exposed-modules: Exposed other-modules:- Paths_foo+ 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@@ -1274,19 +1671,23 @@ 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+ |] `shouldRenderTo` (package [i|+ library other-modules:- Other+ Paths_my_package autogen-modules:- Other- Exposed+ 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@@ -1304,7 +1705,8 @@ src other-modules: Foo- Paths_foo+ Paths_my_package+ default-language: Haskell2010 |] it "allows to specify other-modules" $ do@@ -1322,6 +1724,7 @@ src other-modules: Baz+ default-language: Haskell2010 |] it "does not infer any mentioned generated modules" $ do@@ -1337,12 +1740,31 @@ hs-source-dirs: src other-modules:- Paths_foo+ 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"@@ -1357,9 +1779,10 @@ |] `shouldRenderTo` executable "foo" [i| other-modules: Bar- Paths_foo+ Paths_my_package hs-source-dirs: src+ default-language: Haskell2010 if os(windows) other-modules: Foo@@ -1378,9 +1801,10 @@ |] `shouldRenderTo` executable "foo" [i| other-modules: Foo- Paths_foo+ Paths_my_package hs-source-dirs: src+ default-language: Haskell2010 if os(windows) other-modules: Bar@@ -1389,6 +1813,16 @@ |] 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"@@ -1404,7 +1838,8 @@ src other-modules: Bar- Paths_foo+ Paths_my_package+ default-language: Haskell2010 |] context "with a conditional" $ do@@ -1417,8 +1852,11 @@ when: condition: os(windows) main: Foo.hs- |] `shouldRenderTo` executable_ "foo" [i|+ |] `shouldRenderTo` executable "foo" [i| ghc-options: -Wall+ other-modules:+ Paths_my_package+ default-language: Haskell2010 if os(windows) main-is: Foo.hs |]@@ -1430,7 +1868,10 @@ when: condition: os(windows) main: Foo- |] `shouldRenderTo` executable_ "foo" [i|+ |] `shouldRenderTo` executable "foo" [i|+ other-modules:+ Paths_my_package+ default-language: Haskell2010 if os(windows) main-is: Foo.hs ghc-options: -main-is Foo@@ -1443,7 +1884,10 @@ condition: os(windows) dependencies: Win32 executable: {}- |] `shouldRenderTo` executable_ "foo" [i|+ |] `shouldRenderTo` executable "my-package" [i|+ other-modules:+ Paths_my_package+ default-language: Haskell2010 if os(windows) build-depends: Win32@@ -1477,7 +1921,10 @@ else: dependencies: unix executable: {}- |] `shouldRenderTo` executable_ "foo" [i|+ |] `shouldRenderTo` executable "my-package" [i|+ other-modules:+ Paths_my_package+ default-language: Haskell2010 if os(windows) build-depends: Win32@@ -1567,7 +2014,7 @@ |] `shouldRenderTo` package [i| library other-modules:- Paths_foo+ Paths_my_package default-language: Haskell2010 foo: 23 bar: 42@@ -1584,7 +2031,7 @@ |] `shouldRenderTo` package [i| library other-modules:- Paths_foo+ Paths_my_package default-language: Haskell2010 build-depneds: foo@@ -1600,16 +2047,33 @@ |] `shouldRenderTo` package [i| library other-modules:- Paths_foo+ Paths_my_package |] context "when specified globally" $ do it "overrides header fields" $ do [i| verbatim:- cabal-version: foo- |] `shouldRenderTo` (package "") {packageCabalVersion = "foo"}+ 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|@@ -1629,7 +2093,7 @@ foo: 23 library other-modules:- Paths_foo+ Paths_my_package default-language: Haskell2010 |] @@ -1644,7 +2108,7 @@ test-suite spec type: detailed-0.9 other-modules:- Paths_foo+ Paths_my_package default-language: Haskell2010 |] describe "default value of maintainer" $ do@@ -1681,9 +2145,9 @@ return $ case mPackage of Right (DecodeResult pkg cabalVersion _ warnings) -> let- FormattingHints{..} = sniffFormattingHints (lines old)+ hints@FormattingHints{..} = sniffFormattingHints (lines old) alignment = fromMaybe 0 formattingHintsAlignment- settings = formattingHintsRenderSettings+ settings = formattingHintsRenderSettings hints output = cabalVersion ++ Hpack.renderPackageWith settings alignment formattingHintsFieldOrder formattingHintsSectionsFieldOrder pkg in Right (warnings, output)@@ -1697,12 +2161,9 @@ 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+ 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@@ -1732,7 +2193,7 @@ content = [i| library other-modules:- Paths_foo+ Paths_my_package #{indentBy 2 $ unindent l} default-language: Haskell2010 |]@@ -1743,7 +2204,6 @@ content = [i| library #{indentBy 2 $ unindent l}- default-language: Haskell2010 |] internalLibrary :: String -> String -> Package@@ -1761,7 +2221,7 @@ content = [i| executable #{name} other-modules:- Paths_foo+ Paths_my_package #{indentBy 2 $ unindent e} default-language: Haskell2010 |]@@ -1772,11 +2232,10 @@ 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 []+package c = Package "my-package" "0.0.0" "Simple" "1.12" c [] data Package = Package { packageName :: String@@ -1802,7 +2261,7 @@ license :: String license = [i|-Copyright (c) 2014-2018 Simon Hengel <sol@typeful.net>+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
@@ -11,6 +11,7 @@ , module System.FilePath , withCurrentDirectory , yaml+, makeVersion ) where import Imports@@ -19,6 +20,7 @@ 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@@ -44,3 +46,6 @@ yaml :: Language.Haskell.TH.Quote.QuasiQuoter yaml = yamlQQ++makeVersion :: [Int] -> Version+makeVersion v = Version v []
test/Hpack/CabalFileSpec.hs view
@@ -28,12 +28,12 @@ it "includes hash" $ do inTempDirectory $ do writeFile file $ mkHeader "package.yaml" version hash- readCabalFile file `shouldReturn` Just (CabalFile [] (Just version) (Just 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" ++ mkHeader "package.yaml" version hash)- readCabalFile file `shouldReturn` Just (CabalFile ["cabal-version: 2.2"] (Just version) (Just 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
@@ -28,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@@ -164,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@@ -223,7 +225,7 @@ withPackageConfig_ [i| category: Data |]- (`shouldBe` package {packageCategory = Just "Data"})+ (`shouldBe` package {packageCategory = ["Data"]}) it "accepts author" $ do withPackageConfig_ [i|@@ -418,6 +420,15 @@ withPackageConfig_ [i| library: source-dirs:+ - foo+ - bar+ |]+ (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 |]
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/OptionsSpec.hs view
@@ -18,10 +18,10 @@ context "by default" $ do it "returns Run" $ do- parseOptions defaultTarget [] `shouldReturn` Run (ParseOptions Verbose NoForce Nothing 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 Nothing 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,31 +29,31 @@ context "with --silent" $ do it "sets optionsVerbose to NoVerbose" $ do- parseOptions defaultTarget ["--silent"] `shouldReturn` Run (ParseOptions NoVerbose NoForce Nothing 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 Nothing 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 Nothing 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)+ 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)+ 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)- parseOptions defaultTarget ["--hash", "--no-hash"] `shouldReturn` Run (ParseOptions Verbose NoForce (Just False) False defaultTarget)+ 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 Nothing 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,11 +3,11 @@ import Test.Hspec import Hpack.Render.Hints-import Hpack.Render.Dsl+import Hpack.Render.Dsl (CommaStyle(..)) spec :: Spec spec = do- describe "sniffRenderSettings" $ do+ describe "formattingHintsRenderSettings" $ do context "when sniffed indentation is < default" $ do it "uses default instead" $ do let input = [@@ -15,13 +15,14 @@ , "exposed-modules:" , " Foo" ]- sniffIndentation input `shouldBe` Just 0- renderSettingsIndentation (sniffRenderSettings input) `shouldBe` 2+ 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: "@@ -38,7 +39,7 @@ describe "extractSectionsFieldOrder" $ do it "splits input into sections" $ do let input = [- "name: cabalize"+ "name: hpack" , "version: 0.0.0" , "" , "library"@@ -88,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"@@ -98,13 +99,29 @@ it "ignores fields without a value on the same line" $ do let input = [- "name: cabalize"+ "name: hpack" , "version: 0.0.0" , "description: " , " foo" , " bar" ] 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
test/Hpack/RenderSpec.hs view
@@ -4,21 +4,32 @@ import Helper +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 library :: Library 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@@ -117,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 [@@ -230,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"@@ -240,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"@@ -252,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)"@@ -263,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"@@ -274,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"@@ -328,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"@@ -338,7 +304,7 @@ describe "renderDirectories" $ do it "replaces . with ./. (for compatibility with cabal syntax)" $ do- (render defaultRenderSettings 0 $ renderDirectories "name" ["."])+ (render $ renderDirectories "name" ["."]) `shouldBe` [ "name:" , " ./"
test/Hpack/Syntax/DependenciesSpec.hs view
@@ -29,6 +29,9 @@ 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@@ -212,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|
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/HpackSpec.hs view
@@ -1,15 +1,18 @@+{-# 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 $!!)@@ -47,15 +50,15 @@ describe "renderCabalFile" $ do it "is inverse to readCabalFile" $ do- expected <- lines <$> readFile "hpack.cabal"- Just c <- readCabalFile "hpack.cabal"- renderCabalFile "package.yaml" c `shouldBe` expected+ 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+ hpackWithVersion v = hpackResultWithVersion (makeVersion v) defaultOptions >>= either (die . formatHpackError "hpack") return hpackWithStrategy strategy = hpackResult defaultOptions { optionsGenerateHashStrategy = strategy } hpackForce = hpackResult defaultOptions {optionsForce = Force} @@ -152,3 +155,26 @@ 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")