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