diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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) diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2014-2018 Simon Hengel +Copyright (c) 2014-2026 Simon Hengel Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal diff --git a/driver/Main.hs b/driver/Main.hs --- a/driver/Main.hs +++ b/driver/Main.hs @@ -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 diff --git a/hpack.cabal b/hpack.cabal --- a/hpack.cabal +++ b/hpack.cabal @@ -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 +description: See the README at category: Development homepage: https://github.com/sol/hpack#readme bug-reports: https://github.com/sol/hpack/issues +author: Simon Hengel maintainer: Simon Hengel 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 diff --git a/resources/test/hpack.cabal b/resources/test/hpack.cabal new file mode 100644 --- /dev/null +++ b/resources/test/hpack.cabal @@ -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 +category: Development +homepage: https://github.com/sol/hpack#readme +bug-reports: https://github.com/sol/hpack/issues +author: Simon Hengel +maintainer: Simon Hengel +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 diff --git a/src/Data/Aeson/Config/FromValue.hs b/src/Data/Aeson/Config/FromValue.hs --- a/src/Data/Aeson/Config/FromValue.hs +++ b/src/Data/Aeson/Config/FromValue.hs @@ -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 diff --git a/src/Data/Aeson/Config/Parser.hs b/src/Data/Aeson/Config/Parser.hs --- a/src/Data/Aeson/Config/Parser.hs +++ b/src/Data/Aeson/Config/Parser.hs @@ -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) diff --git a/src/Hpack.hs b/src/Hpack.hs --- a/src/Hpack.hs +++ b/src/Hpack.hs @@ -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 . +-- +-- 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 diff --git a/src/Hpack/CabalFile.hs b/src/Hpack/CabalFile.hs --- a/src/Hpack/CabalFile.hs +++ b/src/Hpack/CabalFile.hs @@ -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 diff --git a/src/Hpack/Config.hs b/src/Hpack/Config.hs --- a/src/Hpack/Config.hs +++ b/src/Hpack/Config.hs @@ -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 diff --git a/src/Hpack/Defaults.hs b/src/Hpack/Defaults.hs --- a/src/Hpack/Defaults.hs +++ b/src/Hpack/Defaults.hs @@ -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 diff --git a/src/Hpack/Error.hs b/src/Hpack/Error.hs new file mode 100644 --- /dev/null +++ b/src/Hpack/Error.hs @@ -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 diff --git a/src/Hpack/Options.hs b/src/Hpack/Options.hs --- a/src/Hpack/Options.hs +++ b/src/Hpack/Options.hs @@ -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 diff --git a/src/Hpack/Render.hs b/src/Hpack/Render.hs --- a/src/Hpack/Render.hs +++ b/src/Hpack/Render.hs @@ -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) diff --git a/src/Hpack/Render/Dsl.hs b/src/Hpack/Render/Dsl.hs --- a/src/Hpack/Render/Dsl.hs +++ b/src/Hpack/Render/Dsl.hs @@ -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 = diff --git a/src/Hpack/Render/Hints.hs b/src/Hpack/Render/Hints.hs --- a/src/Hpack/Render/Hints.hs +++ b/src/Hpack/Render/Hints.hs @@ -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 diff --git a/src/Hpack/Syntax/Dependencies.hs b/src/Hpack/Syntax/Dependencies.hs --- a/src/Hpack/Syntax/Dependencies.hs +++ b/src/Hpack/Syntax/Dependencies.hs @@ -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 diff --git a/src/Hpack/Syntax/DependencyVersion.hs b/src/Hpack/Syntax/DependencyVersion.hs --- a/src/Hpack/Syntax/DependencyVersion.hs +++ b/src/Hpack/Syntax/DependencyVersion.hs @@ -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 diff --git a/src/Hpack/Utf8.hs b/src/Hpack/Utf8.hs --- a/src/Hpack/Utf8.hs +++ b/src/Hpack/Utf8.hs @@ -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 diff --git a/src/Hpack/Util.hs b/src/Hpack/Util.hs --- a/src/Hpack/Util.hs +++ b/src/Hpack/Util.hs @@ -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 diff --git a/src/Hpack/Yaml.hs b/src/Hpack/Yaml.hs --- a/src/Hpack/Yaml.hs +++ b/src/Hpack/Yaml.hs @@ -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 diff --git a/src/Imports.hs b/src/Imports.hs --- a/src/Imports.hs +++ b/src/Imports.hs @@ -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 diff --git a/test/Data/Aeson/Config/FromValueSpec.hs b/test/Data/Aeson/Config/FromValueSpec.hs --- a/test/Data/Aeson/Config/FromValueSpec.hs +++ b/test/Data/Aeson/Config/FromValueSpec.hs @@ -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"], []) diff --git a/test/EndToEndSpec.hs b/test/EndToEndSpec.hs --- a/test/EndToEndSpec.hs +++ b/test/EndToEndSpec.hs @@ -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 +Copyright (c) 2014-2023 Simon Hengel Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal diff --git a/test/Helper.hs b/test/Helper.hs --- a/test/Helper.hs +++ b/test/Helper.hs @@ -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 [] diff --git a/test/Hpack/CabalFileSpec.hs b/test/Hpack/CabalFileSpec.hs --- a/test/Hpack/CabalFileSpec.hs +++ b/test/Hpack/CabalFileSpec.hs @@ -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 diff --git a/test/Hpack/ConfigSpec.hs b/test/Hpack/ConfigSpec.hs --- a/test/Hpack/ConfigSpec.hs +++ b/test/Hpack/ConfigSpec.hs @@ -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 |] diff --git a/test/Hpack/DefaultsSpec.hs b/test/Hpack/DefaultsSpec.hs --- a/test/Hpack/DefaultsSpec.hs +++ b/test/Hpack/DefaultsSpec.hs @@ -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 diff --git a/test/Hpack/OptionsSpec.hs b/test/Hpack/OptionsSpec.hs --- a/test/Hpack/OptionsSpec.hs +++ b/test/Hpack/OptionsSpec.hs @@ -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 diff --git a/test/Hpack/Render/DslSpec.hs b/test/Hpack/Render/DslSpec.hs --- a/test/Hpack/Render/DslSpec.hs +++ b/test/Hpack/Render/DslSpec.hs @@ -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" diff --git a/test/Hpack/Render/HintsSpec.hs b/test/Hpack/Render/HintsSpec.hs --- a/test/Hpack/Render/HintsSpec.hs +++ b/test/Hpack/Render/HintsSpec.hs @@ -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 diff --git a/test/Hpack/RenderSpec.hs b/test/Hpack/RenderSpec.hs --- a/test/Hpack/RenderSpec.hs +++ b/test/Hpack/RenderSpec.hs @@ -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:" , " ./" diff --git a/test/Hpack/Syntax/DependenciesSpec.hs b/test/Hpack/Syntax/DependenciesSpec.hs --- a/test/Hpack/Syntax/DependenciesSpec.hs +++ b/test/Hpack/Syntax/DependenciesSpec.hs @@ -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| diff --git a/test/Hpack/Syntax/GitSpec.hs b/test/Hpack/Syntax/GitSpec.hs --- a/test/Hpack/Syntax/GitSpec.hs +++ b/test/Hpack/Syntax/GitSpec.hs @@ -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 diff --git a/test/Hpack/Utf8Spec.hs b/test/Hpack/Utf8Spec.hs --- a/test/Hpack/Utf8Spec.hs +++ b/test/Hpack/Utf8Spec.hs @@ -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 diff --git a/test/HpackSpec.hs b/test/HpackSpec.hs --- a/test/HpackSpec.hs +++ b/test/HpackSpec.hs @@ -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 diff --git a/test/SpecHook.hs b/test/SpecHook.hs new file mode 100644 --- /dev/null +++ b/test/SpecHook.hs @@ -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")