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