diff --git a/Cabal.cabal b/Cabal.cabal --- a/Cabal.cabal +++ b/Cabal.cabal @@ -1,7 +1,7 @@ -cabal-version: >=1.10 +cabal-version: 1.22 name: Cabal -version: 3.6.3.0 -copyright: 2003-2021, Cabal Development Team (see AUTHORS file) +version: 3.8.1.0 +copyright: 2003-2022, Cabal Development Team (see AUTHORS file) license: BSD3 license-file: LICENSE author: Cabal Development Team @@ -29,14 +29,12 @@ location: https://github.com/haskell/cabal/ subdir: Cabal -flag bundled-binary-generic - default: False - library default-language: Haskell2010 hs-source-dirs: src build-depends: + Cabal-syntax >= 3.8 && < 3.9, array >= 0.4.0.1 && < 0.6, base >= 4.6 && < 5, bytestring >= 0.10.0.0 && < 0.12, @@ -45,40 +43,25 @@ directory >= 1.2 && < 1.4, filepath >= 1.3.0.1 && < 1.5, pretty >= 1.1.1 && < 1.2, - process >= 1.1.0.2 && < 1.7, + process >= 1.2.1.0 && < 1.7, time >= 1.4.0.1 && < 1.13 - if flag(bundled-binary-generic) - build-depends: binary >= 0.5.1.1 && < 0.7 - else - build-depends: binary >= 0.7 && < 0.9 + -- pull in process version with fixed waitForProcess error + if impl(ghc >=8.2) + build-depends: process >= 1.6.14.0 if os(windows) - build-depends: Win32 >= 2.3.0.0 && < 2.13 + build-depends: Win32 >= 2.3.0.0 && < 2.14 else build-depends: unix >= 2.6.0.0 && < 2.8 ghc-options: -Wall -fno-ignore-asserts -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates - if impl(ghc >= 8.0) - ghc-options: -Wcompat -Wnoncanonical-monad-instances - - if impl(ghc <8.8) - ghc-options: -Wnoncanonical-monadfail-instances - - if !impl(ghc >= 8.0) - -- at least one of lib:Cabal's dependency (i.e. `parsec`) - -- already depends on `fail` and `semigroups` transitively - build-depends: fail == 4.9.*, semigroups >= 0.18.3 && < 0.21 - - if !impl(ghc >= 7.10) - build-depends: void >= 0.7.3 && < 0.8 + ghc-options: -Wcompat -Wnoncanonical-monad-instances - if !impl(ghc >= 7.8) - -- semigroups depends on tagged. - build-depends: tagged >=0.8.6 && <0.9 + if impl(ghc <8.8) + ghc-options: -Wnoncanonical-monadfail-instances exposed-modules: - Distribution.Backpack Distribution.Backpack.Configure Distribution.Backpack.ComponentsGraph Distribution.Backpack.ConfiguredComponent @@ -88,45 +71,21 @@ Distribution.Backpack.ModSubst Distribution.Backpack.ModuleShape Distribution.Backpack.PreModuleShape - Distribution.CabalSpecVersion Distribution.Utils.IOData - Distribution.Utils.Path Distribution.Utils.LogProgress Distribution.Utils.MapAccum - Distribution.Utils.MD5 - Distribution.Utils.Structured Distribution.Compat.CreatePipe Distribution.Compat.Directory Distribution.Compat.Environment - Distribution.Compat.Exception Distribution.Compat.FilePath - Distribution.Compat.Graph Distribution.Compat.Internal.TempFile - Distribution.Compat.Newtype - Distribution.Compat.NonEmptySet Distribution.Compat.ResponseFile Distribution.Compat.Prelude.Internal Distribution.Compat.Process - Distribution.Compat.Semigroup Distribution.Compat.Stack Distribution.Compat.Time - Distribution.Compat.Typeable - Distribution.Compat.DList - Distribution.Compiler - Distribution.InstalledPackageInfo - Distribution.Types.AbiDependency - Distribution.Types.ExposedModule - Distribution.Types.InstalledPackageInfo - Distribution.Types.InstalledPackageInfo.FieldGrammar - Distribution.License Distribution.Make - Distribution.ModuleName - Distribution.Package - Distribution.PackageDescription Distribution.PackageDescription.Check - Distribution.PackageDescription.Configuration - Distribution.PackageDescription.PrettyPrint - Distribution.PackageDescription.Utils Distribution.ReadE Distribution.Simple Distribution.Simple.Bench @@ -151,6 +110,7 @@ Distribution.Simple.InstallDirs Distribution.Simple.InstallDirs.Internal Distribution.Simple.LocalBuildInfo + Distribution.Simple.PackageDescription Distribution.Simple.PackageIndex Distribution.Simple.PreProcess Distribution.Simple.PreProcess.Unlit @@ -180,88 +140,162 @@ Distribution.Simple.UHC Distribution.Simple.UserHooks Distribution.Simple.Utils - Distribution.SPDX - Distribution.SPDX.License - Distribution.SPDX.LicenseId - Distribution.SPDX.LicenseExceptionId - Distribution.SPDX.LicenseExpression - Distribution.SPDX.LicenseListVersion - Distribution.SPDX.LicenseReference - Distribution.System Distribution.TestSuite - Distribution.Text - Distribution.Pretty - Distribution.Types.AbiHash Distribution.Types.AnnotatedId - Distribution.Types.Benchmark - Distribution.Types.BenchmarkInterface - Distribution.Types.BenchmarkType - Distribution.Types.BuildInfo - Distribution.Types.BuildType Distribution.Types.ComponentInclude - Distribution.Types.ConfVar - Distribution.Types.Dependency - Distribution.Types.ExeDependency - Distribution.Types.LegacyExeDependency - Distribution.Types.PkgconfigDependency - Distribution.Types.DependencyMap - Distribution.Types.ComponentId - Distribution.Types.MungedPackageId - Distribution.Types.PackageId - Distribution.Types.UnitId - Distribution.Types.Executable - Distribution.Types.ExecutableScope - Distribution.Types.Library - Distribution.Types.LibraryVisibility - Distribution.Types.Flag - Distribution.Types.ForeignLib - Distribution.Types.ForeignLibType - Distribution.Types.ForeignLibOption - Distribution.Types.Module - Distribution.Types.ModuleReexport - Distribution.Types.ModuleRenaming - Distribution.Types.ComponentName - Distribution.Types.LibraryName - Distribution.Types.MungedPackageName - Distribution.Types.PackageName + Distribution.Types.DumpBuildInfo Distribution.Types.PackageName.Magic - Distribution.Types.PkgconfigName - Distribution.Types.PkgconfigVersion - Distribution.Types.PkgconfigVersionRange - Distribution.Types.UnqualComponentName - Distribution.Types.IncludeRenaming - Distribution.Types.Mixin - Distribution.Types.SetupBuildInfo - Distribution.Types.TestSuite - Distribution.Types.TestSuiteInterface - Distribution.Types.TestType - Distribution.Types.GenericPackageDescription - Distribution.Types.Condition - Distribution.Types.CondTree - Distribution.Types.HookedBuildInfo - Distribution.Types.PackageDescription - Distribution.Types.SourceRepo - Distribution.Types.Component Distribution.Types.ComponentLocalBuildInfo Distribution.Types.LocalBuildInfo - Distribution.Types.ComponentRequestedSpec Distribution.Types.TargetInfo - Distribution.Types.Version - Distribution.Types.VersionRange - Distribution.Types.VersionRange.Internal - Distribution.Types.VersionInterval - Distribution.Types.VersionInterval.Legacy Distribution.Types.GivenComponent - Distribution.Types.PackageVersionConstraint - Distribution.Utils.Generic + Distribution.Utils.Json Distribution.Utils.NubList - Distribution.Utils.ShortText Distribution.Utils.Progress Distribution.Verbosity Distribution.Verbosity.Internal - Distribution.Version + + -- We reexport all of Cabal-syntax to aid in compatibility for downstream + -- users. In the future we may opt to deprecate some or all of these exports. + -- See haskell/Cabal#7974. + reexported-modules: + Distribution.Backpack, + Distribution.CabalSpecVersion, + Distribution.Compat.Binary, + Distribution.Compat.CharParsing, + Distribution.Compat.DList, + Distribution.Compat.Exception, + Distribution.Compat.Graph, + Distribution.Compat.Lens, + Distribution.Compat.MonadFail, + Distribution.Compat.Newtype, + Distribution.Compat.NonEmptySet, + Distribution.Compat.Parsing, + Distribution.Compat.Prelude, + Distribution.Compat.Semigroup, + Distribution.Compat.Typeable, + Distribution.Compiler, + Distribution.FieldGrammar, + Distribution.FieldGrammar.Class, + Distribution.FieldGrammar.FieldDescrs, + Distribution.FieldGrammar.Newtypes, + Distribution.FieldGrammar.Parsec, + Distribution.FieldGrammar.Pretty, + Distribution.Fields, + Distribution.Fields.ConfVar, + Distribution.Fields.Field, + Distribution.Fields.Lexer, + Distribution.Fields.LexerMonad, + Distribution.Fields.ParseResult, + Distribution.Fields.Parser, + Distribution.Fields.Pretty, + Distribution.InstalledPackageInfo, + Distribution.License, + Distribution.ModuleName, + Distribution.Package, + Distribution.PackageDescription, + Distribution.PackageDescription.Configuration, + Distribution.PackageDescription.FieldGrammar, + Distribution.PackageDescription.Parsec, + Distribution.PackageDescription.PrettyPrint, + Distribution.PackageDescription.Quirks, + Distribution.PackageDescription.Utils, + Distribution.Parsec, + Distribution.Parsec.Error, + Distribution.Parsec.FieldLineStream, + Distribution.Parsec.Position, + Distribution.Parsec.Warning, + Distribution.Pretty, + Distribution.SPDX, + Distribution.SPDX.License, + Distribution.SPDX.LicenseExceptionId, + Distribution.SPDX.LicenseExpression, + Distribution.SPDX.LicenseId, + Distribution.SPDX.LicenseListVersion, + Distribution.SPDX.LicenseReference, + Distribution.System, + Distribution.Text, + Distribution.Types.AbiDependency, + Distribution.Types.AbiHash, + Distribution.Types.Benchmark, + Distribution.Types.Benchmark.Lens, + Distribution.Types.BenchmarkInterface, + Distribution.Types.BenchmarkType, + Distribution.Types.BuildInfo, + Distribution.Types.BuildInfo.Lens, + Distribution.Types.BuildType, + Distribution.Types.Component, + Distribution.Types.ComponentId, + Distribution.Types.ComponentName, + Distribution.Types.ComponentRequestedSpec, + Distribution.Types.CondTree, + Distribution.Types.Condition, + Distribution.Types.ConfVar, + Distribution.Types.Dependency, + Distribution.Types.DependencyMap, + Distribution.Types.ExeDependency, + Distribution.Types.Executable, + Distribution.Types.Executable.Lens, + Distribution.Types.ExecutableScope, + Distribution.Types.ExposedModule, + Distribution.Types.Flag, + Distribution.Types.ForeignLib, + Distribution.Types.ForeignLib.Lens, + Distribution.Types.ForeignLibOption, + Distribution.Types.ForeignLibType, + Distribution.Types.GenericPackageDescription, + Distribution.Types.GenericPackageDescription.Lens, + Distribution.Types.HookedBuildInfo, + Distribution.Types.IncludeRenaming, + Distribution.Types.InstalledPackageInfo, + Distribution.Types.InstalledPackageInfo.Lens, + Distribution.Types.InstalledPackageInfo.FieldGrammar, + Distribution.Types.LegacyExeDependency, + Distribution.Types.Lens, + Distribution.Types.Library, + Distribution.Types.Library.Lens, + Distribution.Types.LibraryName, + Distribution.Types.LibraryVisibility, + Distribution.Types.Mixin, + Distribution.Types.Module, + Distribution.Types.ModuleReexport, + Distribution.Types.ModuleRenaming, + Distribution.Types.MungedPackageId, + Distribution.Types.MungedPackageName, + Distribution.Types.PackageDescription, + Distribution.Types.PackageDescription.Lens, + Distribution.Types.PackageId, + Distribution.Types.PackageId.Lens, + Distribution.Types.PackageName, + Distribution.Types.PackageVersionConstraint, + Distribution.Types.PkgconfigDependency, + Distribution.Types.PkgconfigName, + Distribution.Types.PkgconfigVersion, + Distribution.Types.PkgconfigVersionRange, + Distribution.Types.SetupBuildInfo, + Distribution.Types.SetupBuildInfo.Lens, + Distribution.Types.SourceRepo, + Distribution.Types.SourceRepo.Lens, + Distribution.Types.TestSuite, + Distribution.Types.TestSuite.Lens, + Distribution.Types.TestSuiteInterface, + Distribution.Types.TestType, + Distribution.Types.UnitId, + Distribution.Types.UnqualComponentName, + Distribution.Types.Version, + Distribution.Types.VersionInterval, + Distribution.Types.VersionInterval.Legacy, + Distribution.Types.VersionRange, + Distribution.Types.VersionRange.Internal, + Distribution.Utils.Base62, + Distribution.Utils.Generic, + Distribution.Utils.MD5, + Distribution.Utils.Path, + Distribution.Utils.ShortText, + Distribution.Utils.String, + Distribution.Utils.Structured, + Distribution.Version, Language.Haskell.Extension - Distribution.Compat.Binary -- Parsec parser-related modules build-depends: @@ -271,49 +305,7 @@ mtl >= 2.1 && < 2.3, text (>= 1.2.3.0 && < 1.3) || (>= 2.0 && < 2.1), parsec >= 3.1.13.0 && < 3.2 - exposed-modules: - Distribution.Compat.Parsing - Distribution.Compat.CharParsing - Distribution.FieldGrammar - Distribution.FieldGrammar.Class - Distribution.FieldGrammar.FieldDescrs - Distribution.FieldGrammar.Newtypes - Distribution.FieldGrammar.Parsec - Distribution.FieldGrammar.Pretty - Distribution.PackageDescription.FieldGrammar - Distribution.PackageDescription.Parsec - Distribution.PackageDescription.Quirks - Distribution.Parsec - Distribution.Parsec.Error - Distribution.Parsec.Position - Distribution.Parsec.Warning - Distribution.Parsec.FieldLineStream - Distribution.Fields - Distribution.Fields.ConfVar - Distribution.Fields.Field - Distribution.Fields.Lexer - Distribution.Fields.LexerMonad - Distribution.Fields.ParseResult - Distribution.Fields.Parser - Distribution.Fields.Pretty - -- Lens functionality - exposed-modules: - Distribution.Compat.Lens - Distribution.Types.Lens - Distribution.Types.Benchmark.Lens - Distribution.Types.BuildInfo.Lens - Distribution.Types.Executable.Lens - Distribution.Types.ForeignLib.Lens - Distribution.Types.GenericPackageDescription.Lens - Distribution.Types.InstalledPackageInfo.Lens - Distribution.Types.Library.Lens - Distribution.Types.PackageDescription.Lens - Distribution.Types.PackageId.Lens - Distribution.Types.SetupBuildInfo.Lens - Distribution.Types.SourceRepo.Lens - Distribution.Types.TestSuite.Lens - other-modules: Distribution.Backpack.PreExistingComponent Distribution.Backpack.ReadyComponent @@ -322,30 +314,20 @@ Distribution.Backpack.UnifyM Distribution.Backpack.Id Distribution.Utils.UnionFind - Distribution.Utils.Base62 Distribution.Compat.Async Distribution.Compat.CopyFile Distribution.Compat.GetShortPathName - Distribution.Compat.MonadFail - Distribution.Compat.Prelude Distribution.Compat.SnocList Distribution.GetOpt Distribution.Lex - Distribution.Utils.String Distribution.Simple.Build.Macros.Z Distribution.Simple.Build.PathsModule.Z Distribution.Simple.GHC.EnvironmentParser Distribution.Simple.GHC.Internal Distribution.Simple.GHC.ImplInfo - Distribution.Simple.Utils.Json Distribution.ZinzaPrelude Paths_Cabal - if flag(bundled-binary-generic) - other-modules: - Distribution.Compat.Binary.Class - Distribution.Compat.Binary.Generic - other-extensions: BangPatterns CPP @@ -361,8 +343,10 @@ GeneralizedNewtypeDeriving ImplicitParams KindSignatures + LambdaCase NondecreasingIndentation OverloadedStrings + PatternSynonyms RankNTypes RecordWildCards ScopedTypeVariables @@ -372,6 +356,3 @@ TypeOperators TypeSynonymInstances UndecidableInstances - - if impl(ghc >= 7.11) - other-extensions: PatternSynonyms diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,16 +1,22 @@ +# 3.8.1.0 [Mikolaj Konarski](mailto:mikolaj@well-typed.com) August 2022 + * See https://github.com/haskell/cabal/blob/master/release-notes/Cabal-3.8.1.0.md + # 3.6.3.0 March 2022 * See https://github.com/haskell/cabal/blob/master/release-notes/Cabal-3.6.3.0.md -# 3.6.2.0 [Emily Pillmore](mailgo:emilypi@cohomolo.gy) October 2021 +# 3.6.2.0 [Emily Pillmore](mailto:emilypi@cohomolo.gy) October 2021 * See https://github.com/haskell/cabal/blob/master/release-notes/Cabal-3.6.2.0.md -# 3.6.1.0 [Emily Pillmore](mailgo:emilypi@cohomolo.gy) August 2021 +# 3.6.1.0 [Emily Pillmore](mailto:emilypi@cohomolo.gy) August 2021 * See https://github.com/haskell/cabal/blob/master/release-notes/Cabal-3.6.1.0.md -# 3.6.0.0 [Emily Pillmore](mailgo:emilypi@cohomolo.gy) August 2021 +# 3.6.0.0 [Emily Pillmore](mailto:emilypi@cohomolo.gy) August 2021 * See https://github.com/haskell/cabal/blob/master/release-notes/Cabal-3.6.0.0.md -# 3.4.0.0 [Oleg Grenrus](mailgo:oleg.grnerus@iki.fi) February 2021 +# 3.4.1.0 [Emily Pillmore](mailto:emilypi@cohomolo.gy) October 2021 + * See https://github.com/haskell/cabal/blob/master/release-notes/Cabal-3.4.1.0.md + +# 3.4.0.0 [Oleg Grenrus](mailto:oleg.grnerus@iki.fi) February 2021 * See https://github.com/haskell/cabal/blob/master/release-notes/Cabal-3.4.0.0.md # 3.2.1.0 [Oleg Grenrus](mailto:oleg.grenris@iki.fi) October 2020 diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2003-2020, Cabal Development Team. +Copyright (c) 2003-2022, Cabal Development Team. See the AUTHORS file for the full list of copyright holders. See */LICENSE for the copyright holders of the subcomponents. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -6,17 +6,17 @@ If you also want the `cabal` command-line program, you need the [cabal-install] package in addition to this library. -[cabal-install]: ../cabal-install/README.md +[cabal-install]: ../cabal-install More information ================ -Please see the [Cabal web site] for the [user guide] and [API +Please see the [Cabal web site], the [user guide] and the [API documentation]. There is additional information available on the [development wiki]. [user guide]: http://www.haskell.org/cabal/users-guide -[API documentation]: http://www.haskell.org/cabal/release/cabal-latest/doc/API/Cabal/Distribution-Simple.html +[API documentation]: https://hackage.haskell.org/package/Cabal/docs/Distribution-Simple.html [development wiki]: https://github.com/haskell/cabal/wiki diff --git a/src/Distribution/Backpack.hs b/src/Distribution/Backpack.hs deleted file mode 100644 --- a/src/Distribution/Backpack.hs +++ /dev/null @@ -1,269 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE RankNTypes #-} - --- | This module defines the core data types for Backpack. For more --- details, see: --- --- - -module Distribution.Backpack ( - -- * OpenUnitId - OpenUnitId(..), - openUnitIdFreeHoles, - mkOpenUnitId, - - -- * DefUnitId - DefUnitId, - unDefUnitId, - mkDefUnitId, - - -- * OpenModule - OpenModule(..), - openModuleFreeHoles, - - -- * OpenModuleSubst - OpenModuleSubst, - dispOpenModuleSubst, - dispOpenModuleSubstEntry, - parsecOpenModuleSubst, - parsecOpenModuleSubstEntry, - openModuleSubstFreeHoles, - - -- * Conversions to 'UnitId' - abstractUnitId, - hashModuleSubst, -) where - -import Distribution.Compat.Prelude hiding (mod) -import Distribution.Parsec -import Distribution.Pretty -import Prelude () -import Text.PrettyPrint (hcat) - -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp - -import Distribution.ModuleName -import Distribution.Types.ComponentId -import Distribution.Types.Module -import Distribution.Types.UnitId -import Distribution.Utils.Base62 - -import qualified Data.Map as Map -import qualified Data.Set as Set - ------------------------------------------------------------------------ --- OpenUnitId - --- | An 'OpenUnitId' describes a (possibly partially) instantiated --- Backpack component, with a description of how the holes are filled --- in. Unlike 'OpenUnitId', the 'ModuleSubst' is kept in a structured --- form that allows for substitution (which fills in holes.) This form --- of unit cannot be installed. It must first be converted to a --- 'UnitId'. --- --- In the absence of Backpack, there are no holes to fill, so any such --- component always has an empty module substitution; thus we can lossly --- represent it as an 'OpenUnitId uid'. --- --- For a source component using Backpack, however, there is more --- structure as components may be parametrized over some signatures, and --- these \"holes\" may be partially or wholly filled. --- --- OpenUnitId plays an important role when we are mix-in linking, --- and is recorded to the installed packaged database for indefinite --- packages; however, for compiled packages that are fully instantiated, --- we instantiate 'OpenUnitId' into 'UnitId'. --- --- For more details see the Backpack spec --- --- - -data OpenUnitId - -- | Identifies a component which may have some unfilled holes; - -- specifying its 'ComponentId' and its 'OpenModuleSubst'. - -- TODO: Invariant that 'OpenModuleSubst' is non-empty? - -- See also the Text instance. - = IndefFullUnitId ComponentId OpenModuleSubst - -- | Identifies a fully instantiated component, which has - -- been compiled and abbreviated as a hash. The embedded 'UnitId' - -- MUST NOT be for an indefinite component; an 'OpenUnitId' - -- is guaranteed not to have any holes. - | DefiniteUnitId DefUnitId - deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) --- TODO: cache holes? - -instance Binary OpenUnitId -instance Structured OpenUnitId -instance NFData OpenUnitId where - rnf (IndefFullUnitId cid subst) = rnf cid `seq` rnf subst - rnf (DefiniteUnitId uid) = rnf uid - -instance Pretty OpenUnitId where - pretty (IndefFullUnitId cid insts) - -- TODO: arguably a smart constructor to enforce invariant would be - -- better - | Map.null insts = pretty cid - | otherwise = pretty cid <<>> Disp.brackets (dispOpenModuleSubst insts) - pretty (DefiniteUnitId uid) = pretty uid - --- | --- --- >>> eitherParsec "foobar" :: Either String OpenUnitId ---Right (DefiniteUnitId (DefUnitId {unDefUnitId = UnitId "foobar"})) --- --- >>> eitherParsec "foo[Str=text-1.2.3:Data.Text.Text]" :: Either String OpenUnitId --- Right (IndefFullUnitId (ComponentId "foo") (fromList [(ModuleName "Str",OpenModule (DefiniteUnitId (DefUnitId {unDefUnitId = UnitId "text-1.2.3"})) (ModuleName "Data.Text.Text"))])) --- -instance Parsec OpenUnitId where - parsec = P.try parseOpenUnitId <|> fmap DefiniteUnitId parsec - where - parseOpenUnitId = do - cid <- parsec - insts <- P.between (P.char '[') (P.char ']') - parsecOpenModuleSubst - return (IndefFullUnitId cid insts) - --- | Get the set of holes ('ModuleVar') embedded in a 'UnitId'. -openUnitIdFreeHoles :: OpenUnitId -> Set ModuleName -openUnitIdFreeHoles (IndefFullUnitId _ insts) = openModuleSubstFreeHoles insts -openUnitIdFreeHoles _ = Set.empty - --- | Safe constructor from a UnitId. The only way to do this safely --- is if the instantiation is provided. -mkOpenUnitId :: UnitId -> ComponentId -> OpenModuleSubst -> OpenUnitId -mkOpenUnitId uid cid insts = - if Set.null (openModuleSubstFreeHoles insts) - then DefiniteUnitId (unsafeMkDefUnitId uid) -- invariant holds! - else IndefFullUnitId cid insts - ------------------------------------------------------------------------ --- DefUnitId - --- | Create a 'DefUnitId' from a 'ComponentId' and an instantiation --- with no holes. -mkDefUnitId :: ComponentId -> Map ModuleName Module -> DefUnitId -mkDefUnitId cid insts = - unsafeMkDefUnitId (mkUnitId - (unComponentId cid ++ maybe "" ("+"++) (hashModuleSubst insts))) - -- impose invariant! - ------------------------------------------------------------------------ --- OpenModule - --- | Unlike a 'Module', an 'OpenModule' is either an ordinary --- module from some unit, OR an 'OpenModuleVar', representing a --- hole that needs to be filled in. Substitutions are over --- module variables. -data OpenModule - = OpenModule OpenUnitId ModuleName - | OpenModuleVar ModuleName - deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) - -instance Binary OpenModule -instance Structured OpenModule - -instance NFData OpenModule where - rnf (OpenModule uid mod_name) = rnf uid `seq` rnf mod_name - rnf (OpenModuleVar mod_name) = rnf mod_name - -instance Pretty OpenModule where - pretty (OpenModule uid mod_name) = - hcat [pretty uid, Disp.text ":", pretty mod_name] - pretty (OpenModuleVar mod_name) = - hcat [Disp.char '<', pretty mod_name, Disp.char '>'] - --- | --- --- >>> eitherParsec "Includes2-0.1.0.0-inplace-mysql:Database.MySQL" :: Either String OpenModule --- Right (OpenModule (DefiniteUnitId (DefUnitId {unDefUnitId = UnitId "Includes2-0.1.0.0-inplace-mysql"})) (ModuleName "Database.MySQL")) --- -instance Parsec OpenModule where - parsec = parsecModuleVar <|> parsecOpenModule - where - parsecOpenModule = do - uid <- parsec - _ <- P.char ':' - mod_name <- parsec - return (OpenModule uid mod_name) - - parsecModuleVar = do - _ <- P.char '<' - mod_name <- parsec - _ <- P.char '>' - return (OpenModuleVar mod_name) - --- | Get the set of holes ('ModuleVar') embedded in a 'Module'. -openModuleFreeHoles :: OpenModule -> Set ModuleName -openModuleFreeHoles (OpenModuleVar mod_name) = Set.singleton mod_name -openModuleFreeHoles (OpenModule uid _n) = openUnitIdFreeHoles uid - ------------------------------------------------------------------------ --- OpenModuleSubst - --- | An explicit substitution on modules. --- --- NB: These substitutions are NOT idempotent, for example, a --- valid substitution is (A -> B, B -> A). -type OpenModuleSubst = Map ModuleName OpenModule - --- | Pretty-print the entries of a module substitution, suitable --- for embedding into a 'OpenUnitId' or passing to GHC via @--instantiate-with@. -dispOpenModuleSubst :: OpenModuleSubst -> Disp.Doc -dispOpenModuleSubst subst - = Disp.hcat - . Disp.punctuate Disp.comma - $ map dispOpenModuleSubstEntry (Map.toAscList subst) - --- | Pretty-print a single entry of a module substitution. -dispOpenModuleSubstEntry :: (ModuleName, OpenModule) -> Disp.Doc -dispOpenModuleSubstEntry (k, v) = pretty k <<>> Disp.char '=' <<>> pretty v - --- | Inverse to 'dispModSubst'. --- --- @since 2.2 -parsecOpenModuleSubst :: CabalParsing m => m OpenModuleSubst -parsecOpenModuleSubst = fmap Map.fromList - . flip P.sepBy (P.char ',') - $ parsecOpenModuleSubstEntry - --- | Inverse to 'dispModSubstEntry'. --- --- @since 2.2 -parsecOpenModuleSubstEntry :: CabalParsing m => m (ModuleName, OpenModule) -parsecOpenModuleSubstEntry = - do k <- parsec - _ <- P.char '=' - v <- parsec - return (k, v) - --- | Get the set of holes ('ModuleVar') embedded in a 'OpenModuleSubst'. --- This is NOT the domain of the substitution. -openModuleSubstFreeHoles :: OpenModuleSubst -> Set ModuleName -openModuleSubstFreeHoles insts = Set.unions (map openModuleFreeHoles (Map.elems insts)) - ------------------------------------------------------------------------ --- Conversions to UnitId - --- | When typechecking, we don't demand that a freshly instantiated --- 'IndefFullUnitId' be compiled; instead, we just depend on the --- installed indefinite unit installed at the 'ComponentId'. -abstractUnitId :: OpenUnitId -> UnitId -abstractUnitId (DefiniteUnitId def_uid) = unDefUnitId def_uid -abstractUnitId (IndefFullUnitId cid _) = newSimpleUnitId cid - --- | Take a module substitution and hash it into a string suitable for --- 'UnitId'. Note that since this takes 'Module', not 'OpenModule', --- you are responsible for recursively converting 'OpenModule' --- into 'Module'. See also "Distribution.Backpack.ReadyComponent". -hashModuleSubst :: Map ModuleName Module -> Maybe String -hashModuleSubst subst - | Map.null subst = Nothing - | otherwise = - Just . hashToBase62 $ - concat [ prettyShow mod_name ++ "=" ++ prettyShow m ++ "\n" - | (mod_name, m) <- Map.toList subst] diff --git a/src/Distribution/Backpack/Id.hs b/src/Distribution/Backpack/Id.hs --- a/src/Distribution/Backpack/Id.hs +++ b/src/Distribution/Backpack/Id.hs @@ -41,7 +41,7 @@ computeComponentId deterministic mb_ipid mb_cid pid cname mb_details = -- show is found to be faster than intercalate and then replacement of -- special character used in intercalating. We cannot simply hash by - -- doubly concating list, as it just flatten out the nested list, so + -- doubly concatenating list, as it just flatten out the nested list, so -- different sources can produce same hash let hash_suffix | Just (dep_ipids, flags) <- mb_details diff --git a/src/Distribution/CabalSpecVersion.hs b/src/Distribution/CabalSpecVersion.hs deleted file mode 100644 --- a/src/Distribution/CabalSpecVersion.hs +++ /dev/null @@ -1,150 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -module Distribution.CabalSpecVersion where - -import Prelude () -import Distribution.Compat.Prelude - --- | Different Cabal-the-spec versions. --- --- We branch based on this at least in the parser. --- -data CabalSpecVersion - = CabalSpecV1_0 -- ^ this is older than 'CabalSpecV1_2' - | CabalSpecV1_2 -- ^ new syntax (sections) - | CabalSpecV1_4 - | CabalSpecV1_6 - | CabalSpecV1_8 - | CabalSpecV1_10 - | CabalSpecV1_12 - -- 1.16 -- 1.14: no changes - | CabalSpecV1_18 - | CabalSpecV1_20 - | CabalSpecV1_22 - | CabalSpecV1_24 - | CabalSpecV2_0 - | CabalSpecV2_2 - | CabalSpecV2_4 - | CabalSpecV3_0 - -- 3.2: no changes - | CabalSpecV3_4 - | CabalSpecV3_6 - deriving (Eq, Ord, Show, Read, Enum, Bounded, Typeable, Data, Generic) - -instance Binary CabalSpecVersion -instance Structured CabalSpecVersion -instance NFData CabalSpecVersion where rnf = genericRnf - --- | Show cabal spec version, but not the way in the .cabal files --- --- @since 3.0.0.0 -showCabalSpecVersion :: CabalSpecVersion -> String -showCabalSpecVersion CabalSpecV3_6 = "3.6" -showCabalSpecVersion CabalSpecV3_4 = "3.4" -showCabalSpecVersion CabalSpecV3_0 = "3.0" -showCabalSpecVersion CabalSpecV2_4 = "2.4" -showCabalSpecVersion CabalSpecV2_2 = "2.2" -showCabalSpecVersion CabalSpecV2_0 = "2.0" -showCabalSpecVersion CabalSpecV1_24 = "1.24" -showCabalSpecVersion CabalSpecV1_22 = "1.22" -showCabalSpecVersion CabalSpecV1_20 = "1.20" -showCabalSpecVersion CabalSpecV1_18 = "1.18" -showCabalSpecVersion CabalSpecV1_12 = "1.12" -showCabalSpecVersion CabalSpecV1_10 = "1.10" -showCabalSpecVersion CabalSpecV1_8 = "1.8" -showCabalSpecVersion CabalSpecV1_6 = "1.6" -showCabalSpecVersion CabalSpecV1_4 = "1.4" -showCabalSpecVersion CabalSpecV1_2 = "1.2" -showCabalSpecVersion CabalSpecV1_0 = "1.0" - -cabalSpecLatest :: CabalSpecVersion -cabalSpecLatest = CabalSpecV3_6 - --- | Parse 'CabalSpecVersion' from version digits. --- --- It may fail if for recent versions the version is not exact. --- -cabalSpecFromVersionDigits :: [Int] -> Maybe CabalSpecVersion -cabalSpecFromVersionDigits v - | v == [3,6] = Just CabalSpecV3_6 - | v == [3,4] = Just CabalSpecV3_4 - | v == [3,0] = Just CabalSpecV3_0 - | v == [2,4] = Just CabalSpecV2_4 - | v == [2,2] = Just CabalSpecV2_2 - | v == [2,0] = Just CabalSpecV2_0 - | v >= [1,25] = Nothing - | v >= [1,23] = Just CabalSpecV1_24 - | v >= [1,21] = Just CabalSpecV1_22 - | v >= [1,19] = Just CabalSpecV1_20 - | v >= [1,17] = Just CabalSpecV1_18 - | v >= [1,11] = Just CabalSpecV1_12 - | v >= [1,9] = Just CabalSpecV1_10 - | v >= [1,7] = Just CabalSpecV1_8 - | v >= [1,5] = Just CabalSpecV1_6 - | v >= [1,3] = Just CabalSpecV1_4 - | v >= [1,1] = Just CabalSpecV1_2 - | otherwise = Just CabalSpecV1_0 - --- | @since 3.4.0.0 -cabalSpecToVersionDigits :: CabalSpecVersion -> [Int] -cabalSpecToVersionDigits CabalSpecV3_6 = [3,6] -cabalSpecToVersionDigits CabalSpecV3_4 = [3,4] -cabalSpecToVersionDigits CabalSpecV3_0 = [3,0] -cabalSpecToVersionDigits CabalSpecV2_4 = [2,4] -cabalSpecToVersionDigits CabalSpecV2_2 = [2,2] -cabalSpecToVersionDigits CabalSpecV2_0 = [2,0] -cabalSpecToVersionDigits CabalSpecV1_24 = [1,24] -cabalSpecToVersionDigits CabalSpecV1_22 = [1,22] -cabalSpecToVersionDigits CabalSpecV1_20 = [1,20] -cabalSpecToVersionDigits CabalSpecV1_18 = [1,18] -cabalSpecToVersionDigits CabalSpecV1_12 = [1,12] -cabalSpecToVersionDigits CabalSpecV1_10 = [1,10] -cabalSpecToVersionDigits CabalSpecV1_8 = [1,8] -cabalSpecToVersionDigits CabalSpecV1_6 = [1,6] -cabalSpecToVersionDigits CabalSpecV1_4 = [1,4] -cabalSpecToVersionDigits CabalSpecV1_2 = [1,2] -cabalSpecToVersionDigits CabalSpecV1_0 = [1,0] - --- | What is the minimum Cabal library version which knows how handle --- this spec version. --- --- /Note:/ this is a point where we could decouple cabal-spec and Cabal --- versions, if we ever want that. --- --- >>> cabalSpecMinimumLibraryVersion CabalSpecV3_0 --- [2,5] --- --- >>> cabalSpecMinimumLibraryVersion CabalSpecV2_4 --- [2,3] --- --- @since 3.4.0.0 -cabalSpecMinimumLibraryVersion :: CabalSpecVersion -> [Int] -cabalSpecMinimumLibraryVersion CabalSpecV1_0 = [1,0] -cabalSpecMinimumLibraryVersion csv = case cabalSpecToVersionDigits (pred csv) of - [x,y] -> [x, y+1] - xs -> xs - -specHasCommonStanzas :: CabalSpecVersion -> HasCommonStanzas -specHasCommonStanzas v = - if v >= CabalSpecV2_2 - then HasCommonStanzas - else NoCommonStanzas - -specHasElif :: CabalSpecVersion -> HasElif -specHasElif v = - if v >= CabalSpecV2_2 - then HasElif - else NoElif - -------------------------------------------------------------------------------- --- Booleans -------------------------------------------------------------------------------- - --- IDEA: make some kind of tagged booleans? -data HasElif = HasElif | NoElif - deriving (Eq, Show) - -data HasCommonStanzas = HasCommonStanzas | NoCommonStanzas - deriving (Eq, Show) - -data HasGlobstar = HasGlobstar | NoGlobstar diff --git a/src/Distribution/Compat/Binary.hs b/src/Distribution/Compat/Binary.hs deleted file mode 100644 --- a/src/Distribution/Compat/Binary.hs +++ /dev/null @@ -1,71 +0,0 @@ -{-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ >= 711 -{-# LANGUAGE PatternSynonyms #-} -#endif - -#ifndef MIN_VERSION_binary -#define MIN_VERSION_binary(x, y, z) 0 -#endif - -module Distribution.Compat.Binary - ( decodeOrFailIO - , decodeFileOrFail' -#if __GLASGOW_HASKELL__ >= 708 || MIN_VERSION_binary(0,7,0) - , module Data.Binary -#else - , Binary(..) - , decode, encode, encodeFile -#endif - ) where - -import Control.Exception (ErrorCall (..), catch, evaluate) -import Data.ByteString.Lazy (ByteString) - -#if __GLASGOW_HASKELL__ >= 708 || MIN_VERSION_binary(0,7,0) - -import Data.Binary - --- | Lazily reconstruct a value previously written to a file. -decodeFileOrFail' :: Binary a => FilePath -> IO (Either String a) -decodeFileOrFail' f = either (Left . snd) Right `fmap` decodeFileOrFail f - -#else - -import Data.Binary.Get -import Data.Binary.Put -import qualified Data.ByteString.Lazy as BSL - -import Distribution.Compat.Binary.Class -import Distribution.Compat.Binary.Generic () - --- | Decode a value from a lazy ByteString, reconstructing the --- original structure. --- -decode :: Binary a => ByteString -> a -decode = runGet get - --- | Encode a value using binary serialisation to a lazy ByteString. --- -encode :: Binary a => a -> ByteString -encode = runPut . put -{-# INLINE encode #-} - --- | Lazily reconstruct a value previously written to a file. -decodeFileOrFail' :: Binary a => FilePath -> IO (Either String a) -decodeFileOrFail' f = decodeOrFailIO =<< BSL.readFile f - --- | Lazily serialise a value to a file -encodeFile :: Binary a => FilePath -> a -> IO () -encodeFile f = BSL.writeFile f . encode - -#endif - -decodeOrFailIO :: Binary a => ByteString -> IO (Either String a) -decodeOrFailIO bs = - catch (evaluate (decode bs) >>= return . Right) handler - where -#if MIN_VERSION_base(4,9,0) - handler (ErrorCallWithLocation str _) = return $ Left str -#else - handler (ErrorCall str) = return $ Left str -#endif diff --git a/src/Distribution/Compat/Binary/Class.hs b/src/Distribution/Compat/Binary/Class.hs deleted file mode 100644 --- a/src/Distribution/Compat/Binary/Class.hs +++ /dev/null @@ -1,519 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE DefaultSignatures #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Compat.Binary.Class --- Copyright : Lennart Kolmodin --- License : BSD3-style (see LICENSE) --- --- Maintainer : Lennart Kolmodin --- Stability : unstable --- Portability : portable to Hugs and GHC. Requires the FFI and some flexible instances --- --- Typeclass and instances for binary serialization. --- ------------------------------------------------------------------------------ - -module Distribution.Compat.Binary.Class ( - - -- * The Binary class - Binary(..) - - -- * Support for generics - , GBinary(..) - - ) where - -import Data.Word - -import Data.Binary.Put -import Data.Binary.Get - -import Control.Applicative ((<$>), (<*>), (*>)) -import Foreign - -import Data.ByteString.Lazy (ByteString) -import qualified Data.ByteString.Lazy as L - -import Data.Char (chr,ord) -import Data.List (unfoldr) -import Data.Foldable (traverse_) - --- And needed for the instances: -import qualified Data.ByteString as B -import qualified Data.Map as Map -import qualified Data.Set as Set -import qualified Data.IntMap as IntMap -import qualified Data.IntSet as IntSet -import qualified Data.Ratio as R - -import qualified Data.Tree as T - -import Data.Array.Unboxed - -import GHC.Generics - -import qualified Data.Sequence as Seq -import qualified Data.Foldable as Fold - ------------------------------------------------------------------------- - -class GBinary f where - gput :: f t -> Put - gget :: Get (f t) - --- | The 'Binary' class provides 'put' and 'get', methods to encode and --- decode a Haskell value to a lazy 'ByteString'. It mirrors the 'Read' and --- 'Show' classes for textual representation of Haskell types, and is --- suitable for serialising Haskell values to disk, over the network. --- --- For decoding and generating simple external binary formats (e.g. C --- structures), Binary may be used, but in general is not suitable --- for complex protocols. Instead use the 'Put' and 'Get' primitives --- directly. --- --- Instances of Binary should satisfy the following property: --- --- > decode . encode == id --- --- That is, the 'get' and 'put' methods should be the inverse of each --- other. A range of instances are provided for basic Haskell types. --- -class Binary t where - -- | Encode a value in the Put monad. - put :: t -> Put - -- | Decode a value in the Get monad - get :: Get t - - default put :: (Generic t, GBinary (Rep t)) => t -> Put - put = gput . from - - default get :: (Generic t, GBinary (Rep t)) => Get t - get = to `fmap` gget - ------------------------------------------------------------------------- --- Simple instances - --- The () type need never be written to disk: values of singleton type --- can be reconstructed from the type alone -instance Binary () where - put () = return () - get = return () - --- Bools are encoded as a byte in the range 0 .. 1 -instance Binary Bool where - put = putWord8 . fromIntegral . fromEnum - get = fmap (toEnum . fromIntegral) getWord8 - --- Values of type 'Ordering' are encoded as a byte in the range 0 .. 2 -instance Binary Ordering where - put = putWord8 . fromIntegral . fromEnum - get = fmap (toEnum . fromIntegral) getWord8 - ------------------------------------------------------------------------- --- Words and Ints - --- Words8s are written as bytes -instance Binary Word8 where - put = putWord8 - get = getWord8 - --- Words16s are written as 2 bytes in big-endian (network) order -instance Binary Word16 where - put = putWord16be - get = getWord16be - --- Words32s are written as 4 bytes in big-endian (network) order -instance Binary Word32 where - put = putWord32be - get = getWord32be - --- Words64s are written as 8 bytes in big-endian (network) order -instance Binary Word64 where - put = putWord64be - get = getWord64be - --- Int8s are written as a single byte. -instance Binary Int8 where - put i = put (fromIntegral i :: Word8) - get = fmap fromIntegral (get :: Get Word8) - --- Int16s are written as a 2 bytes in big endian format -instance Binary Int16 where - put i = put (fromIntegral i :: Word16) - get = fmap fromIntegral (get :: Get Word16) - --- Int32s are written as a 4 bytes in big endian format -instance Binary Int32 where - put i = put (fromIntegral i :: Word32) - get = fmap fromIntegral (get :: Get Word32) - --- Int64s are written as a 4 bytes in big endian format -instance Binary Int64 where - put i = put (fromIntegral i :: Word64) - get = fmap fromIntegral (get :: Get Word64) - ------------------------------------------------------------------------- - --- Words are are written as Word64s, that is, 8 bytes in big endian format -instance Binary Word where - put i = put (fromIntegral i :: Word64) - get = fmap fromIntegral (get :: Get Word64) - --- Ints are are written as Int64s, that is, 8 bytes in big endian format -instance Binary Int where - put i = put (fromIntegral i :: Int64) - get = fmap fromIntegral (get :: Get Int64) - ------------------------------------------------------------------------- --- --- Portable, and pretty efficient, serialisation of Integer --- - --- Fixed-size type for a subset of Integer -type SmallInt = Int32 - --- Integers are encoded in two ways: if they fit inside a SmallInt, --- they're written as a byte tag, and that value. If the Integer value --- is too large to fit in a SmallInt, it is written as a byte array, --- along with a sign and length field. - -instance Binary Integer where - - {-# INLINE put #-} - put n | n >= lo && n <= hi = do - putWord8 0 - put (fromIntegral n :: SmallInt) -- fast path - where - lo = fromIntegral (minBound :: SmallInt) :: Integer - hi = fromIntegral (maxBound :: SmallInt) :: Integer - - put n = do - putWord8 1 - put sign - put (unroll (abs n)) -- unroll the bytes - where - sign = fromIntegral (signum n) :: Word8 - - {-# INLINE get #-} - get = do - tag <- get :: Get Word8 - case tag of - 0 -> fmap fromIntegral (get :: Get SmallInt) - _ -> do sign <- get - bytes <- get - let v = roll bytes - return $! if sign == (1 :: Word8) then v else - v - --- --- Fold and unfold an Integer to and from a list of its bytes --- -unroll :: Integer -> [Word8] -unroll = unfoldr step - where - step 0 = Nothing - step i = Just (fromIntegral i, i `shiftR` 8) - -roll :: [Word8] -> Integer -roll = foldr unstep 0 - where - unstep b a = a `shiftL` 8 .|. fromIntegral b - -{- - --- --- An efficient, raw serialisation for Integer (GHC only) --- - --- TODO This instance is not architecture portable. GMP stores numbers as --- arrays of machine sized words, so the byte format is not portable across --- architectures with different endianness and word size. - -import Data.ByteString.Base (toForeignPtr,unsafePackAddress, memcpy) -import GHC.Base hiding (ord, chr) -import GHC.Prim -import GHC.Ptr (Ptr(..)) -import GHC.IOBase (IO(..)) - -instance Binary Integer where - put (S# i) = putWord8 0 *> put (I# i) - put (J# s ba) = do - putWord8 1 - put (I# s) - put (BA ba) - - get = do - b <- getWord8 - case b of - 0 -> do (I# i#) <- get - return (S# i#) - _ -> do (I# s#) <- get - (BA a#) <- get - return (J# s# a#) - -instance Binary ByteArray where - - -- Pretty safe. - put (BA ba) = - let sz = sizeofByteArray# ba -- (primitive) in *bytes* - addr = byteArrayContents# ba - bs = unsafePackAddress (I# sz) addr - in put bs -- write as a ByteString. easy, yay! - - -- Pretty scary. Should be quick though - get = do - (fp, off, n@(I# sz)) <- fmap toForeignPtr get -- so decode a ByteString - assert (off == 0) $ return $ unsafePerformIO $ do - (MBA arr) <- newByteArray sz -- and copy it into a ByteArray# - let to = byteArrayContents# (unsafeCoerce# arr) -- urk, is this safe? - withForeignPtr fp $ \from -> memcpy (Ptr to) from (fromIntegral n) - freezeByteArray arr - --- wrapper for ByteArray# -data ByteArray = BA {-# UNPACK #-} !ByteArray# -data MBA = MBA {-# UNPACK #-} !(MutableByteArray# RealWorld) - -newByteArray :: Int# -> IO MBA -newByteArray sz = IO $ \s -> - case newPinnedByteArray# sz s of { (# s', arr #) -> - (# s', MBA arr #) } - -freezeByteArray :: MutableByteArray# RealWorld -> IO ByteArray -freezeByteArray arr = IO $ \s -> - case unsafeFreezeByteArray# arr s of { (# s', arr' #) -> - (# s', BA arr' #) } - --} - -instance (Binary a,Integral a) => Binary (R.Ratio a) where - put r = put (R.numerator r) *> put (R.denominator r) - get = (R.%) <$> get <*> get - ------------------------------------------------------------------------- - --- Char is serialised as UTF-8 -instance Binary Char where - put a | c <= 0x7f = put (fromIntegral c :: Word8) - | c <= 0x7ff = do put (0xc0 .|. y) - put (0x80 .|. z) - | c <= 0xffff = do put (0xe0 .|. x) - put (0x80 .|. y) - put (0x80 .|. z) - | c <= 0x10ffff = do put (0xf0 .|. w) - put (0x80 .|. x) - put (0x80 .|. y) - put (0x80 .|. z) - | otherwise = error "Not a valid Unicode code point" - where - c = ord a - z, y, x, w :: Word8 - z = fromIntegral (c .&. 0x3f) - y = fromIntegral (shiftR c 6 .&. 0x3f) - x = fromIntegral (shiftR c 12 .&. 0x3f) - w = fromIntegral (shiftR c 18 .&. 0x7) - - get = do - let getByte = fmap (fromIntegral :: Word8 -> Int) get - shiftL6 = flip shiftL 6 :: Int -> Int - w <- getByte - r <- case () of - _ | w < 0x80 -> return w - | w < 0xe0 -> do - x <- fmap (xor 0x80) getByte - return (x .|. shiftL6 (xor 0xc0 w)) - | w < 0xf0 -> do - x <- fmap (xor 0x80) getByte - y <- fmap (xor 0x80) getByte - return (y .|. shiftL6 (x .|. shiftL6 - (xor 0xe0 w))) - | otherwise -> do - x <- fmap (xor 0x80) getByte - y <- fmap (xor 0x80) getByte - z <- fmap (xor 0x80) getByte - return (z .|. shiftL6 (y .|. shiftL6 - (x .|. shiftL6 (xor 0xf0 w)))) - return $! chr r - ------------------------------------------------------------------------- --- Instances for the first few tuples - -instance (Binary a, Binary b) => Binary (a,b) where - put (a,b) = put a *> put b - get = (,) <$> get <*> get - -instance (Binary a, Binary b, Binary c) => Binary (a,b,c) where - put (a,b,c) = put a *> put b *> put c - get = (,,) <$> get <*> get <*> get - -instance (Binary a, Binary b, Binary c, Binary d) => Binary (a,b,c,d) where - put (a,b,c,d) = put a *> put b *> put c *> put d - get = (,,,) <$> get <*> get <*> get <*> get - -instance (Binary a, Binary b, Binary c, Binary d, Binary e) => Binary (a,b,c,d,e) where - put (a,b,c,d,e) = put a *> put b *> put c *> put d *> put e - get = (,,,,) <$> get <*> get <*> get <*> get <*> get - --- --- and now just recurse: --- - -instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f) - => Binary (a,b,c,d,e,f) where - put (a,b,c,d,e,f) = put (a,(b,c,d,e,f)) - get = do (a,(b,c,d,e,f)) <- get ; return (a,b,c,d,e,f) - -instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f, Binary g) - => Binary (a,b,c,d,e,f,g) where - put (a,b,c,d,e,f,g) = put (a,(b,c,d,e,f,g)) - get = do (a,(b,c,d,e,f,g)) <- get ; return (a,b,c,d,e,f,g) - -instance (Binary a, Binary b, Binary c, Binary d, Binary e, - Binary f, Binary g, Binary h) - => Binary (a,b,c,d,e,f,g,h) where - put (a,b,c,d,e,f,g,h) = put (a,(b,c,d,e,f,g,h)) - get = do (a,(b,c,d,e,f,g,h)) <- get ; return (a,b,c,d,e,f,g,h) - -instance (Binary a, Binary b, Binary c, Binary d, Binary e, - Binary f, Binary g, Binary h, Binary i) - => Binary (a,b,c,d,e,f,g,h,i) where - put (a,b,c,d,e,f,g,h,i) = put (a,(b,c,d,e,f,g,h,i)) - get = do (a,(b,c,d,e,f,g,h,i)) <- get ; return (a,b,c,d,e,f,g,h,i) - -instance (Binary a, Binary b, Binary c, Binary d, Binary e, - Binary f, Binary g, Binary h, Binary i, Binary j) - => Binary (a,b,c,d,e,f,g,h,i,j) where - put (a,b,c,d,e,f,g,h,i,j) = put (a,(b,c,d,e,f,g,h,i,j)) - get = do (a,(b,c,d,e,f,g,h,i,j)) <- get ; return (a,b,c,d,e,f,g,h,i,j) - ------------------------------------------------------------------------- --- Container types - -instance Binary a => Binary [a] where - put l = put (length l) *> traverse_ put l - get = do n <- get :: Get Int - getMany n - --- | 'getMany n' get 'n' elements in order, without blowing the stack. -getMany :: Binary a => Int -> Get [a] -getMany n = go [] n - where - go xs 0 = return $! reverse xs - go xs i = do x <- get - -- we must seq x to avoid stack overflows due to laziness in - -- (>>=) - x `seq` go (x:xs) (i-1) -{-# INLINE getMany #-} - -instance (Binary a) => Binary (Maybe a) where - put Nothing = putWord8 0 - put (Just x) = putWord8 1 *> put x - get = do - w <- getWord8 - case w of - 0 -> return Nothing - _ -> fmap Just get - -instance (Binary a, Binary b) => Binary (Either a b) where - put (Left a) = putWord8 0 *> put a - put (Right b) = putWord8 1 *> put b - get = do - w <- getWord8 - case w of - 0 -> fmap Left get - _ -> fmap Right get - ------------------------------------------------------------------------- --- ByteStrings (have specially efficient instances) - -instance Binary B.ByteString where - put bs = do put (B.length bs) - putByteString bs - get = get >>= getByteString - --- --- Using old versions of fps, this is a type synonym, and non portable --- --- Requires 'flexible instances' --- -instance Binary ByteString where - put bs = do put (fromIntegral (L.length bs) :: Int) - putLazyByteString bs - get = get >>= getLazyByteString - ------------------------------------------------------------------------- --- Maps and Sets - -instance (Binary a) => Binary (Set.Set a) where - put s = put (Set.size s) *> traverse_ put (Set.toAscList s) - get = fmap Set.fromDistinctAscList get - -instance (Binary k, Binary e) => Binary (Map.Map k e) where - put m = put (Map.size m) *> traverse_ put (Map.toAscList m) - get = fmap Map.fromDistinctAscList get - -instance Binary IntSet.IntSet where - put s = put (IntSet.size s) *> traverse_ put (IntSet.toAscList s) - get = fmap IntSet.fromDistinctAscList get - -instance (Binary e) => Binary (IntMap.IntMap e) where - put m = put (IntMap.size m) *> traverse_ put (IntMap.toAscList m) - get = fmap IntMap.fromDistinctAscList get - ------------------------------------------------------------------------- --- Queues and Sequences - -instance (Binary e) => Binary (Seq.Seq e) where - put s = put (Seq.length s) *> Fold.traverse_ put s - get = do n <- get :: Get Int - rep Seq.empty n get - where rep xs 0 _ = return $! xs - rep xs n g = xs `seq` n `seq` do - x <- g - rep (xs Seq.|> x) (n-1) g - ------------------------------------------------------------------------- --- Floating point - -instance Binary Double where - put d = put (decodeFloat d) - get = encodeFloat <$> get <*> get - -instance Binary Float where - put f = put (decodeFloat f) - get = encodeFloat <$> get <*> get - ------------------------------------------------------------------------- --- Trees - -instance (Binary e) => Binary (T.Tree e) where - put (T.Node r s) = put r *> put s - get = T.Node <$> get <*> get - ------------------------------------------------------------------------- --- Arrays - -instance (Binary i, Ix i, Binary e) => Binary (Array i e) where - put a = do - put (bounds a) - put (rangeSize $ bounds a) -- write the length - traverse_ put (elems a) -- now the elems. - get = do - bs <- get - n <- get -- read the length - xs <- getMany n -- now the elems. - return (listArray bs xs) - --- --- The IArray UArray e constraint is non portable. Requires flexible instances --- -instance (Binary i, Ix i, Binary e, IArray UArray e) => Binary (UArray i e) where - put a = do - put (bounds a) - put (rangeSize $ bounds a) -- now write the length - traverse_ put (elems a) - get = do - bs <- get - n <- get - xs <- getMany n - return (listArray bs xs) diff --git a/src/Distribution/Compat/Binary/Generic.hs b/src/Distribution/Compat/Binary/Generic.hs deleted file mode 100644 --- a/src/Distribution/Compat/Binary/Generic.hs +++ /dev/null @@ -1,128 +0,0 @@ -{-# LANGUAGE BangPatterns, CPP, FlexibleInstances, KindSignatures, - ScopedTypeVariables, Trustworthy, TypeOperators, TypeSynonymInstances #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - ------------------------------------------------------------------------------ --- | --- Module : Distribution.Compat.Binary.Generic --- Copyright : Bryan O'Sullivan --- License : BSD3-style (see LICENSE) --- --- Maintainer : Bryan O'Sullivan --- Stability : unstable --- Portability : Only works with GHC 7.2 and newer --- --- Instances for supporting GHC generics. --- ------------------------------------------------------------------------------ -module Distribution.Compat.Binary.Generic - ( - ) where - -import Control.Applicative -import Distribution.Compat.Binary.Class -import Data.Binary.Get -import Data.Binary.Put -import Data.Bits -import Data.Word -import GHC.Generics - --- Type without constructors -instance GBinary V1 where - gput _ = return () - gget = return undefined - --- Constructor without arguments -instance GBinary U1 where - gput U1 = return () - gget = return U1 - --- Product: constructor with parameters -instance (GBinary a, GBinary b) => GBinary (a :*: b) where - gput (x :*: y) = gput x >> gput y - gget = (:*:) <$> gget <*> gget - --- Metadata (constructor name, etc) -instance GBinary a => GBinary (M1 i c a) where - gput = gput . unM1 - gget = M1 <$> gget - --- Constants, additional parameters, and rank-1 recursion -instance Binary a => GBinary (K1 i a) where - gput = put . unK1 - gget = K1 <$> get - --- Borrowed from the cereal package. - --- The following GBinary instance for sums has support for serializing --- types with up to 2^64-1 constructors. It will use the minimal --- number of bytes needed to encode the constructor. For example when --- a type has 2^8 constructors or less it will use a single byte to --- encode the constructor. If it has 2^16 constructors or less it will --- use two bytes, and so on till 2^64-1. - -#define GUARD(WORD) (size - 1) <= fromIntegral (maxBound :: WORD) -#define PUTSUM(WORD) GUARD(WORD) = putSum (0 :: WORD) (fromIntegral size) -#define GETSUM(WORD) GUARD(WORD) = (get :: Get WORD) >>= checkGetSum (fromIntegral size) - -instance ( GSum a, GSum b - , GBinary a, GBinary b - , SumSize a, SumSize b) => GBinary (a :+: b) where - gput | PUTSUM(Word8) | PUTSUM(Word16) | PUTSUM(Word32) | PUTSUM(Word64) - | otherwise = sizeError "encode" size - where - size = unTagged (sumSize :: Tagged (a :+: b) Word64) - - gget | GETSUM(Word8) | GETSUM(Word16) | GETSUM(Word32) | GETSUM(Word64) - | otherwise = sizeError "decode" size - where - size = unTagged (sumSize :: Tagged (a :+: b) Word64) - -sizeError :: Show size => String -> size -> error -sizeError s size = - error $ "Can't " ++ s ++ " a type with " ++ show size ++ " constructors" - ------------------------------------------------------------------------- - -checkGetSum :: (Ord word, Num word, Bits word, GSum f) - => word -> word -> Get (f a) -checkGetSum size code | code < size = getSum code size - | otherwise = fail "Unknown encoding for constructor" -{-# INLINE checkGetSum #-} - -class GSum f where - getSum :: (Ord word, Num word, Bits word) => word -> word -> Get (f a) - putSum :: (Num w, Bits w, Binary w) => w -> w -> f a -> Put - -instance (GSum a, GSum b, GBinary a, GBinary b) => GSum (a :+: b) where - getSum !code !size | code < sizeL = L1 <$> getSum code sizeL - | otherwise = R1 <$> getSum (code - sizeL) sizeR - where - sizeL = size `shiftR` 1 - sizeR = size - sizeL - - putSum !code !size s = case s of - L1 x -> putSum code sizeL x - R1 x -> putSum (code + sizeL) sizeR x - where - sizeL = size `shiftR` 1 - sizeR = size - sizeL - -instance GBinary a => GSum (C1 c a) where - getSum _ _ = gget - - putSum !code _ x = put code *> gput x - ------------------------------------------------------------------------- - -class SumSize f where - sumSize :: Tagged f Word64 - -newtype Tagged (s :: * -> *) b = Tagged {unTagged :: b} - -instance (SumSize a, SumSize b) => SumSize (a :+: b) where - sumSize = Tagged $ unTagged (sumSize :: Tagged a Word64) + - unTagged (sumSize :: Tagged b Word64) - -instance SumSize (C1 c a) where - sumSize = Tagged 1 diff --git a/src/Distribution/Compat/CharParsing.hs b/src/Distribution/Compat/CharParsing.hs deleted file mode 100644 --- a/src/Distribution/Compat/CharParsing.hs +++ /dev/null @@ -1,357 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -fspec-constr -fspec-constr-count=8 #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Compat.CharParsing --- Copyright : (c) Edward Kmett 2011 --- License : BSD3 --- --- Maintainer : ekmett@gmail.com --- Stability : experimental --- Portability : non-portable --- --- Parsers for character streams --- --- Originally in @parsers@ package. --- ------------------------------------------------------------------------------ -module Distribution.Compat.CharParsing - ( - -- * Combinators - oneOf -- :: CharParsing m => [Char] -> m Char - , noneOf -- :: CharParsing m => [Char] -> m Char - , spaces -- :: CharParsing m => m () - , space -- :: CharParsing m => m Char - , newline -- :: CharParsing m => m Char - , tab -- :: CharParsing m => m Char - , upper -- :: CharParsing m => m Char - , lower -- :: CharParsing m => m Char - , alphaNum -- :: CharParsing m => m Char - , letter -- :: CharParsing m => m Char - , digit -- :: CharParsing m => m Char - , hexDigit -- :: CharParsing m => m Char - , octDigit -- :: CharParsing m => m Char - , satisfyRange -- :: CharParsing m => Char -> Char -> m Char - -- * Class - , CharParsing(..) - -- * Cabal additions - , integral - , signedIntegral - , munch1 - , munch - , skipSpaces1 - , module Distribution.Compat.Parsing - ) where - -import Prelude () -import Distribution.Compat.Prelude - -import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.State.Lazy as Lazy -import Control.Monad.Trans.State.Strict as Strict -import Control.Monad.Trans.Writer.Lazy as Lazy -import Control.Monad.Trans.Writer.Strict as Strict -import Control.Monad.Trans.RWS.Lazy as Lazy -import Control.Monad.Trans.RWS.Strict as Strict -import Control.Monad.Trans.Reader (ReaderT (..)) -import Control.Monad.Trans.Identity (IdentityT (..)) -import Data.Char -import Data.Text (Text, unpack) - -import qualified Text.Parsec as Parsec - -import Distribution.Compat.Parsing - --- | @oneOf cs@ succeeds if the current character is in the supplied --- list of characters @cs@. Returns the parsed character. See also --- 'satisfy'. --- --- > vowel = oneOf "aeiou" -oneOf :: CharParsing m => [Char] -> m Char -oneOf xs = satisfy (\c -> c `elem` xs) -{-# INLINE oneOf #-} - --- | As the dual of 'oneOf', @noneOf cs@ succeeds if the current --- character is /not/ in the supplied list of characters @cs@. Returns the --- parsed character. --- --- > consonant = noneOf "aeiou" -noneOf :: CharParsing m => [Char] -> m Char -noneOf xs = satisfy (\c -> c `notElem` xs) -{-# INLINE noneOf #-} - --- | Skips /zero/ or more white space characters. See also 'skipMany'. -spaces :: CharParsing m => m () -spaces = skipMany space "white space" -{-# INLINE spaces #-} - --- | Parses a white space character (any character which satisfies 'isSpace') --- Returns the parsed character. -space :: CharParsing m => m Char -space = satisfy isSpace "space" -{-# INLINE space #-} - --- | Parses a newline character (\'\\n\'). Returns a newline character. -newline :: CharParsing m => m Char -newline = char '\n' "new-line" -{-# INLINE newline #-} - --- | Parses a tab character (\'\\t\'). Returns a tab character. -tab :: CharParsing m => m Char -tab = char '\t' "tab" -{-# INLINE tab #-} - --- | Parses an upper case letter. Returns the parsed character. -upper :: CharParsing m => m Char -upper = satisfy isUpper "uppercase letter" -{-# INLINE upper #-} - --- | Parses a lower case character. Returns the parsed character. -lower :: CharParsing m => m Char -lower = satisfy isLower "lowercase letter" -{-# INLINE lower #-} - --- | Parses a letter or digit. Returns the parsed character. -alphaNum :: CharParsing m => m Char -alphaNum = satisfy isAlphaNum "letter or digit" -{-# INLINE alphaNum #-} - --- | Parses a letter (an upper case or lower case character). Returns the --- parsed character. -letter :: CharParsing m => m Char -letter = satisfy isAlpha "letter" -{-# INLINE letter #-} - --- | Parses a digit. Returns the parsed character. -digit :: CharParsing m => m Char -digit = satisfy isDigit "digit" -{-# INLINE digit #-} - --- | Parses a hexadecimal digit (a digit or a letter between \'a\' and --- \'f\' or \'A\' and \'F\'). Returns the parsed character. -hexDigit :: CharParsing m => m Char -hexDigit = satisfy isHexDigit "hexadecimal digit" -{-# INLINE hexDigit #-} - --- | Parses an octal digit (a character between \'0\' and \'7\'). Returns --- the parsed character. -octDigit :: CharParsing m => m Char -octDigit = satisfy isOctDigit "octal digit" -{-# INLINE octDigit #-} - -satisfyRange :: CharParsing m => Char -> Char -> m Char -satisfyRange a z = satisfy (\c -> c >= a && c <= z) -{-# INLINE satisfyRange #-} - --- | Additional functionality needed to parse character streams. -class Parsing m => CharParsing m where - -- | Parse a single character of the input, with UTF-8 decoding - satisfy :: (Char -> Bool) -> m Char - - -- | @char c@ parses a single character @c@. Returns the parsed - -- character (i.e. @c@). - -- - -- /e.g./ - -- - -- @semiColon = 'char' ';'@ - char :: Char -> m Char - char c = satisfy (c ==) show [c] - {-# INLINE char #-} - - -- | @notChar c@ parses any single character other than @c@. Returns the parsed - -- character. - notChar :: Char -> m Char - notChar c = satisfy (c /=) - {-# INLINE notChar #-} - - -- | This parser succeeds for any character. Returns the parsed character. - anyChar :: m Char - anyChar = satisfy (const True) - {-# INLINE anyChar #-} - - -- | @string s@ parses a sequence of characters given by @s@. Returns - -- the parsed string (i.e. @s@). - -- - -- > divOrMod = string "div" - -- > <|> string "mod" - string :: String -> m String - string s = s <$ try (traverse_ char s) show s - {-# INLINE string #-} - - -- | @text t@ parses a sequence of characters determined by the text @t@ Returns - -- the parsed text fragment (i.e. @t@). - -- - -- Using @OverloadedStrings@: - -- - -- > divOrMod = text "div" - -- > <|> text "mod" - text :: Text -> m Text - text t = t <$ string (unpack t) - {-# INLINE text #-} - -instance (CharParsing m, MonadPlus m) => CharParsing (Lazy.StateT s m) where - satisfy = lift . satisfy - {-# INLINE satisfy #-} - char = lift . char - {-# INLINE char #-} - notChar = lift . notChar - {-# INLINE notChar #-} - anyChar = lift anyChar - {-# INLINE anyChar #-} - string = lift . string - {-# INLINE string #-} - text = lift . text - {-# INLINE text #-} - -instance (CharParsing m, MonadPlus m) => CharParsing (Strict.StateT s m) where - satisfy = lift . satisfy - {-# INLINE satisfy #-} - char = lift . char - {-# INLINE char #-} - notChar = lift . notChar - {-# INLINE notChar #-} - anyChar = lift anyChar - {-# INLINE anyChar #-} - string = lift . string - {-# INLINE string #-} - text = lift . text - {-# INLINE text #-} - -instance (CharParsing m, MonadPlus m) => CharParsing (ReaderT e m) where - satisfy = lift . satisfy - {-# INLINE satisfy #-} - char = lift . char - {-# INLINE char #-} - notChar = lift . notChar - {-# INLINE notChar #-} - anyChar = lift anyChar - {-# INLINE anyChar #-} - string = lift . string - {-# INLINE string #-} - text = lift . text - {-# INLINE text #-} - -instance (CharParsing m, MonadPlus m, Monoid w) => CharParsing (Strict.WriterT w m) where - satisfy = lift . satisfy - {-# INLINE satisfy #-} - char = lift . char - {-# INLINE char #-} - notChar = lift . notChar - {-# INLINE notChar #-} - anyChar = lift anyChar - {-# INLINE anyChar #-} - string = lift . string - {-# INLINE string #-} - text = lift . text - {-# INLINE text #-} - -instance (CharParsing m, MonadPlus m, Monoid w) => CharParsing (Lazy.WriterT w m) where - satisfy = lift . satisfy - {-# INLINE satisfy #-} - char = lift . char - {-# INLINE char #-} - notChar = lift . notChar - {-# INLINE notChar #-} - anyChar = lift anyChar - {-# INLINE anyChar #-} - string = lift . string - {-# INLINE string #-} - text = lift . text - {-# INLINE text #-} - -instance (CharParsing m, MonadPlus m, Monoid w) => CharParsing (Lazy.RWST r w s m) where - satisfy = lift . satisfy - {-# INLINE satisfy #-} - char = lift . char - {-# INLINE char #-} - notChar = lift . notChar - {-# INLINE notChar #-} - anyChar = lift anyChar - {-# INLINE anyChar #-} - string = lift . string - {-# INLINE string #-} - text = lift . text - {-# INLINE text #-} - -instance (CharParsing m, MonadPlus m, Monoid w) => CharParsing (Strict.RWST r w s m) where - satisfy = lift . satisfy - {-# INLINE satisfy #-} - char = lift . char - {-# INLINE char #-} - notChar = lift . notChar - {-# INLINE notChar #-} - anyChar = lift anyChar - {-# INLINE anyChar #-} - string = lift . string - {-# INLINE string #-} - text = lift . text - {-# INLINE text #-} - -instance (CharParsing m, MonadPlus m) => CharParsing (IdentityT m) where - satisfy = lift . satisfy - {-# INLINE satisfy #-} - char = lift . char - {-# INLINE char #-} - notChar = lift . notChar - {-# INLINE notChar #-} - anyChar = lift anyChar - {-# INLINE anyChar #-} - string = lift . string - {-# INLINE string #-} - text = lift . text - {-# INLINE text #-} - -instance Parsec.Stream s m Char => CharParsing (Parsec.ParsecT s u m) where - satisfy = Parsec.satisfy - char = Parsec.char - notChar c = Parsec.satisfy (/= c) - anyChar = Parsec.anyChar - string = Parsec.string - -------------------------------------------------------------------------------- --- Our additions -------------------------------------------------------------------------------- - -integral :: (CharParsing m, Integral a) => m a -integral = toNumber <$> some d "integral" - where - toNumber = foldl' (\a b -> a * 10 + b) 0 - d = f <$> satisfyRange '0' '9' - f '0' = 0 - f '1' = 1 - f '2' = 2 - f '3' = 3 - f '4' = 4 - f '5' = 5 - f '6' = 6 - f '7' = 7 - f '8' = 8 - f '9' = 9 - f _ = error "panic! integral" -{-# INLINE integral #-} - --- | Accepts negative (starting with @-@) and positive (without sign) integral --- numbers. --- --- @since 3.4.0.0 -signedIntegral :: (CharParsing m, Integral a) => m a -signedIntegral = negate <$ char '-' <*> integral <|> integral -{-# INLINE signedIntegral #-} - --- | Greedily munch characters while predicate holds. --- Require at least one character. -munch1 :: CharParsing m => (Char -> Bool) -> m String -munch1 = some . satisfy -{-# INLINE munch1 #-} - --- | Greedely munch characters while predicate holds. --- Always succeeds. -munch :: CharParsing m => (Char -> Bool) -> m String -munch = many . satisfy -{-# INLINE munch #-} - -skipSpaces1 :: CharParsing m => m () -skipSpaces1 = skipSome space -{-# INLINE skipSpaces1 #-} diff --git a/src/Distribution/Compat/CopyFile.hs b/src/Distribution/Compat/CopyFile.hs --- a/src/Distribution/Compat/CopyFile.hs +++ b/src/Distribution/Compat/CopyFile.hs @@ -20,6 +20,8 @@ import Control.Exception ( bracketOnError ) import qualified Data.ByteString.Lazy as BSL +import Data.Bits + ( (.|.) ) import System.IO.Error ( ioeSetLocation ) import System.Directory @@ -34,10 +36,8 @@ import System.Posix.Types ( FileMode ) -import System.Posix.Internals - ( c_chmod, withFilePath ) -import Foreign.C - ( throwErrnoPathIfMinus1_ ) +import System.Posix.Files + ( getFileStatus, fileMode, setFileMode ) #else /* else mingw32_HOST_OS */ @@ -69,15 +69,17 @@ copyOrdinaryFile src dest = copyFile src dest >> setFileOrdinary dest copyExecutableFile src dest = copyFile src dest >> setFileExecutable dest -setFileOrdinary, setFileExecutable, setDirOrdinary :: FilePath -> IO () +setFileOrdinary, setFileExecutable, setDirOrdinary :: FilePath -> IO () #ifndef mingw32_HOST_OS -setFileOrdinary path = setFileMode path 0o644 -- file perms -rw-r--r-- -setFileExecutable path = setFileMode path 0o755 -- file perms -rwxr-xr-x +-- When running with a restrictive UMASK such as 0077 we still want to +-- install files and directories that are accessible to other users. +setFileOrdinary path = addFileMode path 0o644 -- file perms -rw-r--r-- +setFileExecutable path = addFileMode path 0o755 -- file perms -rwxr-xr-x -setFileMode :: FilePath -> FileMode -> IO () -setFileMode name m = - withFilePath name $ \s -> do - throwErrnoPathIfMinus1_ "setFileMode" name (c_chmod s m) +addFileMode :: FilePath -> FileMode -> IO () +addFileMode name m = do + o <- fileMode <$> getFileStatus name + setFileMode name (m .|. o) #else setFileOrdinary _ = return () setFileExecutable _ = return () diff --git a/src/Distribution/Compat/CreatePipe.hs b/src/Distribution/Compat/CreatePipe.hs --- a/src/Distribution/Compat/CreatePipe.hs +++ b/src/Distribution/Compat/CreatePipe.hs @@ -1,81 +1,5 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} - -module Distribution.Compat.CreatePipe (createPipe) where +module Distribution.Compat.CreatePipe + {-# DEPRECATED "Use System.Process from package process directly" #-} + (createPipe) where -#if MIN_VERSION_process(1,2,1) import System.Process (createPipe) -#else -import System.IO (Handle, hSetBinaryMode) - -import Prelude () -import Distribution.Compat.Prelude -import Distribution.Compat.Stack - --- The mingw32_HOST_OS CPP macro is GHC-specific -#ifdef mingw32_HOST_OS -import qualified Prelude -import Control.Exception (onException) -import Foreign.C.Error (throwErrnoIfMinus1_) -import Foreign.C.Types (CInt(..), CUInt(..)) -import Foreign.Ptr (Ptr) -import Foreign.Marshal.Array (allocaArray) -import Foreign.Storable (peek, peekElemOff) -import GHC.IO.FD (mkFD) -import GHC.IO.Device (IODeviceType(Stream)) -import GHC.IO.Handle.FD (mkHandleFromFD) -import System.IO (IOMode(ReadMode, WriteMode)) -#elif defined ghcjs_HOST_OS -#else -import System.Posix.IO (fdToHandle) -import qualified System.Posix.IO as Posix -#endif - -createPipe :: IO (Handle, Handle) --- The mingw32_HOST_OS CPP macro is GHC-specific -#ifdef mingw32_HOST_OS -createPipe = do - (readfd, writefd) <- allocaArray 2 $ \ pfds -> do - throwErrnoIfMinus1_ "_pipe" $ c__pipe pfds 2 ({- _O_BINARY -} 32768) - readfd <- peek pfds - writefd <- peekElemOff pfds 1 - return (readfd, writefd) - (do readh <- fdToHandle readfd ReadMode - writeh <- fdToHandle writefd WriteMode - hSetBinaryMode readh True - hSetBinaryMode writeh True - return (readh, writeh)) `onException` (close readfd >> close writefd) - where - fdToHandle :: CInt -> IOMode -> IO Handle - fdToHandle fd mode = do - (fd', deviceType) <- mkFD fd mode (Just (Stream, 0, 0)) False False - mkHandleFromFD fd' deviceType "" mode False Nothing - - close :: CInt -> IO () - close = throwErrnoIfMinus1_ "_close" . c__close - where _ = callStack -- TODO: attach call stack to exception - - _ = callStack -- TODO: attach call stack to exceptions - -foreign import ccall "io.h _pipe" c__pipe :: - Ptr CInt -> CUInt -> CInt -> Prelude.IO CInt - -foreign import ccall "io.h _close" c__close :: - CInt -> Prelude.IO CInt -#elif defined ghcjs_HOST_OS -createPipe = error "createPipe" - where - _ = callStack -#else -createPipe = do - (readfd, writefd) <- Posix.createPipe - readh <- fdToHandle readfd - writeh <- fdToHandle writefd - hSetBinaryMode readh True - hSetBinaryMode writeh True - return (readh, writeh) - where - _ = callStack -#endif -#endif diff --git a/src/Distribution/Compat/DList.hs b/src/Distribution/Compat/DList.hs deleted file mode 100644 --- a/src/Distribution/Compat/DList.hs +++ /dev/null @@ -1,53 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Compat.DList --- Copyright : (c) Ben Gamari 2015-2019 --- License : BSD3 --- --- Maintainer : cabal-dev@haskell.org --- Stability : experimental --- Portability : portable --- --- A very simple difference list. -module Distribution.Compat.DList ( - DList, - runDList, - empty, - singleton, - fromList, - toList, - snoc, -) where - -import Prelude () -import Distribution.Compat.Prelude hiding (toList, empty) - --- | Difference list. -newtype DList a = DList ([a] -> [a]) - -runDList :: DList a -> [a] -runDList (DList run) = run [] - --- | Make 'DList' containing single element. -singleton :: a -> DList a -singleton a = DList (a:) - --- | @since 3.4.0.0 -empty :: DList a -empty = DList id - -fromList :: [a] -> DList a -fromList as = DList (as ++) - -toList :: DList a -> [a] -toList = runDList - -snoc :: DList a -> a -> DList a -snoc xs x = xs <> singleton x - -instance Monoid (DList a) where - mempty = empty - mappend = (<>) - -instance Semigroup (DList a) where - DList a <> DList b = DList (a . b) diff --git a/src/Distribution/Compat/Environment.hs b/src/Distribution/Compat/Environment.hs --- a/src/Distribution/Compat/Environment.hs +++ b/src/Distribution/Compat/Environment.hs @@ -11,25 +11,13 @@ import qualified Prelude import Distribution.Compat.Prelude -#ifndef mingw32_HOST_OS -#if __GLASGOW_HASKELL__ < 708 -import Foreign.C.Error (throwErrnoIf_) -#endif -#endif - import qualified System.Environment as System -import System.Environment (lookupEnv) -#if __GLASGOW_HASKELL__ >= 708 -import System.Environment (unsetEnv) -#endif +import System.Environment (lookupEnv, unsetEnv) import Distribution.Compat.Stack #ifdef mingw32_HOST_OS import Foreign.C -#if __GLASGOW_HASKELL__ < 708 -import Foreign.Ptr (nullPtr) -#endif import GHC.Windows #else import Foreign.C.Types @@ -95,40 +83,3 @@ foreign import ccall unsafe "setenv" c_setenv :: CString -> CString -> CInt -> Prelude.IO CInt #endif /* mingw32_HOST_OS */ - -#if __GLASGOW_HASKELL__ < 708 - --- | @unsetEnv name@ removes the specified environment variable from the --- environment of the current process. --- --- Throws `Control.Exception.IOException` if @name@ is the empty string or --- contains an equals sign. --- --- @since 4.7.0.0 -unsetEnv :: String -> IO () -#ifdef mingw32_HOST_OS -unsetEnv key = withCWString key $ \k -> do - success <- c_SetEnvironmentVariable k nullPtr - unless success $ do - -- We consider unsetting an environment variable that does not exist not as - -- an error, hence we ignore eRROR_ENVVAR_NOT_FOUND. - err <- c_GetLastError - unless (err == eRROR_ENVVAR_NOT_FOUND) $ do - throwGetLastError "unsetEnv" - -eRROR_ENVVAR_NOT_FOUND :: DWORD -eRROR_ENVVAR_NOT_FOUND = 203 - -foreign import WINDOWS_CCONV unsafe "windows.h GetLastError" - c_GetLastError:: IO DWORD -#else -unsetEnv key = withFilePath key (throwErrnoIf_ (/= 0) "unsetEnv" . c_unsetenv) -#if __GLASGOW_HASKELL__ > 706 -foreign import ccall unsafe "__hsbase_unsetenv" c_unsetenv :: CString -> Prelude.IO CInt -#else --- HACK: We hope very hard that !UNSETENV_RETURNS_VOID -foreign import ccall unsafe "unsetenv" c_unsetenv :: CString -> Prelude.IO CInt -#endif -#endif - -#endif diff --git a/src/Distribution/Compat/Exception.hs b/src/Distribution/Compat/Exception.hs deleted file mode 100644 --- a/src/Distribution/Compat/Exception.hs +++ /dev/null @@ -1,37 +0,0 @@ -{-# LANGUAGE CPP #-} -module Distribution.Compat.Exception ( - catchIO, - catchExit, - tryIO, - displayException, - ) where - -#ifdef MIN_VERSION_base -#define MINVER_base_48 MIN_VERSION_base(4,8,0) -#else -#define MINVER_base_48 (__GLASGOW_HASKELL__ >= 710) -#endif - -import System.Exit -import qualified Control.Exception as Exception - -#if MINVER_base_48 -import Control.Exception (displayException) -#endif - --- | Try 'IOException'. -tryIO :: IO a -> IO (Either Exception.IOException a) -tryIO = Exception.try - --- | Catch 'IOException'. -catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a -catchIO = Exception.catch - --- | Catch 'ExitCode' -catchExit :: IO a -> (ExitCode -> IO a) -> IO a -catchExit = Exception.catch - -#if !MINVER_base_48 -displayException :: Exception.Exception e => e -> String -displayException = show -#endif diff --git a/src/Distribution/Compat/Graph.hs b/src/Distribution/Compat/Graph.hs deleted file mode 100644 --- a/src/Distribution/Compat/Graph.hs +++ /dev/null @@ -1,408 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Compat.Graph --- Copyright : (c) Edward Z. Yang 2016 --- License : BSD3 --- --- Maintainer : cabal-dev@haskell.org --- Stability : experimental --- Portability : portable --- --- A data type representing directed graphs, backed by "Data.Graph". --- It is strict in the node type. --- --- This is an alternative interface to "Data.Graph". In this interface, --- nodes (identified by the 'IsNode' type class) are associated with a --- key and record the keys of their neighbors. This interface is more --- convenient than 'Data.Graph.Graph', which requires vertices to be --- explicitly handled by integer indexes. --- --- The current implementation has somewhat peculiar performance --- characteristics. The asymptotics of all map-like operations mirror --- their counterparts in "Data.Map". However, to perform a graph --- operation, we first must build the "Data.Graph" representation, an --- operation that takes /O(V + E log V)/. However, this operation can --- be amortized across all queries on that particular graph. --- --- Some nodes may be broken, i.e., refer to neighbors which are not --- stored in the graph. In our graph algorithms, we transparently --- ignore such edges; however, you can easily query for the broken --- vertices of a graph using 'broken' (and should, e.g., to ensure that --- a closure of a graph is well-formed.) It's possible to take a closed --- subset of a broken graph and get a well-formed graph. --- ------------------------------------------------------------------------------ - -module Distribution.Compat.Graph ( - -- * Graph type - Graph, - IsNode(..), - -- * Query - null, - size, - member, - lookup, - -- * Construction - empty, - insert, - deleteKey, - deleteLookup, - -- * Combine - unionLeft, - unionRight, - -- * Graph algorithms - stronglyConnComp, - SCC(..), - cycles, - broken, - neighbors, - revNeighbors, - closure, - revClosure, - topSort, - revTopSort, - -- * Conversions - -- ** Maps - toMap, - -- ** Lists - fromDistinctList, - toList, - keys, - -- ** Sets - keysSet, - -- ** Graphs - toGraph, - -- * Node type - Node(..), - nodeValue, -) where - -import Distribution.Compat.Prelude hiding (empty, lookup, null, toList) -import Prelude () - -import Data.Array ((!)) -import Data.Graph (SCC (..)) -import Distribution.Utils.Structured (Structure (..), Structured (..)) - -import qualified Data.Array as Array -import qualified Data.Foldable as Foldable -import qualified Data.Graph as G -import qualified Data.Map.Strict as Map -import qualified Data.Set as Set -import qualified Data.Tree as Tree -import qualified Distribution.Compat.Prelude as Prelude - --- | A graph of nodes @a@. The nodes are expected to have instance --- of class 'IsNode'. -data Graph a - = Graph { - graphMap :: !(Map (Key a) a), - -- Lazily cached graph representation - graphForward :: G.Graph, - graphAdjoint :: G.Graph, - graphVertexToNode :: G.Vertex -> a, - graphKeyToVertex :: Key a -> Maybe G.Vertex, - graphBroken :: [(a, [Key a])] - } - deriving (Typeable) - --- NB: Not a Functor! (or Traversable), because you need --- to restrict Key a ~ Key b. We provide our own mapping --- functions. - --- General strategy is most operations are deferred to the --- Map representation. - -instance Show a => Show (Graph a) where - show = show . toList - -instance (IsNode a, Read a, Show (Key a)) => Read (Graph a) where - readsPrec d s = map (\(a,r) -> (fromDistinctList a, r)) (readsPrec d s) - -instance (IsNode a, Binary a, Show (Key a)) => Binary (Graph a) where - put x = put (toList x) - get = fmap fromDistinctList get - -instance Structured a => Structured (Graph a) where - structure p = Nominal (typeRep p) 0 "Graph" [structure (Proxy :: Proxy a)] - -instance (Eq (Key a), Eq a) => Eq (Graph a) where - g1 == g2 = graphMap g1 == graphMap g2 - -instance Foldable.Foldable Graph where - fold = Foldable.fold . graphMap - foldr f z = Foldable.foldr f z . graphMap - foldl f z = Foldable.foldl f z . graphMap - foldMap f = Foldable.foldMap f . graphMap - foldl' f z = Foldable.foldl' f z . graphMap - foldr' f z = Foldable.foldr' f z . graphMap -#ifdef MIN_VERSION_base -#if MIN_VERSION_base(4,8,0) - length = Foldable.length . graphMap - null = Foldable.null . graphMap - toList = Foldable.toList . graphMap - elem x = Foldable.elem x . graphMap - maximum = Foldable.maximum . graphMap - minimum = Foldable.minimum . graphMap - sum = Foldable.sum . graphMap - product = Foldable.product . graphMap -#endif -#endif - -instance (NFData a, NFData (Key a)) => NFData (Graph a) where - rnf Graph { - graphMap = m, - graphForward = gf, - graphAdjoint = ga, - graphVertexToNode = vtn, - graphKeyToVertex = ktv, - graphBroken = b - } = gf `seq` ga `seq` vtn `seq` ktv `seq` b `seq` rnf m - --- TODO: Data instance? - --- | The 'IsNode' class is used for datatypes which represent directed --- graph nodes. A node of type @a@ is associated with some unique key of --- type @'Key' a@; given a node we can determine its key ('nodeKey') --- and the keys of its neighbors ('nodeNeighbors'). -class Ord (Key a) => IsNode a where - type Key a - nodeKey :: a -> Key a - nodeNeighbors :: a -> [Key a] - -instance (IsNode a, IsNode b, Key a ~ Key b) => IsNode (Either a b) where - type Key (Either a b) = Key a - nodeKey (Left x) = nodeKey x - nodeKey (Right x) = nodeKey x - nodeNeighbors (Left x) = nodeNeighbors x - nodeNeighbors (Right x) = nodeNeighbors x - --- | A simple, trivial data type which admits an 'IsNode' instance. -data Node k a = N a k [k] - deriving (Show, Eq) - --- | Get the value from a 'Node'. -nodeValue :: Node k a -> a -nodeValue (N a _ _) = a - -instance Functor (Node k) where - fmap f (N a k ks) = N (f a) k ks - -instance Ord k => IsNode (Node k a) where - type Key (Node k a) = k - nodeKey (N _ k _) = k - nodeNeighbors (N _ _ ks) = ks - --- TODO: Maybe introduce a typeclass for items which just --- keys (so, Key associated type, and nodeKey method). But --- I didn't need it here, so I didn't introduce it. - --- Query - --- | /O(1)/. Is the graph empty? -null :: Graph a -> Bool -null = Map.null . toMap - --- | /O(1)/. The number of nodes in the graph. -size :: Graph a -> Int -size = Map.size . toMap - --- | /O(log V)/. Check if the key is in the graph. -member :: IsNode a => Key a -> Graph a -> Bool -member k g = Map.member k (toMap g) - --- | /O(log V)/. Lookup the node at a key in the graph. -lookup :: IsNode a => Key a -> Graph a -> Maybe a -lookup k g = Map.lookup k (toMap g) - --- Construction - --- | /O(1)/. The empty graph. -empty :: IsNode a => Graph a -empty = fromMap Map.empty - --- | /O(log V)/. Insert a node into a graph. -insert :: IsNode a => a -> Graph a -> Graph a -insert !n g = fromMap (Map.insert (nodeKey n) n (toMap g)) - --- | /O(log V)/. Delete the node at a key from the graph. -deleteKey :: IsNode a => Key a -> Graph a -> Graph a -deleteKey k g = fromMap (Map.delete k (toMap g)) - --- | /O(log V)/. Lookup and delete. This function returns the deleted --- value if it existed. -deleteLookup :: IsNode a => Key a -> Graph a -> (Maybe a, Graph a) -deleteLookup k g = - let (r, m') = Map.updateLookupWithKey (\_ _ -> Nothing) k (toMap g) - in (r, fromMap m') - --- Combining - --- | /O(V + V')/. Right-biased union, preferring entries --- from the second map when conflicts occur. --- @'nodeKey' x = 'nodeKey' (f x)@. -unionRight :: IsNode a => Graph a -> Graph a -> Graph a -unionRight g g' = fromMap (Map.union (toMap g') (toMap g)) - --- | /O(V + V')/. Left-biased union, preferring entries from --- the first map when conflicts occur. -unionLeft :: IsNode a => Graph a -> Graph a -> Graph a -unionLeft = flip unionRight - --- Graph-like operations - --- | /Ω(V + E)/. Compute the strongly connected components of a graph. --- Requires amortized construction of graph. -stronglyConnComp :: Graph a -> [SCC a] -stronglyConnComp g = map decode forest - where - forest = G.scc (graphForward g) - decode (Tree.Node v []) - | mentions_itself v = CyclicSCC [graphVertexToNode g v] - | otherwise = AcyclicSCC (graphVertexToNode g v) - decode other = CyclicSCC (dec other []) - where dec (Tree.Node v ts) vs - = graphVertexToNode g v : foldr dec vs ts - mentions_itself v = v `elem` (graphForward g ! v) --- Implementation copied from 'stronglyConnCompR' in 'Data.Graph'. - --- | /Ω(V + E)/. Compute the cycles of a graph. --- Requires amortized construction of graph. -cycles :: Graph a -> [[a]] -cycles g = [ vs | CyclicSCC vs <- stronglyConnComp g ] - --- | /O(1)/. Return a list of nodes paired with their broken --- neighbors (i.e., neighbor keys which are not in the graph). --- Requires amortized construction of graph. -broken :: Graph a -> [(a, [Key a])] -broken g = graphBroken g - --- | Lookup the immediate neighbors from a key in the graph. --- Requires amortized construction of graph. -neighbors :: Graph a -> Key a -> Maybe [a] -neighbors g k = do - v <- graphKeyToVertex g k - return (map (graphVertexToNode g) (graphForward g ! v)) - --- | Lookup the immediate reverse neighbors from a key in the graph. --- Requires amortized construction of graph. -revNeighbors :: Graph a -> Key a -> Maybe [a] -revNeighbors g k = do - v <- graphKeyToVertex g k - return (map (graphVertexToNode g) (graphAdjoint g ! v)) - --- | Compute the subgraph which is the closure of some set of keys. --- Returns @Nothing@ if one (or more) keys are not present in --- the graph. --- Requires amortized construction of graph. -closure :: Graph a -> [Key a] -> Maybe [a] -closure g ks = do - vs <- traverse (graphKeyToVertex g) ks - return (decodeVertexForest g (G.dfs (graphForward g) vs)) - --- | Compute the reverse closure of a graph from some set --- of keys. Returns @Nothing@ if one (or more) keys are not present in --- the graph. --- Requires amortized construction of graph. -revClosure :: Graph a -> [Key a] -> Maybe [a] -revClosure g ks = do - vs <- traverse (graphKeyToVertex g) ks - return (decodeVertexForest g (G.dfs (graphAdjoint g) vs)) - -flattenForest :: Tree.Forest a -> [a] -flattenForest = concatMap Tree.flatten - -decodeVertexForest :: Graph a -> Tree.Forest G.Vertex -> [a] -decodeVertexForest g = map (graphVertexToNode g) . flattenForest - --- | Topologically sort the nodes of a graph. --- Requires amortized construction of graph. -topSort :: Graph a -> [a] -topSort g = map (graphVertexToNode g) $ G.topSort (graphForward g) - --- | Reverse topologically sort the nodes of a graph. --- Requires amortized construction of graph. -revTopSort :: Graph a -> [a] -revTopSort g = map (graphVertexToNode g) $ G.topSort (graphAdjoint g) - --- Conversions - --- | /O(1)/. Convert a map from keys to nodes into a graph. --- The map must satisfy the invariant that --- @'fromMap' m == 'fromList' ('Data.Map.elems' m)@; --- if you can't fulfill this invariant use @'fromList' ('Data.Map.elems' m)@ --- instead. The values of the map are assumed to already --- be in WHNF. -fromMap :: IsNode a => Map (Key a) a -> Graph a -fromMap m - = Graph { graphMap = m - -- These are lazily computed! - , graphForward = g - , graphAdjoint = G.transposeG g - , graphVertexToNode = vertex_to_node - , graphKeyToVertex = key_to_vertex - , graphBroken = broke - } - where - try_key_to_vertex k = maybe (Left k) Right (key_to_vertex k) - - (brokenEdges, edges) - = unzip - $ [ partitionEithers (map try_key_to_vertex (nodeNeighbors n)) - | n <- ns ] - broke = filter (not . Prelude.null . snd) (zip ns brokenEdges) - - g = Array.listArray bounds edges - - ns = Map.elems m -- sorted ascending - vertices = zip (map nodeKey ns) [0..] - vertex_map = Map.fromAscList vertices - key_to_vertex k = Map.lookup k vertex_map - - vertex_to_node vertex = nodeTable ! vertex - - nodeTable = Array.listArray bounds ns - bounds = (0, Map.size m - 1) - --- | /O(V log V)/. Convert a list of nodes (with distinct keys) into a graph. -fromDistinctList :: (IsNode a, Show (Key a)) => [a] -> Graph a -fromDistinctList = fromMap - . Map.fromListWith (\_ -> duplicateError) - . map (\n -> n `seq` (nodeKey n, n)) - where - duplicateError n = error $ "Graph.fromDistinctList: duplicate key: " - ++ show (nodeKey n) - --- Map-like operations - --- | /O(V)/. Convert a graph into a list of nodes. -toList :: Graph a -> [a] -toList g = Map.elems (toMap g) - --- | /O(V)/. Convert a graph into a list of keys. -keys :: Graph a -> [Key a] -keys g = Map.keys (toMap g) - --- | /O(V)/. Convert a graph into a set of keys. -keysSet :: Graph a -> Set.Set (Key a) -keysSet g = Map.keysSet (toMap g) - --- | /O(1)/. Convert a graph into a map from keys to nodes. --- The resulting map @m@ is guaranteed to have the property that --- @'Prelude.all' (\(k,n) -> k == 'nodeKey' n) ('Data.Map.toList' m)@. -toMap :: Graph a -> Map (Key a) a -toMap = graphMap - --- Graph-like operations - --- | /O(1)/. Convert a graph into a 'Data.Graph.Graph'. --- Requires amortized construction of graph. -toGraph :: Graph a -> (G.Graph, G.Vertex -> a, Key a -> Maybe G.Vertex) -toGraph g = (graphForward g, graphVertexToNode g, graphKeyToVertex g) diff --git a/src/Distribution/Compat/Lens.hs b/src/Distribution/Compat/Lens.hs deleted file mode 100644 --- a/src/Distribution/Compat/Lens.hs +++ /dev/null @@ -1,262 +0,0 @@ -{-# LANGUAGE RankNTypes #-} --- | This module provides very basic lens functionality, without extra dependencies. --- --- For the documentation of the combinators see package. --- This module uses the same vocabulary. -module Distribution.Compat.Lens ( - -- * Types - Lens, - Lens', - Traversal, - Traversal', - -- ** LensLike - LensLike, - LensLike', - -- ** rank-1 types - Getting, - AGetter, - ASetter, - ALens, - ALens', - -- * Getter - view, - use, - getting, - -- * Setter - set, - over, - -- * Fold - toDListOf, - toListOf, - toSetOf, - -- * Lens - cloneLens, - aview, - -- * Common lenses - _1, _2, - -- * Operators - (&), - (^.), - (.~), (?~), (%~), - (.=), (?=), (%=), - (^#), - (#~), (#%~), - -- * Internal Comonads - Pretext (..), - -- * Cabal developer info - -- $development - ) where - -import Prelude() -import Distribution.Compat.Prelude - -import Control.Monad.State.Class (MonadState (..), gets, modify) - -import qualified Distribution.Compat.DList as DList -import qualified Data.Set as Set - -------------------------------------------------------------------------------- --- Types -------------------------------------------------------------------------------- - -type LensLike f s t a b = (a -> f b) -> s -> f t -type LensLike' f s a = (a -> f a) -> s -> f s - -type Lens s t a b = forall f. Functor f => LensLike f s t a b -type Traversal s t a b = forall f. Applicative f => LensLike f s t a b - -type Lens' s a = Lens s s a a -type Traversal' s a = Traversal s s a a - -type Getting r s a = LensLike (Const r) s s a a - -type AGetter s a = LensLike (Const a) s s a a -- this doesn't exist in 'lens' -type ASetter s t a b = LensLike Identity s t a b -type ALens s t a b = LensLike (Pretext a b) s t a b - -type ALens' s a = ALens s s a a - -------------------------------------------------------------------------------- --- Getter -------------------------------------------------------------------------------- - -view :: Getting a s a -> s -> a -view l s = getConst (l Const s) -{-# INLINE view #-} - -use :: MonadState s m => Getting a s a -> m a -use l = gets (view l) -{-# INLINE use #-} - --- | @since 2.4 --- --- >>> (3 :: Int) ^. getting (+2) . getting show --- "5" -getting :: (s -> a) -> Getting r s a -getting k f = Const . getConst . f . k -{-# INLINE getting #-} - -------------------------------------------------------------------------------- --- Setter -------------------------------------------------------------------------------- - -set :: ASetter s t a b -> b -> s -> t -set l x = over l (const x) - -over :: ASetter s t a b -> (a -> b) -> s -> t -over l f s = runIdentity (l (\x -> Identity (f x)) s) - -------------------------------------------------------------------------------- --- Fold -------------------------------------------------------------------------------- - -toDListOf :: Getting (DList.DList a) s a -> s -> DList.DList a -toDListOf l s = getConst (l (\x -> Const (DList.singleton x)) s) - -toListOf :: Getting (DList.DList a) s a -> s -> [a] -toListOf l = DList.runDList . toDListOf l - -toSetOf :: Getting (Set.Set a) s a -> s -> Set.Set a -toSetOf l s = getConst (l (\x -> Const (Set.singleton x)) s) - -------------------------------------------------------------------------------- --- Lens -------------------------------------------------------------------------------- - -aview :: ALens s t a b -> s -> a -aview l = pretextPos . l pretextSell -{-# INLINE aview #-} - -{- -lens :: (s -> a) -> (s -> a -> s) -> Lens' s a -lens sa sbt afb s = sbt s <$> afb (sa s) --} - -------------------------------------------------------------------------------- --- Common -------------------------------------------------------------------------------- - -_1 :: Lens (a, c) (b, c) a b -_1 f (a, c) = flip (,) c <$> f a - -_2 :: Lens (c, a) (c, b) a b -_2 f (c, a) = (,) c <$> f a - -------------------------------------------------------------------------------- --- Operators -------------------------------------------------------------------------------- - --- | '&' is a reverse application operator -(&) :: a -> (a -> b) -> b -(&) = flip ($) -{-# INLINE (&) #-} -infixl 1 & - -infixl 8 ^., ^# -infixr 4 .~, %~, ?~ -infixr 4 #~, #%~ -infixr 4 .=, %=, ?= - -(^.) :: s -> Getting a s a -> a -s ^. l = getConst (l Const s) -{-# INLINE (^.) #-} - -(.~) :: ASetter s t a b -> b -> s -> t -(.~) = set -{-# INLINE (.~) #-} - -(?~) :: ASetter s t a (Maybe b) -> b -> s -> t -l ?~ b = set l (Just b) -{-# INLINE (?~) #-} - -(%~) :: ASetter s t a b -> (a -> b) -> s -> t -(%~) = over -{-# INLINE (%~) #-} - -(.=) :: MonadState s m => ASetter s s a b -> b -> m () -l .= b = modify (l .~ b) -{-# INLINE (.=) #-} - -(?=) :: MonadState s m => ASetter s s a (Maybe b) -> b -> m () -l ?= b = modify (l ?~ b) -{-# INLINE (?=) #-} - -(%=) :: MonadState s m => ASetter s s a b -> (a -> b) -> m () -l %= f = modify (l %~ f) -{-# INLINE (%=) #-} - -(^#) :: s -> ALens s t a b -> a -s ^# l = aview l s - -(#~) :: ALens s t a b -> b -> s -> t -(#~) l b s = pretextPeek b (l pretextSell s) -{-# INLINE (#~) #-} - -(#%~) :: ALens s t a b -> (a -> b) -> s -> t -(#%~) l f s = pretextPeeks f (l pretextSell s) -{-# INLINE (#%~) #-} - -pretextSell :: a -> Pretext a b b -pretextSell a = Pretext (\afb -> afb a) -{-# INLINE pretextSell #-} - -pretextPeeks :: (a -> b) -> Pretext a b t -> t -pretextPeeks f (Pretext m) = runIdentity $ m (\x -> Identity (f x)) -{-# INLINE pretextPeeks #-} - -pretextPeek :: b -> Pretext a b t -> t -pretextPeek b (Pretext m) = runIdentity $ m (\_ -> Identity b) -{-# INLINE pretextPeek #-} - -pretextPos :: Pretext a b t -> a -pretextPos (Pretext m) = getConst (m Const) -{-# INLINE pretextPos #-} - -cloneLens :: Functor f => ALens s t a b -> LensLike f s t a b -cloneLens l f s = runPretext (l pretextSell s) f -{-# INLINE cloneLens #-} - -------------------------------------------------------------------------------- --- Comonads -------------------------------------------------------------------------------- - --- | @lens@ variant is also parametrised by profunctor. -data Pretext a b t = Pretext { runPretext :: forall f. Functor f => (a -> f b) -> f t } - -instance Functor (Pretext a b) where - fmap f (Pretext pretext) = Pretext (\afb -> fmap f (pretext afb)) - -------------------------------------------------------------------------------- --- Documentation -------------------------------------------------------------------------------- - --- $development --- --- We cannot depend on @template-haskell@, because Cabal is a boot library. --- This fact makes defining optics a manual task. Here is a small recipe to --- make the process less tedious. --- --- First start a repl --- --- > cabal new-repl Cabal:hackage-tests --- --- Because @--extra-package@ isn't yet implemented, we use a test-suite --- with @generics-sop@ dependency. --- --- In the repl, we load a helper script: --- --- > :l ../generics-sop-lens.hs --- --- Now we are set up to derive lenses! --- --- > :m +Distribution.Types.SourceRepo --- > putStr $ genericLenses (Proxy :: Proxy SourceRepo) --- --- @ --- repoKind :: Lens' SourceRepo RepoKind --- repoKind f s = fmap (\\x -> s { T.repoKind = x }) (f (T.repoKind s)) --- \{-# INLINE repoKind #-\} --- ... --- @ --- --- /Note:/ You may need to adjust type-aliases, e.g. `String` to `FilePath`. diff --git a/src/Distribution/Compat/MonadFail.hs b/src/Distribution/Compat/MonadFail.hs deleted file mode 100644 --- a/src/Distribution/Compat/MonadFail.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-# LANGUAGE CPP #-} - --- | Compatibility layer for "Control.Monad.Fail" -module Distribution.Compat.MonadFail ( Control.Monad.Fail.MonadFail(fail) ) where -import Control.Monad.Fail diff --git a/src/Distribution/Compat/Newtype.hs b/src/Distribution/Compat/Newtype.hs deleted file mode 100644 --- a/src/Distribution/Compat/Newtype.hs +++ /dev/null @@ -1,91 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} --- | Per Conor McBride, the 'Newtype' typeclass represents the packing and --- unpacking of a newtype, and allows you to operatate under that newtype with --- functions such as 'ala'. -module Distribution.Compat.Newtype ( - Newtype (..), - ala, - alaf, - pack', - unpack', - ) where - -import Data.Functor.Identity (Identity (..)) -import Data.Monoid (Sum (..), Product (..), Endo (..)) - -#if MIN_VERSION_base(4,7,0) -import Data.Coerce (coerce, Coercible) -#else -import Unsafe.Coerce (unsafeCoerce) -#endif - --- | The @FunctionalDependencies@ version of 'Newtype' type-class. --- --- Since Cabal-3.0 class arguments are in a different order than in @newtype@ package. --- This change is to allow usage with @DeriveAnyClass@ (and @DerivingStrategies@, in GHC-8.2). --- Unfortunately one has to repeat inner type. --- --- @ --- newtype New = New Old --- deriving anyclass (Newtype Old) --- @ --- --- Another approach would be to use @TypeFamilies@ (and possibly --- compute inner type using "GHC.Generics"), but we think @FunctionalDependencies@ --- version gives cleaner type signatures. --- -class Newtype o n | n -> o where - pack :: o -> n -#if MIN_VERSION_base(4,7,0) - default pack :: Coercible o n => o -> n - pack = coerce -#else - default pack :: o -> n - pack = unsafeCoerce -#endif - - unpack :: n -> o -#if MIN_VERSION_base(4,7,0) - default unpack :: Coercible n o => n -> o - unpack = coerce -#else - default unpack :: n -> o - unpack = unsafeCoerce -#endif - -instance Newtype a (Identity a) -instance Newtype a (Sum a) -instance Newtype a (Product a) -instance Newtype (a -> a) (Endo a) - --- | --- --- >>> ala Sum foldMap [1, 2, 3, 4 :: Int] --- 10 --- --- /Note:/ the user supplied function for the newtype is /ignored/. --- --- >>> ala (Sum . (+1)) foldMap [1, 2, 3, 4 :: Int] --- 10 -ala :: (Newtype o n, Newtype o' n') => (o -> n) -> ((o -> n) -> b -> n') -> (b -> o') -ala pa hof = alaf pa hof id - --- | --- --- >>> alaf Sum foldMap length ["cabal", "install"] --- 12 --- --- /Note:/ as with 'ala', the user supplied function for the newtype is /ignored/. -alaf :: (Newtype o n, Newtype o' n') => (o -> n) -> ((a -> n) -> b -> n') -> (a -> o) -> (b -> o') -alaf _ hof f = unpack . hof (pack . f) - --- | Variant of 'pack', which takes a phantom type. -pack' :: Newtype o n => (o -> n) -> o -> n -pack' _ = pack - --- | Variant of 'unpack', which takes a phantom type. -unpack' :: Newtype o n => (o -> n) -> n -> o -unpack' _ = unpack diff --git a/src/Distribution/Compat/NonEmptySet.hs b/src/Distribution/Compat/NonEmptySet.hs deleted file mode 100644 --- a/src/Distribution/Compat/NonEmptySet.hs +++ /dev/null @@ -1,155 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -module Distribution.Compat.NonEmptySet ( - NonEmptySet, - -- * Construction - singleton, - -- * Insertion - insert, - -- * Deletion - delete, - -- * Conversions - toNonEmpty, - fromNonEmpty, - toList, - toSet, - -- * Query - member, - -- * Map - map, -) where - -import Prelude (Bool (..), Eq, Maybe (..), Ord (..), Read, Show (..), String, error, otherwise, return, showParen, showString, ($), (++), (.)) - -import Control.DeepSeq (NFData (..)) -import Data.Data (Data) -import Data.List.NonEmpty (NonEmpty (..)) -import Data.Semigroup (Semigroup (..)) -import Data.Typeable (Typeable) - -import qualified Data.Foldable as F -import qualified Data.Set as Set - -import Distribution.Compat.Binary (Binary (..)) -import Distribution.Utils.Structured - -#if MIN_VERSION_binary(0,6,0) -import Control.Applicative (empty) -#else -import Control.Monad (fail) -#endif - --- | @since 3.4.0.0 -newtype NonEmptySet a = NES (Set.Set a) - deriving (Eq, Ord, Typeable, Data, Read) - -------------------------------------------------------------------------------- --- Instances -------------------------------------------------------------------------------- - -instance Show a => Show (NonEmptySet a) where - showsPrec d s = showParen (d > 10) - $ showString "fromNonEmpty " - . showsPrec 11 (toNonEmpty s) - -instance Binary a => Binary (NonEmptySet a) where - put (NES s) = put s - get = do - xs <- get - if Set.null xs -#if MIN_VERSION_binary(0,6,0) - then empty -#else - then fail "NonEmptySet: empty" -#endif - else return (NES xs) - -instance Structured a => Structured (NonEmptySet a) where - structure = containerStructure - -instance NFData a => NFData (NonEmptySet a) where - rnf (NES x) = rnf x - --- | Note: there aren't @Monoid@ instance. -instance Ord a => Semigroup (NonEmptySet a) where - NES x <> NES y = NES (Set.union x y) - -instance F.Foldable NonEmptySet where - foldMap f (NES s) = F.foldMap f s - foldr f z (NES s) = F.foldr f z s - -#if MIN_VERSION_base(4,8,0) - toList = toList - null _ = False - length (NES s) = F.length s -#endif - -------------------------------------------------------------------------------- --- Constructors -------------------------------------------------------------------------------- - -singleton :: a -> NonEmptySet a -singleton = NES . Set.singleton - -------------------------------------------------------------------------------- --- Insertion -------------------------------------------------------------------------------- - -insert :: Ord a => a -> NonEmptySet a -> NonEmptySet a -insert x (NES xs) = NES (Set.insert x xs) - -------------------------------------------------------------------------------- --- Deletion -------------------------------------------------------------------------------- - -delete :: Ord a => a -> NonEmptySet a -> Maybe (NonEmptySet a) -delete x (NES xs) - | Set.null res = Nothing - | otherwise = Just (NES xs) - where - res = Set.delete x xs - -------------------------------------------------------------------------------- --- Conversions -------------------------------------------------------------------------------- - -fromNonEmpty :: Ord a => NonEmpty a -> NonEmptySet a -fromNonEmpty (x :| xs) = NES (Set.fromList (x : xs)) - -toNonEmpty :: NonEmptySet a -> NonEmpty a -toNonEmpty (NES s) = case Set.toList s of - [] -> panic "toNonEmpty" - x:xs -> x :| xs - -toList :: NonEmptySet a -> [a] -toList (NES s) = Set.toList s - -toSet :: NonEmptySet a -> Set.Set a -toSet (NES s) = s - -------------------------------------------------------------------------------- --- Query -------------------------------------------------------------------------------- - -member :: Ord a => a -> NonEmptySet a -> Bool -member x (NES xs) = Set.member x xs - -------------------------------------------------------------------------------- --- Map -------------------------------------------------------------------------------- - -map - :: ( Ord b -#if !MIN_VERSION_containers(0,5,2) - , Ord a -#endif - ) - => (a -> b) -> NonEmptySet a -> NonEmptySet b -map f (NES x) = NES (Set.map f x) - -------------------------------------------------------------------------------- --- Internal -------------------------------------------------------------------------------- - -panic :: String -> a -panic msg = error $ "NonEmptySet invariant violated: " ++ msg diff --git a/src/Distribution/Compat/Parsing.hs b/src/Distribution/Compat/Parsing.hs deleted file mode 100644 --- a/src/Distribution/Compat/Parsing.hs +++ /dev/null @@ -1,362 +0,0 @@ -{-# LANGUAGE GADTs, UndecidableInstances #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Compat.Parsing --- Copyright : (c) Edward Kmett 2011-2012 --- License : BSD3 --- --- Maintainer : ekmett@gmail.com --- Stability : experimental --- Portability : non-portable --- --- Alternative parser combinators. --- --- Originally in @parsers@ package. --- ------------------------------------------------------------------------------ -module Distribution.Compat.Parsing - ( - -- * Parsing Combinators - choice - , option - , optional -- from Control.Applicative, parsec optionMaybe - , skipOptional -- parsec optional - , between - , some -- from Control.Applicative, parsec many1 - , many -- from Control.Applicative - , sepBy - , sepByNonEmpty - , sepEndByNonEmpty - , sepEndBy - , endByNonEmpty - , endBy - , count - , chainl - , chainr - , chainl1 - , chainr1 - , manyTill - -- * Parsing Class - , Parsing(..) - ) where - -import Prelude () -import Distribution.Compat.Prelude - -import Control.Applicative ((<**>), optional) -import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.State.Lazy as Lazy -import Control.Monad.Trans.State.Strict as Strict -import Control.Monad.Trans.Writer.Lazy as Lazy -import Control.Monad.Trans.Writer.Strict as Strict -import Control.Monad.Trans.RWS.Lazy as Lazy -import Control.Monad.Trans.RWS.Strict as Strict -import Control.Monad.Trans.Reader (ReaderT (..)) -import Control.Monad.Trans.Identity (IdentityT (..)) -import Data.Foldable (asum) - -import qualified Data.List.NonEmpty as NE -import qualified Text.Parsec as Parsec - --- | @choice ps@ tries to apply the parsers in the list @ps@ in order, --- until one of them succeeds. Returns the value of the succeeding --- parser. -choice :: Alternative m => [m a] -> m a -choice = asum -{-# INLINE choice #-} - --- | @option x p@ tries to apply parser @p@. If @p@ fails without --- consuming input, it returns the value @x@, otherwise the value --- returned by @p@. --- --- > priority = option 0 (digitToInt <$> digit) -option :: Alternative m => a -> m a -> m a -option x p = p <|> pure x -{-# INLINE option #-} - --- | @skipOptional p@ tries to apply parser @p@. It will parse @p@ or nothing. --- It only fails if @p@ fails after consuming input. It discards the result --- of @p@. (Plays the role of parsec's optional, which conflicts with Applicative's optional) -skipOptional :: Alternative m => m a -> m () -skipOptional p = (() <$ p) <|> pure () -{-# INLINE skipOptional #-} - --- | @between open close p@ parses @open@, followed by @p@ and @close@. --- Returns the value returned by @p@. --- --- > braces = between (symbol "{") (symbol "}") -between :: Applicative m => m bra -> m ket -> m a -> m a -between bra ket p = bra *> p <* ket -{-# INLINE between #-} - --- | @sepBy p sep@ parses /zero/ or more occurrences of @p@, separated --- by @sep@. Returns a list of values returned by @p@. --- --- > commaSep p = p `sepBy` (symbol ",") -sepBy :: Alternative m => m a -> m sep -> m [a] -sepBy p sep = toList <$> sepByNonEmpty p sep <|> pure [] -{-# INLINE sepBy #-} - --- | @sepByNonEmpty p sep@ parses /one/ or more occurrences of @p@, separated --- by @sep@. Returns a non-empty list of values returned by @p@. -sepByNonEmpty :: Alternative m => m a -> m sep -> m (NonEmpty a) -sepByNonEmpty p sep = (:|) <$> p <*> many (sep *> p) -{-# INLINE sepByNonEmpty #-} - --- | @sepEndByNonEmpty p sep@ parses /one/ or more occurrences of @p@, --- separated and optionally ended by @sep@. Returns a non-empty list of values --- returned by @p@. -sepEndByNonEmpty :: Alternative m => m a -> m sep -> m (NonEmpty a) -sepEndByNonEmpty p sep = (:|) <$> p <*> ((sep *> sepEndBy p sep) <|> pure []) - --- | @sepEndBy p sep@ parses /zero/ or more occurrences of @p@, --- separated and optionally ended by @sep@, ie. haskell style --- statements. Returns a list of values returned by @p@. --- --- > haskellStatements = haskellStatement `sepEndBy` semi -sepEndBy :: Alternative m => m a -> m sep -> m [a] -sepEndBy p sep = toList <$> sepEndByNonEmpty p sep <|> pure [] -{-# INLINE sepEndBy #-} - --- | @endByNonEmpty p sep@ parses /one/ or more occurrences of @p@, separated --- and ended by @sep@. Returns a non-empty list of values returned by @p@. -endByNonEmpty :: Alternative m => m a -> m sep -> m (NonEmpty a) -endByNonEmpty p sep = NE.some1 (p <* sep) -{-# INLINE endByNonEmpty #-} - --- | @endBy p sep@ parses /zero/ or more occurrences of @p@, separated --- and ended by @sep@. Returns a list of values returned by @p@. --- --- > cStatements = cStatement `endBy` semi -endBy :: Alternative m => m a -> m sep -> m [a] -endBy p sep = many (p <* sep) -{-# INLINE endBy #-} - --- | @count n p@ parses @n@ occurrences of @p@. If @n@ is smaller or --- equal to zero, the parser equals to @return []@. Returns a list of --- @n@ values returned by @p@. -count :: Applicative m => Int -> m a -> m [a] -count n p | n <= 0 = pure [] - | otherwise = sequenceA (replicate n p) -{-# INLINE count #-} - --- | @chainr p op x@ parses /zero/ or more occurrences of @p@, --- separated by @op@ Returns a value obtained by a /right/ associative --- application of all functions returned by @op@ to the values returned --- by @p@. If there are no occurrences of @p@, the value @x@ is --- returned. -chainr :: Alternative m => m a -> m (a -> a -> a) -> a -> m a -chainr p op x = chainr1 p op <|> pure x -{-# INLINE chainr #-} - --- | @chainl p op x@ parses /zero/ or more occurrences of @p@, --- separated by @op@. Returns a value obtained by a /left/ associative --- application of all functions returned by @op@ to the values returned --- by @p@. If there are zero occurrences of @p@, the value @x@ is --- returned. -chainl :: Alternative m => m a -> m (a -> a -> a) -> a -> m a -chainl p op x = chainl1 p op <|> pure x -{-# INLINE chainl #-} - --- | @chainl1 p op x@ parses /one/ or more occurrences of @p@, --- separated by @op@ Returns a value obtained by a /left/ associative --- application of all functions returned by @op@ to the values returned --- by @p@. . This parser can for example be used to eliminate left --- recursion which typically occurs in expression grammars. --- --- > expr = term `chainl1` addop --- > term = factor `chainl1` mulop --- > factor = parens expr <|> integer --- > --- > mulop = (*) <$ symbol "*" --- > <|> div <$ symbol "/" --- > --- > addop = (+) <$ symbol "+" --- > <|> (-) <$ symbol "-" -chainl1 :: Alternative m => m a -> m (a -> a -> a) -> m a -chainl1 p op = scan where - scan = p <**> rst - rst = (\f y g x -> g (f x y)) <$> op <*> p <*> rst <|> pure id -{-# INLINE chainl1 #-} - --- | @chainr1 p op x@ parses /one/ or more occurrences of @p@, --- separated by @op@ Returns a value obtained by a /right/ associative --- application of all functions returned by @op@ to the values returned --- by @p@. -chainr1 :: Alternative m => m a -> m (a -> a -> a) -> m a -chainr1 p op = scan where - scan = p <**> rst - rst = (flip <$> op <*> scan) <|> pure id -{-# INLINE chainr1 #-} - --- | @manyTill p end@ applies parser @p@ /zero/ or more times until --- parser @end@ succeeds. Returns the list of values returned by @p@. --- This parser can be used to scan comments: --- --- > simpleComment = do{ string "")) --- > } --- --- Note the overlapping parsers @anyChar@ and @string \"-->\"@, and --- therefore the use of the 'try' combinator. -manyTill :: Alternative m => m a -> m end -> m [a] -manyTill p end = go where go = ([] <$ end) <|> ((:) <$> p <*> go) -{-# INLINE manyTill #-} - -infixr 0 - --- | Additional functionality needed to describe parsers independent of input type. -class Alternative m => Parsing m where - -- | Take a parser that may consume input, and on failure, go back to - -- where we started and fail as if we didn't consume input. - try :: m a -> m a - - -- | Give a parser a name - () :: m a -> String -> m a - - -- | A version of many that discards its input. Specialized because it - -- can often be implemented more cheaply. - skipMany :: m a -> m () - skipMany p = () <$ many p - {-# INLINE skipMany #-} - - -- | @skipSome p@ applies the parser @p@ /one/ or more times, skipping - -- its result. (aka skipMany1 in parsec) - skipSome :: m a -> m () - skipSome p = p *> skipMany p - {-# INLINE skipSome #-} - - -- | Used to emit an error on an unexpected token - unexpected :: String -> m a - - -- | This parser only succeeds at the end of the input. This is not a - -- primitive parser but it is defined using 'notFollowedBy'. - -- - -- > eof = notFollowedBy anyChar "end of input" - eof :: m () - - -- | @notFollowedBy p@ only succeeds when parser @p@ fails. This parser - -- does not consume any input. This parser can be used to implement the - -- \'longest match\' rule. For example, when recognizing keywords (for - -- example @let@), we want to make sure that a keyword is not followed - -- by a legal identifier character, in which case the keyword is - -- actually an identifier (for example @lets@). We can program this - -- behaviour as follows: - -- - -- > keywordLet = try $ string "let" <* notFollowedBy alphaNum - notFollowedBy :: Show a => m a -> m () - -instance (Parsing m, MonadPlus m) => Parsing (Lazy.StateT s m) where - try (Lazy.StateT m) = Lazy.StateT $ try . m - {-# INLINE try #-} - Lazy.StateT m l = Lazy.StateT $ \s -> m s l - {-# INLINE () #-} - unexpected = lift . unexpected - {-# INLINE unexpected #-} - eof = lift eof - {-# INLINE eof #-} - notFollowedBy (Lazy.StateT m) = Lazy.StateT - $ \s -> notFollowedBy (fst <$> m s) >> return ((),s) - {-# INLINE notFollowedBy #-} - -instance (Parsing m, MonadPlus m) => Parsing (Strict.StateT s m) where - try (Strict.StateT m) = Strict.StateT $ try . m - {-# INLINE try #-} - Strict.StateT m l = Strict.StateT $ \s -> m s l - {-# INLINE () #-} - unexpected = lift . unexpected - {-# INLINE unexpected #-} - eof = lift eof - {-# INLINE eof #-} - notFollowedBy (Strict.StateT m) = Strict.StateT - $ \s -> notFollowedBy (fst <$> m s) >> return ((),s) - {-# INLINE notFollowedBy #-} - -instance (Parsing m, MonadPlus m) => Parsing (ReaderT e m) where - try (ReaderT m) = ReaderT $ try . m - {-# INLINE try #-} - ReaderT m l = ReaderT $ \e -> m e l - {-# INLINE () #-} - skipMany (ReaderT m) = ReaderT $ skipMany . m - {-# INLINE skipMany #-} - unexpected = lift . unexpected - {-# INLINE unexpected #-} - eof = lift eof - {-# INLINE eof #-} - notFollowedBy (ReaderT m) = ReaderT $ notFollowedBy . m - {-# INLINE notFollowedBy #-} - -instance (Parsing m, MonadPlus m, Monoid w) => Parsing (Strict.WriterT w m) where - try (Strict.WriterT m) = Strict.WriterT $ try m - {-# INLINE try #-} - Strict.WriterT m l = Strict.WriterT (m l) - {-# INLINE () #-} - unexpected = lift . unexpected - {-# INLINE unexpected #-} - eof = lift eof - {-# INLINE eof #-} - notFollowedBy (Strict.WriterT m) = Strict.WriterT - $ notFollowedBy (fst <$> m) >>= \x -> return (x, mempty) - {-# INLINE notFollowedBy #-} - -instance (Parsing m, MonadPlus m, Monoid w) => Parsing (Lazy.WriterT w m) where - try (Lazy.WriterT m) = Lazy.WriterT $ try m - {-# INLINE try #-} - Lazy.WriterT m l = Lazy.WriterT (m l) - {-# INLINE () #-} - unexpected = lift . unexpected - {-# INLINE unexpected #-} - eof = lift eof - {-# INLINE eof #-} - notFollowedBy (Lazy.WriterT m) = Lazy.WriterT - $ notFollowedBy (fst <$> m) >>= \x -> return (x, mempty) - {-# INLINE notFollowedBy #-} - -instance (Parsing m, MonadPlus m, Monoid w) => Parsing (Lazy.RWST r w s m) where - try (Lazy.RWST m) = Lazy.RWST $ \r s -> try (m r s) - {-# INLINE try #-} - Lazy.RWST m l = Lazy.RWST $ \r s -> m r s l - {-# INLINE () #-} - unexpected = lift . unexpected - {-# INLINE unexpected #-} - eof = lift eof - {-# INLINE eof #-} - notFollowedBy (Lazy.RWST m) = Lazy.RWST - $ \r s -> notFollowedBy ((\(a,_,_) -> a) <$> m r s) >>= \x -> return (x, s, mempty) - {-# INLINE notFollowedBy #-} - -instance (Parsing m, MonadPlus m, Monoid w) => Parsing (Strict.RWST r w s m) where - try (Strict.RWST m) = Strict.RWST $ \r s -> try (m r s) - {-# INLINE try #-} - Strict.RWST m l = Strict.RWST $ \r s -> m r s l - {-# INLINE () #-} - unexpected = lift . unexpected - {-# INLINE unexpected #-} - eof = lift eof - {-# INLINE eof #-} - notFollowedBy (Strict.RWST m) = Strict.RWST - $ \r s -> notFollowedBy ((\(a,_,_) -> a) <$> m r s) >>= \x -> return (x, s, mempty) - {-# INLINE notFollowedBy #-} - -instance (Parsing m, Monad m) => Parsing (IdentityT m) where - try = IdentityT . try . runIdentityT - {-# INLINE try #-} - IdentityT m l = IdentityT (m l) - {-# INLINE () #-} - skipMany = IdentityT . skipMany . runIdentityT - {-# INLINE skipMany #-} - unexpected = lift . unexpected - {-# INLINE unexpected #-} - eof = lift eof - {-# INLINE eof #-} - notFollowedBy (IdentityT m) = IdentityT $ notFollowedBy m - {-# INLINE notFollowedBy #-} - -instance (Parsec.Stream s m t, Show t) => Parsing (Parsec.ParsecT s u m) where - try = Parsec.try - () = (Parsec.) - skipMany = Parsec.skipMany - skipSome = Parsec.skipMany1 - unexpected = Parsec.unexpected - eof = Parsec.eof - notFollowedBy = Parsec.notFollowedBy diff --git a/src/Distribution/Compat/Prelude.hs b/src/Distribution/Compat/Prelude.hs deleted file mode 100644 --- a/src/Distribution/Compat/Prelude.hs +++ /dev/null @@ -1,316 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE TypeOperators #-} - -#ifdef MIN_VERSION_base -#define MINVER_base_411 MIN_VERSION_base(4,11,0) -#define MINVER_base_48 MIN_VERSION_base(4,8,0) -#define MINVER_base_47 MIN_VERSION_base(4,7,0) -#else -#define MINVER_base_411 (__GLASGOW_HASKELL__ >= 804) -#define MINVER_base_48 (__GLASGOW_HASKELL__ >= 710) -#define MINVER_base_47 (__GLASGOW_HASKELL__ >= 708) -#endif - --- | This module does two things: --- --- * Acts as a compatibility layer, like @base-compat@. --- --- * Provides commonly used imports. -module Distribution.Compat.Prelude ( - -- * Prelude - -- - -- Prelude is re-exported, following is hidden: - module BasePrelude, - -#if !MINVER_base_48 - -- * base 4.8 shim - Applicative(..), (<$), (<$>), - Monoid(..), -#endif - - -- * Common type-classes - Semigroup (..), - gmappend, gmempty, - Typeable, TypeRep, typeRep, - Data, - Generic, - NFData (..), genericRnf, - Binary (..), - Structured, - Alternative (..), - MonadPlus (..), - IsString (..), - - -- * Some types - Map, - Set, - NonEmptySet, - Identity (..), - Proxy (..), - Const (..), - Void, - - -- * Data.Either - partitionEithers, - - -- * Data.Maybe - catMaybes, mapMaybe, - fromMaybe, - maybeToList, listToMaybe, - isNothing, isJust, - - -- * Data.List - unfoldr, - isPrefixOf, isSuffixOf, - intercalate, intersperse, - sort, sortBy, - nub, nubBy, - partition, - - -- * Data.List.NonEmpty - NonEmpty((:|)), nonEmpty, foldl1, foldr1, - head, tail, last, init, - - -- * Data.Foldable - Foldable, foldMap, foldr, - null, length, - find, foldl', - traverse_, for_, - any, all, - toList, - - -- * Data.Traversable - Traversable, traverse, sequenceA, - for, - - -- * Data.Function - on, - - -- * Data.Ord - comparing, - - -- * Control.Arrow - first, - - -- * Control.Monad - liftM, liftM2, - unless, when, - ap, void, - foldM, filterM, - join, guard, - - -- * Control.Exception - catch, throwIO, evaluate, - Exception (..), IOException, SomeException (..), -#if !MINVER_base_48 - displayException, -#endif - tryIO, catchIO, catchExit, - - -- * Control.DeepSeq - deepseq, force, - - -- * Data.Char - isSpace, isDigit, isUpper, isAlpha, isAlphaNum, - chr, ord, - toLower, toUpper, - - -- * Data.Void - absurd, vacuous, - - -- * Data.Word & Data.Int - Word, - Word8, Word16, Word32, Word64, - Int8, Int16, Int32, Int64, - - -- * Text.PrettyPrint - (<<>>), (Disp.<+>), - - -- * System.Exit - ExitCode (..), - exitWith, exitSuccess, exitFailure, - - -- * Text.Read - readMaybe, - - -- * Debug.Trace (as deprecated functions) - trace, traceShow, traceShowId, - ) where - --- We also could hide few partial function -import Prelude as BasePrelude hiding - ( mapM, mapM_, sequence, null, length, foldr, any, all, head, tail, last, init - -- partial functions - , read - , foldr1, foldl1 -#if MINVER_base_411 - -- As of base 4.11.0.0 Prelude exports part of Semigroup(..). - -- Hide this so we instead rely on Distribution.Compat.Semigroup. - , Semigroup(..) -#endif -#if MINVER_base_48 - , Word - -- We hide them, as we import only some members - , Traversable, traverse, sequenceA - , Foldable, foldMap -#endif - ) - --- AMP -#if !MINVER_base_48 -import Control.Applicative (Applicative (..), (<$), (<$>)) -import Data.Foldable (toList) -import Distribution.Compat.Semigroup (Monoid (..)) -#else -import Data.Foldable (Foldable (toList), length, null) -#endif - -import Data.Foldable (Foldable (foldMap, foldr), all, any, find, foldl', for_, traverse_) -import Data.Traversable (Traversable (sequenceA, traverse), for) - -import qualified Data.Foldable - --- Extra exports -import Control.Applicative (Alternative (..)) -import Control.Applicative (Const (..)) -import Control.Arrow (first) -import Control.DeepSeq (NFData (..), deepseq, force) -import Control.Exception (Exception (..), IOException, SomeException (..), catch, evaluate, throwIO) -import Control.Monad (MonadPlus (..), ap, filterM, foldM, guard, join, liftM, liftM2, unless, void, when) -import Data.Char (chr, isAlpha, isAlphaNum, isDigit, isSpace, isUpper, ord, toLower, toUpper) -import Data.Data (Data) -import Data.Either (partitionEithers) -import Data.Function (on) -import Data.Functor.Identity (Identity (..)) -import Data.Int (Int16, Int32, Int64, Int8) -import Data.List (intercalate, intersperse, isPrefixOf, isSuffixOf, nub, nubBy, partition, sort, sortBy, unfoldr) -import Data.List.NonEmpty (NonEmpty ((:|)), nonEmpty, head, init, last, tail) -import Data.Map (Map) -import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing, listToMaybe, mapMaybe, maybeToList) -import Data.Ord (comparing) -import Data.Proxy (Proxy (..)) -import Data.Set (Set) -import Data.String (IsString (..)) -import Data.Void (Void, absurd, vacuous) -import Data.Word (Word, Word16, Word32, Word64, Word8) -import Distribution.Compat.Binary (Binary (..)) -import Distribution.Compat.Semigroup (Semigroup (..), gmappend, gmempty) -import Distribution.Compat.Typeable (TypeRep, Typeable, typeRep) -import GHC.Generics ((:*:) ((:*:)), (:+:) (L1, R1), Generic, K1 (unK1), M1 (unM1), Rep (..), U1 (U1), V1) -import System.Exit (ExitCode (..), exitFailure, exitSuccess, exitWith) -import Text.Read (readMaybe) - -import qualified Text.PrettyPrint as Disp - -import Distribution.Compat.Exception -import Distribution.Compat.NonEmptySet (NonEmptySet) -import Distribution.Utils.Structured (Structured) - -import qualified Debug.Trace - --- | New name for 'Text.PrettyPrint.<>' -(<<>>) :: Disp.Doc -> Disp.Doc -> Disp.Doc -(<<>>) = (Disp.<>) - -#if !MINVER_base_48 --- | Test whether the structure is empty. The default implementation is --- optimized for structures that are similar to cons-lists, because there --- is no general way to do better. -null :: Foldable t => t a -> Bool -null = foldr (\_ _ -> False) True - --- | Returns the size/length of a finite structure as an 'Int'. The --- default implementation is optimized for structures that are similar to --- cons-lists, because there is no general way to do better. -length :: Foldable t => t a -> Int -length = foldl' (\c _ -> c+1) 0 -#endif - - --- | "GHC.Generics"-based 'rnf' implementation --- --- This is needed in order to support @deepseq < 1.4@ which didn't --- have a 'Generic'-based default 'rnf' implementation yet. --- --- In order to define instances, use e.g. --- --- > instance NFData MyType where rnf = genericRnf --- --- The implementation has been taken from @deepseq-1.4.2@'s default --- 'rnf' implementation. -genericRnf :: (Generic a, GNFData (Rep a)) => a -> () -genericRnf = grnf . from - --- | Hidden internal type-class -class GNFData f where - grnf :: f a -> () - -instance GNFData V1 where - grnf = error "Control.DeepSeq.rnf: uninhabited type" - -instance GNFData U1 where - grnf U1 = () - -instance NFData a => GNFData (K1 i a) where - grnf = rnf . unK1 - {-# INLINEABLE grnf #-} - -instance GNFData a => GNFData (M1 i c a) where - grnf = grnf . unM1 - {-# INLINEABLE grnf #-} - -instance (GNFData a, GNFData b) => GNFData (a :*: b) where - grnf (x :*: y) = grnf x `seq` grnf y - {-# INLINEABLE grnf #-} - -instance (GNFData a, GNFData b) => GNFData (a :+: b) where - grnf (L1 x) = grnf x - grnf (R1 x) = grnf x - {-# INLINEABLE grnf #-} - - --- TODO: if we want foldr1/foldl1 to work on more than NonEmpty, we --- can define a local typeclass 'Foldable1', e.g. --- --- @ --- class Foldable f => Foldable1 f --- --- instance Foldable1 NonEmpty --- --- foldr1 :: Foldable1 t => (a -> a -> a) -> t a -> a --- foldr1 = Data.Foldable.foldr1 --- --- foldl1 :: Foldable1 t => (a -> a -> a) -> t a -> a --- foldl1 = Data.Foldable.foldl1 --- @ --- - -{-# INLINE foldr1 #-} -foldr1 :: (a -> a -> a) -> NonEmpty a -> a -foldr1 = Data.Foldable.foldr1 - -{-# INLINE foldl1 #-} -foldl1 :: (a -> a -> a) -> NonEmpty a -> a -foldl1 = Data.Foldable.foldl1 - -------------------------------------------------------------------------------- --- Trace -------------------------------------------------------------------------------- - --- Functions from Debug.Trace --- but with DEPRECATED pragma, so -Werror will scream on them. - -trace :: String -> a -> a -trace = Debug.Trace.trace -{-# DEPRECATED trace "Don't leave me in the code" #-} - -traceShowId :: Show a => a -> a -traceShowId x = Debug.Trace.traceShow x x -{-# DEPRECATED traceShowId "Don't leave me in the code" #-} - -traceShow :: Show a => a -> b -> b -traceShow = Debug.Trace.traceShow -{-# DEPRECATED traceShow "Don't leave me in the code" #-} diff --git a/src/Distribution/Compat/Process.hs b/src/Distribution/Compat/Process.hs --- a/src/Distribution/Compat/Process.hs +++ b/src/Distribution/Compat/Process.hs @@ -11,13 +11,9 @@ import System.Exit (ExitCode (..)) import System.IO (Handle) -import System.Process (CreateProcess, ProcessHandle) +import System.Process (CreateProcess, ProcessHandle, waitForProcess) import qualified System.Process as Process -#if MIN_VERSION_process(1,2,0) -import System.Process (waitForProcess) -#endif - #if defined(mingw32_HOST_OS) && MIN_VERSION_process(1,6,9) import System.IO.Unsafe (unsafePerformIO) import System.Win32.Info.Version (dwMajorVersion, dwMinorVersion, getVersionEx) @@ -48,7 +44,7 @@ -- On Windows 7 or before the jobs are disabled due to the fact that -- processes on these systems can only have one job. This prevents -- spawned process from assigning jobs to its own children. Suppose --- processs A spawns process B. The B process has a job assigned (call +-- process A spawns process B. The B process has a job assigned (call -- it J1) and when it tries to spawn a new process C the C -- automatically inherits the job. But at it also tries to assign a -- new job J2 to C since it doesn’t have access J1. This fails on @@ -74,13 +70,8 @@ -- See 'enableProcessJobs'. rawSystem :: String -> [String] -> IO ExitCode rawSystem cmd args = do -#if MIN_VERSION_process(1,2,0) (_,_,_,p) <- createProcess (Process.proc cmd args) { Process.delegate_ctlc = True } waitForProcess p -#else - -- With very old 'process', just do its rawSystem - Process.rawSystem cmd args -#endif -- | 'System.Process.runInteractiveProcess' with process jobs enabled when -- appropriate. See 'enableProcessJobs'. diff --git a/src/Distribution/Compat/Semigroup.hs b/src/Distribution/Compat/Semigroup.hs deleted file mode 100644 --- a/src/Distribution/Compat/Semigroup.hs +++ /dev/null @@ -1,119 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE TypeOperators #-} - --- | Compatibility layer for "Data.Semigroup" -module Distribution.Compat.Semigroup - ( Semigroup((<>)) - , Mon.Monoid(..) - , All(..) - , Any(..) - - , First'(..) - , Last'(..) - - , Option'(..) - - , gmappend - , gmempty - ) where - -import Distribution.Compat.Binary (Binary) -import Distribution.Utils.Structured (Structured) -import Data.Typeable (Typeable) - -import GHC.Generics --- Data.Semigroup is available since GHC 8.0/base-4.9 in `base` --- for older GHC/base, it's provided by `semigroups` -import Data.Semigroup -import qualified Data.Monoid as Mon - - --- | A copy of 'Data.Semigroup.First'. -newtype First' a = First' { getFirst' :: a } - deriving (Eq, Ord, Show) - -instance Semigroup (First' a) where - a <> _ = a - --- | A copy of 'Data.Semigroup.Last'. -newtype Last' a = Last' { getLast' :: a } - deriving (Eq, Ord, Read, Show, Generic, Binary, Typeable) - -instance Structured a => Structured (Last' a) - -instance Semigroup (Last' a) where - _ <> b = b - -instance Functor Last' where - fmap f (Last' x) = Last' (f x) - --- | A wrapper around 'Maybe', providing the 'Semigroup' and 'Monoid' instances --- implemented for 'Maybe' since @base-4.11@. -newtype Option' a = Option' { getOption' :: Maybe a } - deriving (Eq, Ord, Read, Show, Binary, Generic, Functor, Typeable) - -instance Structured a => Structured (Option' a) - -instance Semigroup a => Semigroup (Option' a) where - Option' (Just a) <> Option' (Just b) = Option' (Just (a <> b)) - Option' Nothing <> b = b - a <> Option' Nothing = a - -instance Semigroup a => Monoid (Option' a) where - mempty = Option' Nothing - mappend = (<>) - -------------------------------------------------------------------------------- -------------------------------------------------------------------------------- --- Stolen from Edward Kmett's BSD3-licensed `semigroups` package - --- | Generically generate a 'Semigroup' ('<>') operation for any type --- implementing 'Generic'. This operation will append two values --- by point-wise appending their component fields. It is only defined --- for product types. --- --- @ --- 'gmappend' a ('gmappend' b c) = 'gmappend' ('gmappend' a b) c --- @ -gmappend :: (Generic a, GSemigroup (Rep a)) => a -> a -> a -gmappend x y = to (gmappend' (from x) (from y)) - -class GSemigroup f where - gmappend' :: f p -> f p -> f p - -instance Semigroup a => GSemigroup (K1 i a) where - gmappend' (K1 x) (K1 y) = K1 (x <> y) - -instance GSemigroup f => GSemigroup (M1 i c f) where - gmappend' (M1 x) (M1 y) = M1 (gmappend' x y) - -instance (GSemigroup f, GSemigroup g) => GSemigroup (f :*: g) where - gmappend' (x1 :*: x2) (y1 :*: y2) = gmappend' x1 y1 :*: gmappend' x2 y2 - --- | Generically generate a 'Monoid' 'mempty' for any product-like type --- implementing 'Generic'. --- --- It is only defined for product types. --- --- @ --- 'gmappend' 'gmempty' a = a = 'gmappend' a 'gmempty' --- @ - -gmempty :: (Generic a, GMonoid (Rep a)) => a -gmempty = to gmempty' - -class GSemigroup f => GMonoid f where - gmempty' :: f p - -instance (Semigroup a, Monoid a) => GMonoid (K1 i a) where - gmempty' = K1 mempty - -instance GMonoid f => GMonoid (M1 i c f) where - gmempty' = M1 gmempty' - -instance (GMonoid f, GMonoid g) => GMonoid (f :*: g) where - gmempty' = gmempty' :*: gmempty' diff --git a/src/Distribution/Compat/Typeable.hs b/src/Distribution/Compat/Typeable.hs deleted file mode 100644 --- a/src/Distribution/Compat/Typeable.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ScopedTypeVariables #-} -module Distribution.Compat.Typeable ( - Typeable, - TypeRep, - typeRep, - ) where - -#if MIN_VERSION_base(4,7,0) -import Data.Typeable (Typeable, TypeRep, typeRep) -#else -import Data.Typeable (Typeable, TypeRep, typeOf) -#endif - -#if !MIN_VERSION_base(4,7,0) -typeRep :: forall a proxy. Typeable a => proxy a -> TypeRep -typeRep _ = typeOf (undefined :: a) -#endif diff --git a/src/Distribution/Compiler.hs b/src/Distribution/Compiler.hs deleted file mode 100644 --- a/src/Distribution/Compiler.hs +++ /dev/null @@ -1,223 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveTraversable #-} - ------------------------------------------------------------------------------ --- | --- Module : Distribution.Compiler --- Copyright : Isaac Jones 2003-2004 --- License : BSD3 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This has an enumeration of the various compilers that Cabal knows about. It --- also specifies the default compiler. Sadly you'll often see code that does --- case analysis on this compiler flavour enumeration like: --- --- > case compilerFlavor comp of --- > GHC -> GHC.getInstalledPackages verbosity packageDb progdb --- --- Obviously it would be better to use the proper 'Compiler' abstraction --- because that would keep all the compiler-specific code together. --- Unfortunately we cannot make this change yet without breaking the --- 'UserHooks' api, which would break all custom @Setup.hs@ files, so for the --- moment we just have to live with this deficiency. If you're interested, see --- ticket #57. - -module Distribution.Compiler ( - -- * Compiler flavor - CompilerFlavor(..), - buildCompilerId, - buildCompilerFlavor, - defaultCompilerFlavor, - classifyCompilerFlavor, - knownCompilerFlavors, - - -- * Per compiler flavor - PerCompilerFlavor (..), - perCompilerFlavorToList, - - -- * Compiler id - CompilerId(..), - - -- * Compiler info - CompilerInfo(..), - unknownCompilerInfo, - AbiTag(..), abiTagString - ) where - -import Prelude () -import Distribution.Compat.Prelude - -import Language.Haskell.Extension - -import Distribution.Version (Version, mkVersion', nullVersion) - -import qualified System.Info (compilerName, compilerVersion) -import Distribution.Parsec (Parsec (..)) -import Distribution.Pretty (Pretty (..), prettyShow) -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp - -data CompilerFlavor = - GHC | GHCJS | NHC | YHC | Hugs | HBC | Helium | JHC | LHC | UHC | Eta - | HaskellSuite String -- string is the id of the actual compiler - | OtherCompiler String - deriving (Generic, Show, Read, Eq, Ord, Typeable, Data) - -instance Binary CompilerFlavor -instance Structured CompilerFlavor -instance NFData CompilerFlavor where rnf = genericRnf - -knownCompilerFlavors :: [CompilerFlavor] -knownCompilerFlavors = - [GHC, GHCJS, NHC, YHC, Hugs, HBC, Helium, JHC, LHC, UHC, Eta] - -instance Pretty CompilerFlavor where - pretty (OtherCompiler name) = Disp.text name - pretty (HaskellSuite name) = Disp.text name - pretty NHC = Disp.text "nhc98" - pretty other = Disp.text (lowercase (show other)) - -instance Parsec CompilerFlavor where - parsec = classifyCompilerFlavor <$> component - where - component = do - cs <- P.munch1 isAlphaNum - if all isDigit cs then fail "all digits compiler name" else return cs - -classifyCompilerFlavor :: String -> CompilerFlavor -classifyCompilerFlavor s = - fromMaybe (OtherCompiler s) $ lookup (lowercase s) compilerMap - where - compilerMap = [ (lowercase (prettyShow compiler), compiler) - | compiler <- knownCompilerFlavors ] - -buildCompilerFlavor :: CompilerFlavor -buildCompilerFlavor = classifyCompilerFlavor System.Info.compilerName - -buildCompilerVersion :: Version -buildCompilerVersion = mkVersion' System.Info.compilerVersion - -buildCompilerId :: CompilerId -buildCompilerId = CompilerId buildCompilerFlavor buildCompilerVersion - --- | The default compiler flavour to pick when compiling stuff. This defaults --- to the compiler used to build the Cabal lib. --- --- However if it's not a recognised compiler then it's 'Nothing' and the user --- will have to specify which compiler they want. --- -defaultCompilerFlavor :: Maybe CompilerFlavor -defaultCompilerFlavor = case buildCompilerFlavor of - OtherCompiler _ -> Nothing - _ -> Just buildCompilerFlavor - -------------------------------------------------------------------------------- --- Per compiler data -------------------------------------------------------------------------------- - --- | 'PerCompilerFlavor' carries only info per GHC and GHCJS --- --- Cabal parses only @ghc-options@ and @ghcjs-options@, others are omitted. --- -data PerCompilerFlavor v = PerCompilerFlavor v v - deriving (Generic, Show, Read, Eq, Typeable, Data, Functor, Foldable - , Traversable) - -instance Binary a => Binary (PerCompilerFlavor a) -instance Structured a => Structured (PerCompilerFlavor a) -instance NFData a => NFData (PerCompilerFlavor a) - -perCompilerFlavorToList :: PerCompilerFlavor v -> [(CompilerFlavor, v)] -perCompilerFlavorToList (PerCompilerFlavor a b) = [(GHC, a), (GHCJS, b)] - -instance Semigroup a => Semigroup (PerCompilerFlavor a) where - PerCompilerFlavor a b <> PerCompilerFlavor a' b' = PerCompilerFlavor - (a <> a') (b <> b') - -instance (Semigroup a, Monoid a) => Monoid (PerCompilerFlavor a) where - mempty = PerCompilerFlavor mempty mempty - mappend = (<>) - --- ------------------------------------------------------------ --- * Compiler Id --- ------------------------------------------------------------ - -data CompilerId = CompilerId CompilerFlavor Version - deriving (Eq, Generic, Ord, Read, Show, Typeable) - -instance Binary CompilerId -instance Structured CompilerId -instance NFData CompilerId where rnf = genericRnf - -instance Pretty CompilerId where - pretty (CompilerId f v) - | v == nullVersion = pretty f - | otherwise = pretty f <<>> Disp.char '-' <<>> pretty v - -instance Parsec CompilerId where - parsec = do - flavour <- parsec - version <- (P.char '-' >> parsec) <|> return nullVersion - return (CompilerId flavour version) - -lowercase :: String -> String -lowercase = map toLower - --- ------------------------------------------------------------ --- * Compiler Info --- ------------------------------------------------------------ - --- | Compiler information used for resolving configurations. Some --- fields can be set to Nothing to indicate that the information is --- unknown. - -data CompilerInfo = CompilerInfo { - compilerInfoId :: CompilerId, - -- ^ Compiler flavour and version. - compilerInfoAbiTag :: AbiTag, - -- ^ Tag for distinguishing incompatible ABI's on the same - -- architecture/os. - compilerInfoCompat :: Maybe [CompilerId], - -- ^ Other implementations that this compiler claims to be - -- compatible with, if known. - compilerInfoLanguages :: Maybe [Language], - -- ^ Supported language standards, if known. - compilerInfoExtensions :: Maybe [Extension] - -- ^ Supported extensions, if known. - } - deriving (Generic, Show, Read) - -instance Binary CompilerInfo - -data AbiTag - = NoAbiTag - | AbiTag String - deriving (Eq, Generic, Show, Read, Typeable) - -instance Binary AbiTag -instance Structured AbiTag - -instance Pretty AbiTag where - pretty NoAbiTag = Disp.empty - pretty (AbiTag tag) = Disp.text tag - -instance Parsec AbiTag where - parsec = do - tag <- P.munch (\c -> isAlphaNum c || c == '_') - if null tag then return NoAbiTag else return (AbiTag tag) - -abiTagString :: AbiTag -> String -abiTagString NoAbiTag = "" -abiTagString (AbiTag tag) = tag - --- | Make a CompilerInfo of which only the known information is its CompilerId, --- its AbiTag and that it does not claim to be compatible with other --- compiler id's. -unknownCompilerInfo :: CompilerId -> AbiTag -> CompilerInfo -unknownCompilerInfo compilerId abiTag = - CompilerInfo compilerId abiTag (Just []) Nothing Nothing diff --git a/src/Distribution/FieldGrammar.hs b/src/Distribution/FieldGrammar.hs deleted file mode 100644 --- a/src/Distribution/FieldGrammar.hs +++ /dev/null @@ -1,88 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} --- | This module provides a way to specify a grammar of @.cabal@ -like files. -module Distribution.FieldGrammar ( - -- * Field grammar type - FieldGrammar (..), - uniqueField, - optionalField, - optionalFieldDef, - monoidalField, - -- * Concrete grammar implementations - ParsecFieldGrammar, - ParsecFieldGrammar', - parseFieldGrammar, - fieldGrammarKnownFieldList, - PrettyFieldGrammar, - PrettyFieldGrammar', - prettyFieldGrammar, - -- * Auxlilary - (^^^), - Section(..), - Fields, - partitionFields, - takeFields, - runFieldParser, - runFieldParser', - defaultFreeTextFieldDefST, - -- * Newtypes - module Distribution.FieldGrammar.Newtypes, - ) where - -import Distribution.Compat.Prelude -import Prelude () - -import qualified Data.Map.Strict as Map - -import Distribution.FieldGrammar.Class -import Distribution.FieldGrammar.Newtypes -import Distribution.FieldGrammar.Parsec -import Distribution.FieldGrammar.Pretty -import Distribution.Fields.Field -import Distribution.Utils.Generic (spanMaybe) - -type ParsecFieldGrammar' a = ParsecFieldGrammar a a -type PrettyFieldGrammar' a = PrettyFieldGrammar a a - -infixl 5 ^^^ - --- | Reverse function application which binds tighter than '<$>' and '<*>'. --- Useful for refining grammar specification. --- --- @ --- \<*\> 'monoidalFieldAla' "extensions" (alaList' FSep MQuoted) oldExtensions --- ^^^ 'deprecatedSince' [1,12] "Please use 'default-extensions' or 'other-extensions' fields." --- @ -(^^^) :: a -> (a -> b) -> b -x ^^^ f = f x - --- | Partitioning state -data PS ann = PS (Fields ann) [Section ann] [[Section ann]] - --- | Partition field list into field map and groups of sections. -partitionFields :: [Field ann] -> (Fields ann, [[Section ann]]) -partitionFields = finalize . foldl' f (PS mempty mempty mempty) - where - finalize :: PS ann -> (Fields ann, [[Section ann]]) - finalize (PS fs s ss) - | null s = (fs, reverse ss) - | otherwise = (fs, reverse (reverse s : ss)) - - f :: PS ann -> Field ann -> PS ann - f (PS fs s ss) (Field (Name ann name) fss) = - PS (Map.insertWith (flip (++)) name [MkNamelessField ann fss] fs) [] ss' - where - ss' | null s = ss - | otherwise = reverse s : ss - f (PS fs s ss) (Section name sargs sfields) = - PS fs (MkSection name sargs sfields : s) ss - --- | Take all fields from the front. -takeFields :: [Field ann] -> (Fields ann, [Field ann]) -takeFields = finalize . spanMaybe match - where - finalize (fs, rest) = (Map.fromListWith (flip (++)) fs, rest) - - match (Field (Name ann name) fs) = Just (name, [MkNamelessField ann fs]) - match _ = Nothing diff --git a/src/Distribution/FieldGrammar/Class.hs b/src/Distribution/FieldGrammar/Class.hs deleted file mode 100644 --- a/src/Distribution/FieldGrammar/Class.hs +++ /dev/null @@ -1,205 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -#if __GLASGOW_HASKELL__ >= 800 -{-# LANGUAGE UndecidableSuperClasses #-} -#else -{-# LANGUAGE UndecidableInstances #-} -#endif -module Distribution.FieldGrammar.Class ( - FieldGrammar (..), - uniqueField, - optionalField, - optionalFieldDef, - monoidalField, - defaultFreeTextFieldDefST, -) where - -import Distribution.Compat.Lens -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.CabalSpecVersion (CabalSpecVersion) -import Distribution.Compat.Newtype (Newtype) -import Distribution.FieldGrammar.Newtypes -import Distribution.Fields.Field -import Distribution.Utils.ShortText - --- | 'FieldGrammar' is parametrised by --- --- * @s@ which is a structure we are parsing. We need this to provide prettyprinter --- functionality --- --- * @a@ type of the field. --- --- /Note:/ We'd like to have @forall s. Applicative (f s)@ context. --- -class - ( c SpecVersion, c TestedWith, c SpecLicense, c Token, c Token', c FilePathNT - ) - => FieldGrammar c g | g -> c - where - -- | Unfocus, zoom out, /blur/ 'FieldGrammar'. - blurFieldGrammar :: ALens' a b -> g b d -> g a d - - -- | Field which should be defined, exactly once. - uniqueFieldAla - :: (c b, Newtype a b) - => FieldName -- ^ field name - -> (a -> b) -- ^ 'Newtype' pack - -> ALens' s a -- ^ lens into the field - -> g s a - - -- | Boolean field with a default value. - booleanFieldDef - :: FieldName -- ^ field name - -> ALens' s Bool -- ^ lens into the field - -> Bool -- ^ default - -> g s Bool - - -- | Optional field. - optionalFieldAla - :: (c b, Newtype a b) - => FieldName -- ^ field name - -> (a -> b) -- ^ 'pack' - -> ALens' s (Maybe a) -- ^ lens into the field - -> g s (Maybe a) - - -- | Optional field with default value. - optionalFieldDefAla - :: (c b, Newtype a b, Eq a) - => FieldName -- ^ field name - -> (a -> b) -- ^ 'Newtype' pack - -> ALens' s a -- ^ @'Lens'' s a@: lens into the field - -> a -- ^ default value - -> g s a - - -- | Free text field is essentially 'optionalFieldDefAla` with @""@ - -- as the default and "accept everything" parser. - -- - -- @since 3.0.0.0 - freeTextField - :: FieldName - -> ALens' s (Maybe String) -- ^ lens into the field - -> g s (Maybe String) - - -- | Free text field is essentially 'optionalFieldDefAla` with @""@ - -- as the default and "accept everything" parser. - -- - -- @since 3.0.0.0 - freeTextFieldDef - :: FieldName - -> ALens' s String -- ^ lens into the field - -> g s String - - -- | @since 3.2.0.0 - freeTextFieldDefST - :: FieldName - -> ALens' s ShortText -- ^ lens into the field - -> g s ShortText - - -- | Monoidal field. - -- - -- Values are combined with 'mappend'. - -- - -- /Note:/ 'optionalFieldAla' is a @monoidalField@ with 'Last' monoid. - -- - monoidalFieldAla - :: (c b, Monoid a, Newtype a b) - => FieldName -- ^ field name - -> (a -> b) -- ^ 'pack' - -> ALens' s a -- ^ lens into the field - -> g s a - - -- | Parser matching all fields with a name starting with a prefix. - prefixedFields - :: FieldName -- ^ field name prefix - -> ALens' s [(String, String)] -- ^ lens into the field - -> g s [(String, String)] - - -- | Known field, which we don't parse, nor pretty print. - knownField :: FieldName -> g s () - - -- | Field which is parsed but not pretty printed. - hiddenField :: g s a -> g s a - - -- | Deprecated since - deprecatedSince - :: CabalSpecVersion -- ^ version - -> String -- ^ deprecation message - -> g s a - -> g s a - - -- | Removed in. If we encounter removed field, parsing fails. - removedIn - :: CabalSpecVersion -- ^ version - -> String -- ^ removal message - -> g s a - -> g s a - - -- | Annotate field with since spec-version. - availableSince - :: CabalSpecVersion -- ^ spec version - -> a -- ^ default value - -> g s a - -> g s a - - -- | Annotate field with since spec-version. - -- This is used to recognise, but warn about the field. - -- It is used to process @other-extensions@ field. - -- - -- Default implementation is to not warn. - -- - -- @since 3.4.0.0 - availableSinceWarn - :: CabalSpecVersion -- ^ spec version - -> g s a - -> g s a - availableSinceWarn _ = id - --- | Field which can be defined at most once. -uniqueField - :: (FieldGrammar c g, c (Identity a)) - => FieldName -- ^ field name - -> ALens' s a -- ^ lens into the field - -> g s a -uniqueField fn l = uniqueFieldAla fn Identity l - --- | Field which can be defined at most once. -optionalField - :: (FieldGrammar c g, c (Identity a)) - => FieldName -- ^ field name - -> ALens' s (Maybe a) -- ^ lens into the field - -> g s (Maybe a) -optionalField fn l = optionalFieldAla fn Identity l - --- | Optional field with default value. -optionalFieldDef - :: (FieldGrammar c g, Functor (g s), c (Identity a), Eq a) - => FieldName -- ^ field name - -> ALens' s a -- ^ @'Lens'' s a@: lens into the field - -> a -- ^ default value - -> g s a -optionalFieldDef fn l x = optionalFieldDefAla fn Identity l x - --- | Field which can be define multiple times, and the results are @mappend@ed. -monoidalField - :: (FieldGrammar c g, c (Identity a), Monoid a) - => FieldName -- ^ field name - -> ALens' s a -- ^ lens into the field - -> g s a -monoidalField fn l = monoidalFieldAla fn Identity l - --- | Default implementation for 'freeTextFieldDefST'. -defaultFreeTextFieldDefST - :: (Functor (g s), FieldGrammar c g) - => FieldName - -> ALens' s ShortText -- ^ lens into the field - -> g s ShortText -defaultFreeTextFieldDefST fn l = - toShortText <$> freeTextFieldDef fn (cloneLens l . st) - where - st :: Lens' ShortText String - st f s = toShortText <$> f (fromShortText s) diff --git a/src/Distribution/FieldGrammar/FieldDescrs.hs b/src/Distribution/FieldGrammar/FieldDescrs.hs deleted file mode 100644 --- a/src/Distribution/FieldGrammar/FieldDescrs.hs +++ /dev/null @@ -1,121 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE UndecidableInstances #-} -module Distribution.FieldGrammar.FieldDescrs ( - FieldDescrs, - fieldDescrPretty, - fieldDescrParse, - fieldDescrsToList, - ) where - -import Distribution.Compat.Prelude -import Prelude () - -import Data.List (dropWhileEnd) -import Distribution.Compat.Lens (aview, cloneLens) -import Distribution.Compat.Newtype -import Distribution.FieldGrammar -import Distribution.Pretty (Pretty (..), showFreeText) - -import qualified Data.Map as Map -import qualified Distribution.Compat.CharParsing as C -import qualified Distribution.Fields.Field as P -import qualified Distribution.Parsec as P -import qualified Text.PrettyPrint as Disp - --- strict pair -data SP s = SP - { pPretty :: !(s -> Disp.Doc) - , pParse :: !(forall m. P.CabalParsing m => s -> m s) - } - --- | A collection of field parsers and pretty-printers. -newtype FieldDescrs s a = F { runF :: Map P.FieldName (SP s) } - deriving (Functor) - -instance Applicative (FieldDescrs s) where - pure _ = F mempty - f <*> x = F (mappend (runF f) (runF x)) - -singletonF :: P.FieldName -> (s -> Disp.Doc) -> (forall m. P.CabalParsing m => s -> m s) -> FieldDescrs s a -singletonF fn f g = F $ Map.singleton fn (SP f g) - --- | Lookup a field value pretty-printer. -fieldDescrPretty :: FieldDescrs s a -> P.FieldName -> Maybe (s -> Disp.Doc) -fieldDescrPretty (F m) fn = pPretty <$> Map.lookup fn m - --- | Lookup a field value parser. -fieldDescrParse :: P.CabalParsing m => FieldDescrs s a -> P.FieldName -> Maybe (s -> m s) -fieldDescrParse (F m) fn = (\f -> pParse f) <$> Map.lookup fn m - -fieldDescrsToList - :: P.CabalParsing m - => FieldDescrs s a - -> [(P.FieldName, s -> Disp.Doc, s -> m s)] -fieldDescrsToList = map mk . Map.toList . runF where - mk (name, SP ppr parse) = (name, ppr, parse) - --- | /Note:/ default values are printed. -instance FieldGrammar ParsecPretty FieldDescrs where - blurFieldGrammar l (F m) = F (fmap blur m) where - blur (SP f g) = SP (f . aview l) (cloneLens l g) - - booleanFieldDef fn l _def = singletonF fn f g where - f s = Disp.text (show (aview l s)) - g s = cloneLens l (const P.parsec) s - -- Note: eta expansion is needed for RankNTypes type-checking to work. - - uniqueFieldAla fn _pack l = singletonF fn f g where - f s = pretty (pack' _pack (aview l s)) - g s = cloneLens l (const (unpack' _pack <$> P.parsec)) s - - optionalFieldAla fn _pack l = singletonF fn f g where - f s = maybe mempty (pretty . pack' _pack) (aview l s) - g s = cloneLens l (const (Just . unpack' _pack <$> P.parsec)) s - - optionalFieldDefAla fn _pack l _def = singletonF fn f g where - f s = pretty (pack' _pack (aview l s)) - g s = cloneLens l (const (unpack' _pack <$> P.parsec)) s - - freeTextField fn l = singletonF fn f g where - f s = maybe mempty showFreeText (aview l s) - g s = cloneLens l (const (Just <$> parsecFreeText)) s - - freeTextFieldDef fn l = singletonF fn f g where - f s = showFreeText (aview l s) - g s = cloneLens l (const parsecFreeText) s - - freeTextFieldDefST = defaultFreeTextFieldDefST - - monoidalFieldAla fn _pack l = singletonF fn f g where - f s = pretty (pack' _pack (aview l s)) - g s = cloneLens l (\x -> mappend x . unpack' _pack <$> P.parsec) s - - prefixedFields _fnPfx _l = F mempty - knownField _ = pure () - deprecatedSince _ _ x = x - removedIn _ _ x = x - availableSince _ _ = id - hiddenField _ = F mempty - -parsecFreeText :: P.CabalParsing m => m String -parsecFreeText = dropDotLines <$ C.spaces <*> many C.anyChar - where - -- Example package with dot lines - -- http://hackage.haskell.org/package/copilot-cbmc-0.1/copilot-cbmc.cabal - dropDotLines "." = "." - dropDotLines x = intercalate "\n" . map dotToEmpty . lines $ x - - dotToEmpty x | trim' x == "." = "" - dotToEmpty x = trim x - - trim' :: String -> String - trim' = dropWhileEnd (`elem` (" \t" :: String)) - - trim :: String -> String - trim = dropWhile isSpace . dropWhileEnd isSpace - -class (P.Parsec a, Pretty a) => ParsecPretty a -instance (P.Parsec a, Pretty a) => ParsecPretty a diff --git a/src/Distribution/FieldGrammar/Newtypes.hs b/src/Distribution/FieldGrammar/Newtypes.hs deleted file mode 100644 --- a/src/Distribution/FieldGrammar/Newtypes.hs +++ /dev/null @@ -1,392 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} --- | This module provides @newtype@ wrappers to be used with "Distribution.FieldGrammar". -module Distribution.FieldGrammar.Newtypes ( - -- * List - alaList, - alaList', - -- ** Modifiers - CommaVCat (..), - CommaFSep (..), - VCat (..), - FSep (..), - NoCommaFSep (..), - Sep (..), - -- ** Type - List, - -- ** Set - alaSet, - alaSet', - Set', - -- ** NonEmpty - alaNonEmpty, - alaNonEmpty', - NonEmpty', - -- * Version & License - SpecVersion (..), - TestedWith (..), - SpecLicense (..), - -- * Identifiers - Token (..), - Token' (..), - MQuoted (..), - FilePathNT (..), - ) where - -import Distribution.Compat.Newtype -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.CabalSpecVersion -import Distribution.Compiler (CompilerFlavor) -import Distribution.License (License) -import Distribution.Parsec -import Distribution.Pretty -import Distribution.Version - (LowerBound (..), Version, VersionInterval (..), VersionRange, VersionRangeF (..), anyVersion, asVersionIntervals, cataVersionRange, mkVersion, - version0, versionNumbers) -import Text.PrettyPrint (Doc, comma, fsep, punctuate, text, vcat) - -import qualified Data.List.NonEmpty as NE -import qualified Data.Set as Set -import qualified Distribution.Compat.CharParsing as P -import qualified Distribution.SPDX as SPDX - --- | Vertical list with commas. Displayed with 'vcat' -data CommaVCat = CommaVCat - --- | Paragraph fill list with commas. Displayed with 'fsep' -data CommaFSep = CommaFSep - --- | Vertical list with optional commas. Displayed with 'vcat'. -data VCat = VCat - --- | Paragraph fill list with optional commas. Displayed with 'fsep'. -data FSep = FSep - --- | Paragraph fill list without commas. Displayed with 'fsep'. -data NoCommaFSep = NoCommaFSep - -class Sep sep where - prettySep :: Proxy sep -> [Doc] -> Doc - - parseSep :: CabalParsing m => Proxy sep -> m a -> m [a] - parseSepNE :: CabalParsing m => Proxy sep -> m a -> m (NonEmpty a) - -instance Sep CommaVCat where - prettySep _ = vcat . punctuate comma - parseSep _ p = do - v <- askCabalSpecVersion - if v >= CabalSpecV2_2 then parsecLeadingCommaList p else parsecCommaList p - parseSepNE _ p = do - v <- askCabalSpecVersion - if v >= CabalSpecV2_2 then parsecLeadingCommaNonEmpty p else parsecCommaNonEmpty p -instance Sep CommaFSep where - prettySep _ = fsep . punctuate comma - parseSep _ p = do - v <- askCabalSpecVersion - if v >= CabalSpecV2_2 then parsecLeadingCommaList p else parsecCommaList p - parseSepNE _ p = do - v <- askCabalSpecVersion - if v >= CabalSpecV2_2 then parsecLeadingCommaNonEmpty p else parsecCommaNonEmpty p -instance Sep VCat where - prettySep _ = vcat - parseSep _ p = do - v <- askCabalSpecVersion - if v >= CabalSpecV3_0 then parsecLeadingOptCommaList p else parsecOptCommaList p - parseSepNE _ p = NE.some1 (p <* P.spaces) -instance Sep FSep where - prettySep _ = fsep - parseSep _ p = do - v <- askCabalSpecVersion - if v >= CabalSpecV3_0 then parsecLeadingOptCommaList p else parsecOptCommaList p - parseSepNE _ p = NE.some1 (p <* P.spaces) -instance Sep NoCommaFSep where - prettySep _ = fsep - parseSep _ p = many (p <* P.spaces) - parseSepNE _ p = NE.some1 (p <* P.spaces) - --- | List separated with optional commas. Displayed with @sep@, arguments of --- type @a@ are parsed and pretty-printed as @b@. -newtype List sep b a = List { _getList :: [a] } - --- | 'alaList' and 'alaList'' are simply 'List', with additional phantom --- arguments to constrain the resulting type --- --- >>> :t alaList VCat --- alaList VCat :: [a] -> List VCat (Identity a) a --- --- >>> :t alaList' FSep Token --- alaList' FSep Token :: [String] -> List FSep Token String --- -alaList :: sep -> [a] -> List sep (Identity a) a -alaList _ = List - --- | More general version of 'alaList'. -alaList' :: sep -> (a -> b) -> [a] -> List sep b a -alaList' _ _ = List - -instance Newtype [a] (List sep wrapper a) - -instance (Newtype a b, Sep sep, Parsec b) => Parsec (List sep b a) where - parsec = pack . map (unpack :: b -> a) <$> parseSep (Proxy :: Proxy sep) parsec - -instance (Newtype a b, Sep sep, Pretty b) => Pretty (List sep b a) where - pretty = prettySep (Proxy :: Proxy sep) . map (pretty . (pack :: a -> b)) . unpack - --- --- | Like 'List', but for 'Set'. --- --- @since 3.2.0.0 -newtype Set' sep b a = Set' { _getSet :: Set a } - --- | 'alaSet' and 'alaSet'' are simply 'Set'' constructor, with additional phantom --- arguments to constrain the resulting type --- --- >>> :t alaSet VCat --- alaSet VCat :: Set a -> Set' VCat (Identity a) a --- --- >>> :t alaSet' FSep Token --- alaSet' FSep Token :: Set String -> Set' FSep Token String --- --- >>> unpack' (alaSet' FSep Token) <$> eitherParsec "foo bar foo" --- Right (fromList ["bar","foo"]) --- --- @since 3.2.0.0 -alaSet :: sep -> Set a -> Set' sep (Identity a) a -alaSet _ = Set' - --- | More general version of 'alaSet'. --- --- @since 3.2.0.0 -alaSet' :: sep -> (a -> b) -> Set a -> Set' sep b a -alaSet' _ _ = Set' - -instance Newtype (Set a) (Set' sep wrapper a) - -instance (Newtype a b, Ord a, Sep sep, Parsec b) => Parsec (Set' sep b a) where - parsec = pack . Set.fromList . map (unpack :: b -> a) <$> parseSep (Proxy :: Proxy sep) parsec - -instance (Newtype a b, Sep sep, Pretty b) => Pretty (Set' sep b a) where - pretty = prettySep (Proxy :: Proxy sep) . map (pretty . (pack :: a -> b)) . Set.toList . unpack - --- --- | Like 'List', but for 'NonEmpty'. --- --- @since 3.2.0.0 -newtype NonEmpty' sep b a = NonEmpty' { _getNonEmpty :: NonEmpty a } - --- | 'alaNonEmpty' and 'alaNonEmpty'' are simply 'NonEmpty'' constructor, with additional phantom --- arguments to constrain the resulting type --- --- >>> :t alaNonEmpty VCat --- alaNonEmpty VCat :: NonEmpty a -> NonEmpty' VCat (Identity a) a --- --- >>> unpack' (alaNonEmpty' FSep Token) <$> eitherParsec "foo bar foo" --- Right ("foo" :| ["bar","foo"]) --- --- @since 3.2.0.0 -alaNonEmpty :: sep -> NonEmpty a -> NonEmpty' sep (Identity a) a -alaNonEmpty _ = NonEmpty' - --- | More general version of 'alaNonEmpty'. --- --- @since 3.2.0.0 -alaNonEmpty' :: sep -> (a -> b) -> NonEmpty a -> NonEmpty' sep b a -alaNonEmpty' _ _ = NonEmpty' - -instance Newtype (NonEmpty a) (NonEmpty' sep wrapper a) - -instance (Newtype a b, Sep sep, Parsec b) => Parsec (NonEmpty' sep b a) where - parsec = pack . fmap (unpack :: b -> a) <$> parseSepNE (Proxy :: Proxy sep) parsec - -instance (Newtype a b, Sep sep, Pretty b) => Pretty (NonEmpty' sep b a) where - pretty = prettySep (Proxy :: Proxy sep) . map (pretty . (pack :: a -> b)) . NE.toList . unpack - -------------------------------------------------------------------------------- --- Identifiers -------------------------------------------------------------------------------- - --- | Haskell string or @[^ ,]+@ -newtype Token = Token { getToken :: String } - -instance Newtype String Token - -instance Parsec Token where - parsec = pack <$> parsecToken - -instance Pretty Token where - pretty = showToken . unpack - --- | Haskell string or @[^ ]+@ -newtype Token' = Token' { getToken' :: String } - -instance Newtype String Token' - -instance Parsec Token' where - parsec = pack <$> parsecToken' - -instance Pretty Token' where - pretty = showToken . unpack - --- | Either @"quoted"@ or @un-quoted@. -newtype MQuoted a = MQuoted { getMQuoted :: a } - -instance Newtype a (MQuoted a) - -instance Parsec a => Parsec (MQuoted a) where - parsec = pack <$> parsecMaybeQuoted parsec - -instance Pretty a => Pretty (MQuoted a) where - pretty = pretty . unpack - --- | Filepath are parsed as 'Token'. -newtype FilePathNT = FilePathNT { getFilePathNT :: String } - -instance Newtype String FilePathNT - -instance Parsec FilePathNT where - parsec = do - token <- parsecToken - if null token - then P.unexpected "empty FilePath" - else return (FilePathNT token) - -instance Pretty FilePathNT where - pretty = showFilePath . unpack - -------------------------------------------------------------------------------- --- SpecVersion -------------------------------------------------------------------------------- - --- | Version range or just version, i.e. @cabal-version@ field. --- --- There are few things to consider: --- --- * Starting with 2.2 the cabal-version field should be the first field in the --- file and only exact version is accepted. Therefore if we get e.g. --- @>= 2.2@, we fail. --- See --- --- We have this newtype, as writing Parsec and Pretty instances --- for CabalSpecVersion would cause cycle in modules: --- Version -> CabalSpecVersion -> Parsec -> ... --- -newtype SpecVersion = SpecVersion { getSpecVersion :: CabalSpecVersion } - deriving (Eq, Show) -- instances needed for tests - -instance Newtype CabalSpecVersion SpecVersion - -instance Parsec SpecVersion where - parsec = do - e <- parsecSpecVersion - let ver :: Version - ver = either id specVersionFromRange e - - digits :: [Int] - digits = versionNumbers ver - - case cabalSpecFromVersionDigits digits of - Nothing -> fail $ "Unknown cabal spec version specified: " ++ prettyShow ver - Just csv -> do - -- Check some warnings: - case e of - -- example: cabal-version: 1.10 - -- should be cabal-version: >=1.10 - Left _v | csv < CabalSpecV1_12 -> parsecWarning PWTSpecVersion $ concat - [ "With 1.10 or earlier, the 'cabal-version' field must use " - , "range syntax rather than a simple version number. Use " - , "'cabal-version: >= " ++ prettyShow ver ++ "'." - ] - - -- example: cabal-version: >=1.12 - -- should be cabal-version: 1.12 - Right _vr | csv >= CabalSpecV1_12 -> parsecWarning PWTSpecVersion $ concat - [ "Packages with 'cabal-version: 1.12' or later should specify a " - , "specific version of the Cabal spec of the form " - , "'cabal-version: x.y'. " - , "Use 'cabal-version: " ++ prettyShow ver ++ "'." - ] - - -- example: cabal-version: >=1.10 && <1.12 - -- should be cabal-version: >=1.10 - Right vr | csv < CabalSpecV1_12 - , not (simpleSpecVersionRangeSyntax vr) -> parsecWarning PWTSpecVersion $ concat - [ "It is recommended that the 'cabal-version' field only specify a " - , "version range of the form '>= x.y' for older cabal versions. Use " - , "'cabal-version: >= " ++ prettyShow ver ++ "'. " - , "Tools based on Cabal 1.10 and later will ignore upper bounds." - ] - - -- otherwise no warnings - _ -> pure () - - return (pack csv) - where - parsecSpecVersion = Left <$> parsec <|> Right <$> range - - range = do - vr <- parsec - if specVersionFromRange vr >= mkVersion [2,1] - then fail "cabal-version higher than 2.2 cannot be specified as a range. See https://github.com/haskell/cabal/issues/4899" - else return vr - - specVersionFromRange :: VersionRange -> Version - specVersionFromRange versionRange = case asVersionIntervals versionRange of - [] -> version0 - VersionInterval (LowerBound version _) _ : _ -> version - - simpleSpecVersionRangeSyntax = cataVersionRange alg where - alg (OrLaterVersionF _) = True - alg _ = False - - -instance Pretty SpecVersion where - pretty (SpecVersion csv) - | csv >= CabalSpecV1_12 = text (showCabalSpecVersion csv) - | otherwise = text ">=" <<>> text (showCabalSpecVersion csv) - -------------------------------------------------------------------------------- --- SpecLicense -------------------------------------------------------------------------------- - --- | SPDX License expression or legacy license -newtype SpecLicense = SpecLicense { getSpecLicense :: Either SPDX.License License } - -instance Newtype (Either SPDX.License License) SpecLicense - -instance Parsec SpecLicense where - parsec = do - v <- askCabalSpecVersion - if v >= CabalSpecV2_2 - then SpecLicense . Left <$> parsec - else SpecLicense . Right <$> parsec - -instance Pretty SpecLicense where - pretty = either pretty pretty . unpack - -------------------------------------------------------------------------------- --- TestedWith -------------------------------------------------------------------------------- - --- | Version range or just version -newtype TestedWith = TestedWith { getTestedWith :: (CompilerFlavor, VersionRange) } - -instance Newtype (CompilerFlavor, VersionRange) TestedWith - -instance Parsec TestedWith where - parsec = pack <$> parsecTestedWith - -instance Pretty TestedWith where - pretty x = case unpack x of - (compiler, vr) -> pretty compiler <+> pretty vr - -parsecTestedWith :: CabalParsing m => m (CompilerFlavor, VersionRange) -parsecTestedWith = do - name <- lexemeParsec - ver <- parsec <|> pure anyVersion - return (name, ver) diff --git a/src/Distribution/FieldGrammar/Parsec.hs b/src/Distribution/FieldGrammar/Parsec.hs deleted file mode 100644 --- a/src/Distribution/FieldGrammar/Parsec.hs +++ /dev/null @@ -1,439 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} --- | This module provides a 'FieldGrammarParser', one way to parse --- @.cabal@ -like files. --- --- Fields can be specified multiple times in the .cabal files. The order of --- such entries is important, but the mutual ordering of different fields is --- not.Also conditional sections are considered after non-conditional data. --- The example of this silent-commutation quirk is the fact that --- --- @ --- buildable: True --- if os(linux) --- buildable: False --- @ --- --- and --- --- @ --- if os(linux) --- buildable: False --- buildable: True --- @ --- --- behave the same! This is the limitation of 'GeneralPackageDescription' --- structure. --- --- So we transform the list of fields @['Field' ann]@ into --- a map of grouped ordinary fields and a list of lists of sections: --- @'Fields' ann = 'Map' 'FieldName' ['NamelessField' ann]@ and @[['Section' ann]]@. --- --- We need list of list of sections, because we need to distinguish situations --- where there are fields in between. For example --- --- @ --- if flag(bytestring-lt-0_10_4) --- build-depends: bytestring < 0.10.4 --- --- default-language: Haskell2020 --- --- else --- build-depends: bytestring >= 0.10.4 --- --- @ --- --- is obviously invalid specification. --- --- We can parse 'Fields' like we parse @aeson@ objects, yet we use --- slightly higher-level API, so we can process unspecified fields, --- to report unknown fields and save custom @x-fields@. --- -module Distribution.FieldGrammar.Parsec ( - ParsecFieldGrammar, - parseFieldGrammar, - fieldGrammarKnownFieldList, - -- * Auxiliary - Fields, - NamelessField (..), - namelessFieldAnn, - Section (..), - runFieldParser, - runFieldParser', - fieldLinesToStream, - ) where - -import Data.List (dropWhileEnd) -import Distribution.Compat.Newtype -import Distribution.Compat.Prelude -import Distribution.Simple.Utils (fromUTF8BS) -import Prelude () - -import qualified Data.ByteString as BS -import qualified Data.List.NonEmpty as NE -import qualified Data.Map.Strict as Map -import qualified Data.Set as Set -import qualified Distribution.Utils.ShortText as ShortText -import qualified Text.Parsec as P -import qualified Text.Parsec.Error as P - -import Distribution.CabalSpecVersion -import Distribution.FieldGrammar.Class -import Distribution.Fields.Field -import Distribution.Fields.ParseResult -import Distribution.Parsec -import Distribution.Parsec.FieldLineStream -import Distribution.Parsec.Position (positionCol, positionRow) - -------------------------------------------------------------------------------- --- Auxiliary types -------------------------------------------------------------------------------- - -type Fields ann = Map FieldName [NamelessField ann] - --- | Single field, without name, but with its annotation. -data NamelessField ann = MkNamelessField !ann [FieldLine ann] - deriving (Eq, Show, Functor) - -namelessFieldAnn :: NamelessField ann -> ann -namelessFieldAnn (MkNamelessField ann _) = ann - --- | The 'Section' constructor of 'Field'. -data Section ann = MkSection !(Name ann) [SectionArg ann] [Field ann] - deriving (Eq, Show, Functor) - -------------------------------------------------------------------------------- --- ParsecFieldGrammar -------------------------------------------------------------------------------- - -data ParsecFieldGrammar s a = ParsecFG - { fieldGrammarKnownFields :: !(Set FieldName) - , fieldGrammarKnownPrefixes :: !(Set FieldName) - , fieldGrammarParser :: !(CabalSpecVersion -> Fields Position -> ParseResult a) - } - deriving (Functor) - -parseFieldGrammar :: CabalSpecVersion -> Fields Position -> ParsecFieldGrammar s a -> ParseResult a -parseFieldGrammar v fields grammar = do - for_ (Map.toList (Map.filterWithKey isUnknownField fields)) $ \(name, nfields) -> - for_ nfields $ \(MkNamelessField pos _) -> - parseWarning pos PWTUnknownField $ "Unknown field: " ++ show name - -- TODO: fields allowed in this section - - -- parse - fieldGrammarParser grammar v fields - - where - isUnknownField k _ = not $ - k `Set.member` fieldGrammarKnownFields grammar - || any (`BS.isPrefixOf` k) (fieldGrammarKnownPrefixes grammar) - -fieldGrammarKnownFieldList :: ParsecFieldGrammar s a -> [FieldName] -fieldGrammarKnownFieldList = Set.toList . fieldGrammarKnownFields - -instance Applicative (ParsecFieldGrammar s) where - pure x = ParsecFG mempty mempty (\_ _ -> pure x) - {-# INLINE pure #-} - - ParsecFG f f' f'' <*> ParsecFG x x' x'' = ParsecFG - (mappend f x) - (mappend f' x') - (\v fields -> f'' v fields <*> x'' v fields) - {-# INLINE (<*>) #-} - -warnMultipleSingularFields :: FieldName -> [NamelessField Position] -> ParseResult () -warnMultipleSingularFields _ [] = pure () -warnMultipleSingularFields fn (x : xs) = do - let pos = namelessFieldAnn x - poss = map namelessFieldAnn xs - parseWarning pos PWTMultipleSingularField $ - "The field " <> show fn <> " is specified more than once at positions " ++ intercalate ", " (map showPos (pos : poss)) - -instance FieldGrammar Parsec ParsecFieldGrammar where - blurFieldGrammar _ (ParsecFG s s' parser) = ParsecFG s s' parser - - uniqueFieldAla fn _pack _extract = ParsecFG (Set.singleton fn) Set.empty parser - where - parser v fields = case Map.lookup fn fields of - Nothing -> parseFatalFailure zeroPos $ show fn ++ " field missing" - Just [] -> parseFatalFailure zeroPos $ show fn ++ " field missing" - Just [x] -> parseOne v x - Just xs@(_:y:ys) -> do - warnMultipleSingularFields fn xs - NE.last <$> traverse (parseOne v) (y:|ys) - - parseOne v (MkNamelessField pos fls) = - unpack' _pack <$> runFieldParser pos parsec v fls - - booleanFieldDef fn _extract def = ParsecFG (Set.singleton fn) Set.empty parser - where - parser v fields = case Map.lookup fn fields of - Nothing -> pure def - Just [] -> pure def - Just [x] -> parseOne v x - Just xs@(_:y:ys) -> do - warnMultipleSingularFields fn xs - NE.last <$> traverse (parseOne v) (y:|ys) - - parseOne v (MkNamelessField pos fls) = runFieldParser pos parsec v fls - - optionalFieldAla fn _pack _extract = ParsecFG (Set.singleton fn) Set.empty parser - where - parser v fields = case Map.lookup fn fields of - Nothing -> pure Nothing - Just [] -> pure Nothing - Just [x] -> parseOne v x - Just xs@(_:y:ys) -> do - warnMultipleSingularFields fn xs - NE.last <$> traverse (parseOne v) (y:|ys) - - parseOne v (MkNamelessField pos fls) - | null fls = pure Nothing - | otherwise = Just . unpack' _pack <$> runFieldParser pos parsec v fls - - optionalFieldDefAla fn _pack _extract def = ParsecFG (Set.singleton fn) Set.empty parser - where - parser v fields = case Map.lookup fn fields of - Nothing -> pure def - Just [] -> pure def - Just [x] -> parseOne v x - Just xs@(_:y:ys) -> do - warnMultipleSingularFields fn xs - NE.last <$> traverse (parseOne v) (y:|ys) - - parseOne v (MkNamelessField pos fls) - | null fls = pure def - | otherwise = unpack' _pack <$> runFieldParser pos parsec v fls - - freeTextField fn _ = ParsecFG (Set.singleton fn) Set.empty parser where - parser v fields = case Map.lookup fn fields of - Nothing -> pure Nothing - Just [] -> pure Nothing - Just [x] -> parseOne v x - Just xs@(_:y:ys) -> do - warnMultipleSingularFields fn xs - NE.last <$> traverse (parseOne v) (y:|ys) - - parseOne v (MkNamelessField pos fls) - | null fls = pure Nothing - | v >= CabalSpecV3_0 = pure (Just (fieldlinesToFreeText3 pos fls)) - | otherwise = pure (Just (fieldlinesToFreeText fls)) - - freeTextFieldDef fn _ = ParsecFG (Set.singleton fn) Set.empty parser where - parser v fields = case Map.lookup fn fields of - Nothing -> pure "" - Just [] -> pure "" - Just [x] -> parseOne v x - Just xs@(_:y:ys) -> do - warnMultipleSingularFields fn xs - NE.last <$> traverse (parseOne v) (y:|ys) - - parseOne v (MkNamelessField pos fls) - | null fls = pure "" - | v >= CabalSpecV3_0 = pure (fieldlinesToFreeText3 pos fls) - | otherwise = pure (fieldlinesToFreeText fls) - - -- freeTextFieldDefST = defaultFreeTextFieldDefST - freeTextFieldDefST fn _ = ParsecFG (Set.singleton fn) Set.empty parser where - parser v fields = case Map.lookup fn fields of - Nothing -> pure mempty - Just [] -> pure mempty - Just [x] -> parseOne v x - Just xs@(_:y:ys) -> do - warnMultipleSingularFields fn xs - NE.last <$> traverse (parseOne v) (y:|ys) - - parseOne v (MkNamelessField pos fls) = case fls of - [] -> pure mempty - [FieldLine _ bs] -> pure (ShortText.unsafeFromUTF8BS bs) - _ | v >= CabalSpecV3_0 -> pure (ShortText.toShortText $ fieldlinesToFreeText3 pos fls) - | otherwise -> pure (ShortText.toShortText $ fieldlinesToFreeText fls) - - monoidalFieldAla fn _pack _extract = ParsecFG (Set.singleton fn) Set.empty parser - where - parser v fields = case Map.lookup fn fields of - Nothing -> pure mempty - Just xs -> foldMap (unpack' _pack) <$> traverse (parseOne v) xs - - parseOne v (MkNamelessField pos fls) = runFieldParser pos parsec v fls - - prefixedFields fnPfx _extract = ParsecFG mempty (Set.singleton fnPfx) (\_ fs -> pure (parser fs)) - where - parser :: Fields Position -> [(String, String)] - parser values = reorder $ concatMap convert $ filter match $ Map.toList values - - match (fn, _) = fnPfx `BS.isPrefixOf` fn - convert (fn, fields) = - [ (pos, (fromUTF8BS fn, trim $ fromUTF8BS $ fieldlinesToBS fls)) - | MkNamelessField pos fls <- fields - ] - -- hack: recover the order of prefixed fields - reorder = map snd . sortBy (comparing fst) - trim :: String -> String - trim = dropWhile isSpace . dropWhileEnd isSpace - - availableSince vs def (ParsecFG names prefixes parser) = ParsecFG names prefixes parser' - where - parser' v values - | v >= vs = parser v values - | otherwise = do - let unknownFields = Map.intersection values $ Map.fromSet (const ()) names - for_ (Map.toList unknownFields) $ \(name, fields) -> - for_ fields $ \(MkNamelessField pos _) -> - parseWarning pos PWTUnknownField $ - "The field " <> show name <> " is available only since the Cabal specification version " ++ showCabalSpecVersion vs ++ ". This field will be ignored." - - pure def - - availableSinceWarn vs (ParsecFG names prefixes parser) = ParsecFG names prefixes parser' - where - parser' v values - | v >= vs = parser v values - | otherwise = do - let unknownFields = Map.intersection values $ Map.fromSet (const ()) names - for_ (Map.toList unknownFields) $ \(name, fields) -> - for_ fields $ \(MkNamelessField pos _) -> - parseWarning pos PWTUnknownField $ - "The field " <> show name <> " is available only since the Cabal specification version " ++ showCabalSpecVersion vs ++ "." - - parser v values - - - -- todo we know about this field - deprecatedSince vs msg (ParsecFG names prefixes parser) = ParsecFG names prefixes parser' - where - parser' v values - | v >= vs = do - let deprecatedFields = Map.intersection values $ Map.fromSet (const ()) names - for_ (Map.toList deprecatedFields) $ \(name, fields) -> - for_ fields $ \(MkNamelessField pos _) -> - parseWarning pos PWTDeprecatedField $ - "The field " <> show name <> " is deprecated in the Cabal specification version " ++ showCabalSpecVersion vs ++ ". " ++ msg - - parser v values - - | otherwise = parser v values - - removedIn vs msg (ParsecFG names prefixes parser) = ParsecFG names prefixes parser' where - parser' v values - | v >= vs = do - let msg' = if null msg then "" else ' ' : msg - let unknownFields = Map.intersection values $ Map.fromSet (const ()) names - let namePos = - [ (name, pos) - | (name, fields) <- Map.toList unknownFields - , MkNamelessField pos _ <- fields - ] - - let makeMsg name = "The field " <> show name <> " is removed in the Cabal specification version " ++ showCabalSpecVersion vs ++ "." ++ msg' - - case namePos of - -- no fields => proceed (with empty values, to be sure) - [] -> parser v mempty - - -- if there's single field: fail fatally with it - ((name, pos) : rest) -> do - for_ rest $ \(name', pos') -> parseFailure pos' $ makeMsg name' - parseFatalFailure pos $ makeMsg name - - | otherwise = parser v values - - knownField fn = ParsecFG (Set.singleton fn) Set.empty (\_ _ -> pure ()) - - hiddenField = id - -------------------------------------------------------------------------------- --- Parsec -------------------------------------------------------------------------------- - -runFieldParser' :: [Position] -> ParsecParser a -> CabalSpecVersion -> FieldLineStream -> ParseResult a -runFieldParser' inputPoss p v str = case P.runParser p' [] "" str of - Right (pok, ws) -> do - traverse_ (\(PWarning t pos w) -> parseWarning (mapPosition pos) t w) ws - pure pok - Left err -> do - let ppos = P.errorPos err - let epos = mapPosition $ Position (P.sourceLine ppos) (P.sourceColumn ppos) - - let msg = P.showErrorMessages - "or" "unknown parse error" "expecting" "unexpected" "end of input" - (P.errorMessages err) - parseFatalFailure epos $ msg ++ "\n" - where - p' = (,) <$ P.spaces <*> unPP p v <* P.spaces <* P.eof <*> P.getState - - -- Positions start from 1:1, not 0:0 - mapPosition (Position prow pcol) = go (prow - 1) inputPoss where - go _ [] = zeroPos - go _ [Position row col] = Position row (col + pcol - 1) - go n (Position row col:_) | n <= 0 = Position row (col + pcol - 1) - go n (_:ps) = go (n - 1) ps - -runFieldParser :: Position -> ParsecParser a -> CabalSpecVersion -> [FieldLine Position] -> ParseResult a -runFieldParser pp p v ls = runFieldParser' poss p v (fieldLinesToStream ls) - where - poss = map (\(FieldLine pos _) -> pos) ls ++ [pp] -- add "default" position - -fieldlinesToBS :: [FieldLine ann] -> BS.ByteString -fieldlinesToBS = BS.intercalate "\n" . map (\(FieldLine _ bs) -> bs) - --- Example package with dot lines --- http://hackage.haskell.org/package/copilot-cbmc-0.1/copilot-cbmc.cabal -fieldlinesToFreeText :: [FieldLine ann] -> String -fieldlinesToFreeText [FieldLine _ "."] = "." -fieldlinesToFreeText fls = intercalate "\n" (map go fls) - where - go (FieldLine _ bs) - | s == "." = "" - | otherwise = s - where - s = trim (fromUTF8BS bs) - - trim :: String -> String - trim = dropWhile isSpace . dropWhileEnd isSpace - -fieldlinesToFreeText3 :: Position -> [FieldLine Position] -> String -fieldlinesToFreeText3 _ [] = "" -fieldlinesToFreeText3 _ [FieldLine _ bs] = fromUTF8BS bs -fieldlinesToFreeText3 pos (FieldLine pos1 bs1 : fls2@(FieldLine pos2 _ : _)) - -- if first line is on the same line with field name: - -- the indentation level is either - -- 1. the indentation of left most line in rest fields - -- 2. the indentation of the first line - -- whichever is leftmost - | positionRow pos == positionRow pos1 = concat - $ fromUTF8BS bs1 - : mealy (mk mcol1) pos1 fls2 - - -- otherwise, also indent the first line - | otherwise = concat - $ replicate (positionCol pos1 - mcol2) ' ' - : fromUTF8BS bs1 - : mealy (mk mcol2) pos1 fls2 - - where - mcol1 = foldl' (\a b -> min a $ positionCol $ fieldLineAnn b) (min (positionCol pos1) (positionCol pos2)) fls2 - mcol2 = foldl' (\a b -> min a $ positionCol $ fieldLineAnn b) (positionCol pos1) fls2 - - mk :: Int -> Position -> FieldLine Position -> (Position, String) - mk col p (FieldLine q bs) = - ( q - , replicate newlines '\n' - ++ replicate indent ' ' - ++ fromUTF8BS bs - ) - where - newlines = positionRow q - positionRow p - indent = positionCol q - col - -mealy :: (s -> a -> (s, b)) -> s -> [a] -> [b] -mealy f = go where - go _ [] = [] - go s (x : xs) = let ~(s', y) = f s x in y : go s' xs - -fieldLinesToStream :: [FieldLine ann] -> FieldLineStream -fieldLinesToStream [] = fieldLineStreamEnd -fieldLinesToStream [FieldLine _ bs] = FLSLast bs -fieldLinesToStream (FieldLine _ bs : fs) = FLSCons bs (fieldLinesToStream fs) diff --git a/src/Distribution/FieldGrammar/Pretty.hs b/src/Distribution/FieldGrammar/Pretty.hs deleted file mode 100644 --- a/src/Distribution/FieldGrammar/Pretty.hs +++ /dev/null @@ -1,104 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE MultiParamTypeClasses #-} -module Distribution.FieldGrammar.Pretty ( - PrettyFieldGrammar, - prettyFieldGrammar, - ) where - -import Distribution.CabalSpecVersion -import Distribution.Compat.Lens -import Distribution.Compat.Newtype -import Distribution.Compat.Prelude -import Distribution.Fields.Field (FieldName) -import Distribution.Fields.Pretty (PrettyField (..)) -import Distribution.Pretty (Pretty (..), showFreeText, showFreeTextV3) -import Distribution.Simple.Utils (toUTF8BS) -import Prelude () -import Text.PrettyPrint (Doc) -import qualified Text.PrettyPrint as PP - -import Distribution.FieldGrammar.Class - -newtype PrettyFieldGrammar s a = PrettyFG - { fieldGrammarPretty :: CabalSpecVersion -> s -> [PrettyField ()] - } - deriving (Functor) - -instance Applicative (PrettyFieldGrammar s) where - pure _ = PrettyFG (\_ _ -> mempty) - PrettyFG f <*> PrettyFG x = PrettyFG (\v s -> f v s <> x v s) - --- | We can use 'PrettyFieldGrammar' to pp print the @s@. --- --- /Note:/ there is not trailing @($+$ text "")@. -prettyFieldGrammar :: CabalSpecVersion -> PrettyFieldGrammar s a -> s -> [PrettyField ()] -prettyFieldGrammar = flip fieldGrammarPretty - -instance FieldGrammar Pretty PrettyFieldGrammar where - blurFieldGrammar f (PrettyFG pp) = PrettyFG (\v -> pp v . aview f) - - uniqueFieldAla fn _pack l = PrettyFG $ \_v s -> - ppField fn (pretty (pack' _pack (aview l s))) - - booleanFieldDef fn l def = PrettyFG pp - where - pp _v s - | b == def = mempty - | otherwise = ppField fn (PP.text (show b)) - where - b = aview l s - - optionalFieldAla fn _pack l = PrettyFG pp - where - pp v s = case aview l s of - Nothing -> mempty - Just a -> ppField fn (prettyVersioned v (pack' _pack a)) - - optionalFieldDefAla fn _pack l def = PrettyFG pp - where - pp v s - | x == def = mempty - | otherwise = ppField fn (prettyVersioned v (pack' _pack x)) - where - x = aview l s - - freeTextField fn l = PrettyFG pp where - pp v s = maybe mempty (ppField fn . showFT) (aview l s) where - showFT | v >= CabalSpecV3_0 = showFreeTextV3 - | otherwise = showFreeText - - -- it's ok to just show, as showFreeText of empty string is empty. - freeTextFieldDef fn l = PrettyFG pp where - pp v s = ppField fn (showFT (aview l s)) where - showFT | v >= CabalSpecV3_0 = showFreeTextV3 - | otherwise = showFreeText - - freeTextFieldDefST = defaultFreeTextFieldDefST - - monoidalFieldAla fn _pack l = PrettyFG pp - where - pp v s = ppField fn (prettyVersioned v (pack' _pack (aview l s))) - - prefixedFields _fnPfx l = PrettyFG (\_ -> pp . aview l) - where - pp xs = - -- always print the field, even its Doc is empty. - -- i.e. don't use ppField - [ PrettyField () (toUTF8BS n) $ PP.vcat $ map PP.text $ lines s - | (n, s) <- xs - -- fnPfx `isPrefixOf` n - ] - - knownField _ = pure () - deprecatedSince _ _ x = x - -- TODO: as PrettyFieldGrammar isn't aware of cabal-version: we output the field - -- this doesn't affect roundtrip as `removedIn` fields cannot be parsed - -- so invalid documents can be only manually constructed. - removedIn _ _ x = x - availableSince _ _ = id - hiddenField _ = PrettyFG (\_ -> mempty) - -ppField :: FieldName -> Doc -> [PrettyField ()] -ppField name fielddoc - | PP.isEmpty fielddoc = [] - | otherwise = [ PrettyField () name fielddoc ] diff --git a/src/Distribution/Fields.hs b/src/Distribution/Fields.hs deleted file mode 100644 --- a/src/Distribution/Fields.hs +++ /dev/null @@ -1,42 +0,0 @@ --- | Utilitiies to work with @.cabal@ like file structure. -module Distribution.Fields ( - -- * Types - Field(..), - Name(..), - FieldLine(..), - SectionArg(..), - FieldName, - -- * Grammar and parsing - -- - -- See "Distribution.Fields.Parser" for grammar. - readFields, - readFields', - -- ** ParseResult - ParseResult, - runParseResult, - parseString, - parseWarning, - parseWarnings, - parseFailure, - parseFatalFailure, - -- ** Warnings - PWarnType (..), - PWarning (..), - showPWarning, - -- ** Errors - PError (..), - showPError, - -- * Pretty printing - PrettyField (..), - showFields, - -- ** Transformation from Field - genericFromParsecFields, - fromParsecFields, - ) where - -import Distribution.Fields.Field -import Distribution.Fields.Parser -import Distribution.Fields.ParseResult -import Distribution.Fields.Pretty -import Distribution.Parsec.Error -import Distribution.Parsec.Warning diff --git a/src/Distribution/Fields/ConfVar.hs b/src/Distribution/Fields/ConfVar.hs deleted file mode 100644 --- a/src/Distribution/Fields/ConfVar.hs +++ /dev/null @@ -1,126 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Distribution.Fields.ConfVar (parseConditionConfVar) where - -import Distribution.Compat.CharParsing (char, integral) -import Distribution.Compat.Prelude -import Distribution.Fields.Field (SectionArg (..)) -import Distribution.Fields.ParseResult -import Distribution.Parsec (Parsec (..), Position (..), runParsecParser) -import Distribution.Parsec.FieldLineStream (fieldLineStreamFromBS) -import Distribution.Types.Condition -import Distribution.Types.ConfVar (ConfVar (..)) -import Distribution.Version - (anyVersion, earlierVersion, intersectVersionRanges, laterVersion, majorBoundVersion, - mkVersion, noVersion, orEarlierVersion, orLaterVersion, thisVersion, unionVersionRanges, - withinVersion) -import Prelude () - -import qualified Text.Parsec as P -import qualified Text.Parsec.Error as P - --- | Parse @'Condition' 'ConfVar'@ from section arguments provided by parsec --- based outline parser. -parseConditionConfVar :: [SectionArg Position] -> ParseResult (Condition ConfVar) -parseConditionConfVar args = - -- The name of the input file is irrelevant, as we reformat the error message. - case P.runParser (parser <* P.eof) () "" args of - Right x -> pure x - Left err -> do - -- Mangle the position to the actual one - let ppos = P.errorPos err - let epos = Position (P.sourceLine ppos) (P.sourceColumn ppos) - let msg = P.showErrorMessages - "or" "unknown parse error" "expecting" "unexpected" "end of input" - (P.errorMessages err) - parseFailure epos msg - pure $ Lit True - -type Parser = P.Parsec [SectionArg Position] () - -sepByNonEmpty :: Parser a -> Parser sep -> Parser (NonEmpty a) -sepByNonEmpty p sep = (:|) <$> p <*> many (sep *> p) - -parser :: Parser (Condition ConfVar) -parser = condOr - where - condOr = sepByNonEmpty condAnd (oper "||") >>= return . foldl1 COr - condAnd = sepByNonEmpty cond (oper "&&") >>= return . foldl1 CAnd - cond = P.choice - [ boolLiteral, parens condOr, notCond, osCond, archCond, flagCond, implCond ] - - notCond = CNot <$ oper "!" <*> cond - - boolLiteral = Lit <$> boolLiteral' - osCond = Var . OS <$ string "os" <*> parens fromParsec - flagCond = Var . PackageFlag <$ string "flag" <*> parens fromParsec - archCond = Var . Arch <$ string "arch" <*> parens fromParsec - implCond = Var <$ string "impl" <*> parens implCond' - - implCond' = Impl - <$> fromParsec - <*> P.option anyVersion versionRange - - version = fromParsec - versionStar = mkVersion <$> fromParsec' versionStar' <* oper "*" - versionStar' = some (integral <* char '.') - - versionRange = expr - where - expr = foldl1 unionVersionRanges <$> sepByNonEmpty term (oper "||") - term = foldl1 intersectVersionRanges <$> sepByNonEmpty factor (oper "&&") - - factor = P.choice - $ parens expr - : parseAnyVersion - : parseNoVersion - : parseWildcardRange - : map parseRangeOp rangeOps - - parseAnyVersion = anyVersion <$ string "-any" - parseNoVersion = noVersion <$ string "-none" - - parseWildcardRange = P.try $ withinVersion <$ oper "==" <*> versionStar - - parseRangeOp (s,f) = P.try (f <$ oper s <*> version) - rangeOps = [ ("<", earlierVersion), - ("<=", orEarlierVersion), - (">", laterVersion), - (">=", orLaterVersion), - ("^>=", majorBoundVersion), - ("==", thisVersion) ] - - -- Number token can have many dots in it: SecArgNum (Position 65 15) "7.6.1" - identBS = tokenPrim $ \t -> case t of - SecArgName _ s -> Just s - _ -> Nothing - - boolLiteral' = tokenPrim $ \t -> case t of - SecArgName _ s - | s == "True" -> Just True - | s == "true" -> Just True - | s == "False" -> Just False - | s == "false" -> Just False - _ -> Nothing - - string s = tokenPrim $ \t -> case t of - SecArgName _ s' | s == s' -> Just () - _ -> Nothing - - oper o = tokenPrim $ \t -> case t of - SecArgOther _ o' | o == o' -> Just () - _ -> Nothing - - parens = P.between (oper "(") (oper ")") - - tokenPrim = P.tokenPrim prettySectionArg updatePosition - -- TODO: check where the errors are reported - updatePosition x _ _ = x - prettySectionArg = show - - fromParsec :: Parsec a => Parser a - fromParsec = fromParsec' parsec - - fromParsec' p = do - bs <- identBS - let fls = fieldLineStreamFromBS bs - either (fail . show) pure (runParsecParser p "" fls) diff --git a/src/Distribution/Fields/Field.hs b/src/Distribution/Fields/Field.hs deleted file mode 100644 --- a/src/Distribution/Fields/Field.hs +++ /dev/null @@ -1,141 +0,0 @@ -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveTraversable #-} --- | Cabal-like file AST types: 'Field', 'Section' etc --- --- These types are parametrized by an annotation. -module Distribution.Fields.Field ( - -- * Cabal file - Field (..), - fieldName, - fieldAnn, - fieldUniverse, - FieldLine (..), - fieldLineAnn, - fieldLineBS, - SectionArg (..), - sectionArgAnn, - -- * Name - FieldName, - Name (..), - mkName, - getName, - nameAnn, - -- * Conversions to String - sectionArgsToString, - fieldLinesToString, - ) where - -import Data.ByteString (ByteString) -import qualified Data.ByteString.Char8 as B -import qualified Data.Char as Char -import Distribution.Compat.Prelude -import Distribution.Pretty (showTokenStr) -import Distribution.Simple.Utils (fromUTF8BS) -import Prelude () - - -------------------------------------------------------------------------------- --- Cabal file -------------------------------------------------------------------------------- - --- | A Cabal-like file consists of a series of fields (@foo: bar@) and sections (@library ...@). -data Field ann - = Field !(Name ann) [FieldLine ann] - | Section !(Name ann) [SectionArg ann] [Field ann] - deriving (Eq, Show, Functor, Foldable, Traversable) - --- | Section of field name -fieldName :: Field ann -> Name ann -fieldName (Field n _ ) = n -fieldName (Section n _ _) = n - -fieldAnn :: Field ann -> ann -fieldAnn = nameAnn . fieldName - --- | All transitive descendants of 'Field', including itself. --- --- /Note:/ the resulting list is never empty. --- -fieldUniverse :: Field ann -> [Field ann] -fieldUniverse f@(Section _ _ fs) = f : concatMap fieldUniverse fs -fieldUniverse f@(Field _ _) = [f] - --- | A line of text representing the value of a field from a Cabal file. --- A field may contain multiple lines. --- --- /Invariant:/ 'ByteString' has no newlines. -data FieldLine ann = FieldLine !ann !ByteString - deriving (Eq, Show, Functor, Foldable, Traversable) - --- | @since 3.0.0.0 -fieldLineAnn :: FieldLine ann -> ann -fieldLineAnn (FieldLine ann _) = ann - --- | @since 3.0.0.0 -fieldLineBS :: FieldLine ann -> ByteString -fieldLineBS (FieldLine _ bs) = bs - --- | Section arguments, e.g. name of the library -data SectionArg ann - = SecArgName !ann !ByteString - -- ^ identifier, or something which looks like number. Also many dot numbers, i.e. "7.6.3" - | SecArgStr !ann !ByteString - -- ^ quoted string - | SecArgOther !ann !ByteString - -- ^ everything else, mm. operators (e.g. in if-section conditionals) - deriving (Eq, Show, Functor, Foldable, Traversable) - --- | Extract annotation from 'SectionArg'. -sectionArgAnn :: SectionArg ann -> ann -sectionArgAnn (SecArgName ann _) = ann -sectionArgAnn (SecArgStr ann _) = ann -sectionArgAnn (SecArgOther ann _) = ann - -------------------------------------------------------------------------------- --- Name -------------------------------------------------------------------------------- - -type FieldName = ByteString - --- | A field name. --- --- /Invariant/: 'ByteString' is lower-case ASCII. -data Name ann = Name !ann !FieldName - deriving (Eq, Show, Functor, Foldable, Traversable) - -mkName :: ann -> FieldName -> Name ann -mkName ann bs = Name ann (B.map Char.toLower bs) - -getName :: Name ann -> FieldName -getName (Name _ bs) = bs - -nameAnn :: Name ann -> ann -nameAnn (Name ann _) = ann - -------------------------------------------------------------------------------- --- To Strings -------------------------------------------------------------------------------- - --- | --- --- @since 3.6.0.0 -sectionArgsToString :: [SectionArg ann] -> String -sectionArgsToString = unwords . map toStr where - toStr :: SectionArg ann -> String - toStr (SecArgName _ bs) = showTokenStr (fromUTF8BS bs) - toStr (SecArgStr _ bs) = showTokenStr (fromUTF8BS bs) - toStr (SecArgOther _ bs) = fromUTF8BS bs - --- | Convert @['FieldLine']@ into String. --- --- /Note:/ this doesn't preserve indentation or empty lines, --- as the annotations (e.g. positions) are ignored. --- --- @since 3.6.0.0 -fieldLinesToString :: [FieldLine ann] -> String -fieldLinesToString = - -- intercalate to avoid trailing newline. - intercalate "\n" . map toStr - where - toStr (FieldLine _ bs) = fromUTF8BS bs diff --git a/src/Distribution/Fields/Lexer.hs b/src/Distribution/Fields/Lexer.hs deleted file mode 100644 --- a/src/Distribution/Fields/Lexer.hs +++ /dev/null @@ -1,496 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-missing-signatures #-} -{-# LANGUAGE CPP,MagicHash #-} -{-# LINE 1 "templates/Lexer.x" #-} - ------------------------------------------------------------------------------ --- | --- Module : Distribution.Fields.Lexer --- License : BSD3 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- Lexer for the cabal files. -{-# LANGUAGE CPP #-} -{-# LANGUAGE BangPatterns #-} -#ifdef CABAL_PARSEC_DEBUG -{-# LANGUAGE PatternGuards #-} -#endif -{-# OPTIONS_GHC -fno-warn-unused-imports #-} -module Distribution.Fields.Lexer - (ltest, lexToken, Token(..), LToken(..) - ,bol_section, in_section, in_field_layout, in_field_braces - ,mkLexState) where - --- [Note: boostrapping parsec parser] --- --- We manually produce the `Lexer.hs` file from `boot/Lexer.x` (make lexer) --- because boostrapping cabal-install would be otherwise tricky. --- Alex is (atm) tricky package to build, cabal-install has some magic --- to move bundled generated files in place, so rather we don't depend --- on it before we can build it ourselves. --- Therefore there is one thing less to worry in bootstrap.sh, which is a win. --- --- See also https://github.com/haskell/cabal/issues/4633 --- - -import Prelude () -import qualified Prelude as Prelude -import Distribution.Compat.Prelude - -import Distribution.Fields.LexerMonad -import Distribution.Parsec.Position (Position (..), incPos, retPos) -import Data.ByteString (ByteString) -import qualified Data.ByteString as B -import qualified Data.ByteString.Char8 as B.Char8 -import qualified Data.Word as Word - -#ifdef CABAL_PARSEC_DEBUG -import Debug.Trace -import qualified Data.Vector as V -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Data.Text.Encoding.Error as T -#endif - -#if __GLASGOW_HASKELL__ >= 603 -#include "ghcconfig.h" -#elif defined(__GLASGOW_HASKELL__) -#include "config.h" -#endif -#if __GLASGOW_HASKELL__ >= 503 -import Data.Array -#else -import Array -#endif -#if __GLASGOW_HASKELL__ >= 503 -import Data.Array.Base (unsafeAt) -import GHC.Exts -#else -import GlaExts -#endif -alex_tab_size :: Int -alex_tab_size = 8 -alex_base :: AlexAddr -alex_base = AlexA# - "\x12\xff\xff\xff\xf9\xff\xff\xff\xfb\xff\xff\xff\x01\x00\x00\x00\x2f\x00\x00\x00\x50\x00\x00\x00\xd0\x00\x00\x00\x48\xff\xff\xff\xdc\xff\xff\xff\x51\xff\xff\xff\x6d\xff\xff\xff\x6f\xff\xff\xff\x50\x01\x00\x00\x74\x01\x00\x00\x70\xff\xff\xff\x68\x00\x00\x00\x09\x00\x00\x00\x00\x00\x00\x00\x07\x00\x00\x00\xa3\x01\x00\x00\x0b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6a\x00\x00\x00\xd1\x01\x00\x00\xfb\x01\x00\x00\x7b\x02\x00\x00\xfb\x02\x00\x00\x00\x00\x00\x00\x7b\x03\x00\x00\x7d\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x6d\x00\x00\x00\x6b\x00\x00\x00\xfc\x03\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x6f\x00\x00\x00\x1c\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00"# - -alex_table :: AlexAddr -alex_table = AlexA# - "\x00\x00\x09\x00\x0f\x00\x11\x00\x02\x00\x11\x00\x12\x00\x00\x00\x12\x00\x13\x00\x03\x00\x11\x00\x07\x00\x10\x00\x12\x00\x25\x00\x14\x00\x11\x00\x10\x00\x11\x00\x14\x00\x11\x00\x12\x00\x23\x00\x12\x00\x0f\x00\x28\x00\x02\x00\x2e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x08\x00\x10\x00\x00\x00\x14\x00\x00\x00\x00\x00\x08\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2a\x00\x2e\x00\xff\xff\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x26\x00\x28\x00\xff\xff\xff\xff\x29\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x26\x00\x0f\x00\x11\x00\x17\x00\x26\x00\x12\x00\x25\x00\x11\x00\x2a\x00\x00\x00\x12\x00\x00\x00\x15\x00\x00\x00\x16\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0f\x00\x00\x00\x17\x00\x26\x00\x00\x00\x25\x00\x00\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x00\x00\x2d\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x00\x00\x0b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x00\x00\x0e\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x17\x00\x23\x00\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x17\x00\x1e\x00\x0d\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x00\x00\x1f\x00\x1f\x00\x1e\x00\x1e\x00\x1e\x00\x19\x00\x1a\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x1f\x00\x1e\x00\x1f\x00\x1e\x00\x0b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x21\x00\x1e\x00\x22\x00\x1e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x1d\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x1c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x0c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1e\x00\xff\xff\x1e\x00\x1e\x00\x1e\x00\x1e\x00\xff\xff\xff\xff\xff\xff\x1e\x00\x1e\x00\x1e\x00\x18\x00\x1a\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x1e\x00\xff\xff\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x1e\x00\xff\xff\x1e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1e\x00\xff\xff\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x00\x00\xff\xff\xff\xff\x1e\x00\x1e\x00\x1e\x00\x1a\x00\x1a\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x1e\x00\xff\xff\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x1e\x00\xff\xff\x1e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x1c\x00\x1e\x00\x00\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x00\x00\x00\x1e\x00\x00\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1e\x00\xff\xff\x1e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# - -alex_check :: AlexAddr -alex_check = AlexA# - "\xff\xff\xef\x00\x09\x00\x0a\x00\x09\x00\x0a\x00\x0d\x00\xbf\x00\x0d\x00\x2d\x00\x09\x00\x0a\x00\xbb\x00\xa0\x00\x0d\x00\xa0\x00\xa0\x00\x0a\x00\x09\x00\x0a\x00\x09\x00\x0a\x00\x0d\x00\x0a\x00\x0d\x00\x20\x00\x0a\x00\x20\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x00\xff\xff\x2d\x00\x20\x00\xff\xff\x20\x00\xff\xff\xff\xff\x2d\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x09\x00\x0a\x00\x09\x00\x09\x00\x0d\x00\x09\x00\x0a\x00\x09\x00\xff\xff\x0d\x00\xff\xff\x7b\x00\xff\xff\x7d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\x20\x00\x20\x00\xff\xff\x20\x00\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\xff\xff\x7d\x00\xff\xff\x7f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc2\x00\xff\xff\xc2\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc2\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc2\x00\xff\xff\xc2\x00\xff\xff\x7f\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc2\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xc2\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\xff\xff\xff\xff\x22\x00\xff\xff\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\xff\xff\xff\xff\x22\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x5c\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7f\x00\x5c\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\xff\xff\xff\xff\x7f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x7f\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\xff\xff\xff\xff\x22\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\x7f\x00\x7e\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\xff\xff\x7d\x00\xff\xff\x7f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# - -alex_deflt :: AlexAddr -alex_deflt = AlexA# - "\xff\xff\xff\xff\xff\xff\xff\xff\x2b\x00\x27\x00\x1b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0d\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x13\x00\xff\xff\xff\xff\xff\xff\xff\xff\x18\x00\x1b\x00\x1b\x00\x1b\x00\xff\xff\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\x2b\x00\xff\xff\xff\xff\xff\xff\xff\xff"# - -alex_accept = listArray (0 :: Int, 47) - [ AlexAcc 29 - , AlexAcc 28 - , AlexAcc 27 - , AlexAcc 26 - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAcc 25 - , AlexAcc 24 - , AlexAccSkip - , AlexAcc 23 - , AlexAcc 22 - , AlexAcc 21 - , AlexAccSkip - , AlexAccSkip - , AlexAcc 20 - , AlexAcc 19 - , AlexAcc 18 - , AlexAcc 17 - , AlexAcc 16 - , AlexAcc 15 - , AlexAcc 14 - , AlexAcc 13 - , AlexAcc 12 - , AlexAcc 11 - , AlexAcc 10 - , AlexAcc 9 - , AlexAcc 8 - , AlexAccSkip - , AlexAcc 7 - , AlexAcc 6 - , AlexAcc 5 - , AlexAccSkip - , AlexAcc 4 - , AlexAcc 3 - , AlexAcc 2 - , AlexAcc 1 - , AlexAcc 0 - ] - -alex_actions = array (0 :: Int, 30) - [ (29,alex_action_0) - , (28,alex_action_20) - , (27,alex_action_16) - , (26,alex_action_3) - , (25,alex_action_1) - , (24,alex_action_1) - , (23,alex_action_3) - , (22,alex_action_4) - , (21,alex_action_5) - , (20,alex_action_8) - , (19,alex_action_8) - , (18,alex_action_8) - , (17,alex_action_9) - , (16,alex_action_9) - , (15,alex_action_10) - , (14,alex_action_11) - , (13,alex_action_12) - , (12,alex_action_13) - , (11,alex_action_14) - , (10,alex_action_15) - , (9,alex_action_15) - , (8,alex_action_16) - , (7,alex_action_18) - , (6,alex_action_19) - , (5,alex_action_19) - , (4,alex_action_22) - , (3,alex_action_23) - , (2,alex_action_24) - , (1,alex_action_25) - , (0,alex_action_25) - ] - -{-# LINE 151 "templates/Lexer.x" #-} - --- | Tokens of outer cabal file structure. Field values are treated opaquely. -data Token = TokSym !ByteString -- ^ Haskell-like identifier, number or operator - | TokStr !ByteString -- ^ String in quotes - | TokOther !ByteString -- ^ Operators and parens - | Indent !Int -- ^ Indentation token - | TokFieldLine !ByteString -- ^ Lines after @:@ - | Colon - | OpenBrace - | CloseBrace - | EOF - | LexicalError InputStream --TODO: add separate string lexical error - deriving Show - -data LToken = L !Position !Token - deriving Show - -toki :: (ByteString -> Token) -> Position -> Int -> ByteString -> Lex LToken -toki t pos len input = return $! L pos (t (B.take len input)) - -tok :: Token -> Position -> Int -> ByteString -> Lex LToken -tok t pos _len _input = return $! L pos t - -checkLeadingWhitespace :: Int -> ByteString -> Lex Int -checkLeadingWhitespace len bs - | B.any (== 9) (B.take len bs) = do - addWarning LexWarningTab - checkWhitespace len bs - | otherwise = checkWhitespace len bs - -checkWhitespace :: Int -> ByteString -> Lex Int -checkWhitespace len bs - | B.any (== 194) (B.take len bs) = do - addWarning LexWarningNBSP - return $ len - B.count 194 (B.take len bs) - | otherwise = return len - --- ----------------------------------------------------------------------------- --- The input type - -type AlexInput = InputStream - -alexInputPrevChar :: AlexInput -> Char -alexInputPrevChar _ = error "alexInputPrevChar not used" - -alexGetByte :: AlexInput -> Maybe (Word.Word8,AlexInput) -alexGetByte = B.uncons - -lexicalError :: Position -> InputStream -> Lex LToken -lexicalError pos inp = do - setInput B.empty - return $! L pos (LexicalError inp) - -lexToken :: Lex LToken -lexToken = do - pos <- getPos - inp <- getInput - st <- getStartCode - case alexScan inp st of - AlexEOF -> return (L pos EOF) - AlexError inp' -> - let !len_bytes = B.length inp - B.length inp' in - --FIXME: we want len_chars here really - -- need to decode utf8 up to this point - lexicalError (incPos len_bytes pos) inp' - AlexSkip inp' len_chars -> do - checkPosition pos inp inp' len_chars - adjustPos (incPos len_chars) - setInput inp' - lexToken - AlexToken inp' len_chars action -> do - checkPosition pos inp inp' len_chars - adjustPos (incPos len_chars) - setInput inp' - let !len_bytes = B.length inp - B.length inp' - t <- action pos len_bytes inp - --traceShow t $ return tok - return t - -checkPosition :: Position -> ByteString -> ByteString -> Int -> Lex () -#ifdef CABAL_PARSEC_DEBUG -checkPosition pos@(Position lineno colno) inp inp' len_chars = do - text_lines <- getDbgText - let len_bytes = B.length inp - B.length inp' - pos_txt | lineno-1 < V.length text_lines = T.take len_chars (T.drop (colno-1) (text_lines V.! (lineno-1))) - | otherwise = T.empty - real_txt = B.take len_bytes inp - when (pos_txt /= T.decodeUtf8 real_txt) $ - traceShow (pos, pos_txt, T.decodeUtf8 real_txt) $ - traceShow (take 3 (V.toList text_lines)) $ return () - where - getDbgText = Lex $ \s@LexState{ dbgText = txt } -> LexResult s txt -#else -checkPosition _ _ _ _ = return () -#endif - -lexAll :: Lex [LToken] -lexAll = do - t <- lexToken - case t of - L _ EOF -> return [t] - _ -> do ts <- lexAll - return (t : ts) - -ltest :: Int -> String -> Prelude.IO () -ltest code s = - let (ws, xs) = execLexer (setStartCode code >> lexAll) (B.Char8.pack s) - in traverse_ print ws >> traverse_ print xs - -mkLexState :: ByteString -> LexState -mkLexState input = LexState - { curPos = Position 1 1 - , curInput = input - , curCode = 0 - , warnings = [] -#ifdef CABAL_PARSEC_DEBUG - , dbgText = V.fromList . lines' . T.decodeUtf8With T.lenientDecode $ input -#endif - } - -#ifdef CABAL_PARSEC_DEBUG -lines' :: T.Text -> [T.Text] -lines' s1 - | T.null s1 = [] - | otherwise = case T.break (\c -> c == '\r' || c == '\n') s1 of - (l, s2) | Just (c,s3) <- T.uncons s2 - -> case T.uncons s3 of - Just ('\n', s4) | c == '\r' -> l `T.snoc` '\r' `T.snoc` '\n' : lines' s4 - _ -> l `T.snoc` c : lines' s3 - - | otherwise - -> [l] -#endif - -bol_field_braces,bol_field_layout,bol_section,in_field_braces,in_field_layout,in_section :: Int -bol_field_braces = 1 -bol_field_layout = 2 -bol_section = 3 -in_field_braces = 4 -in_field_layout = 5 -in_section = 6 -alex_action_0 = \_ len _ -> do - when (len /= 0) $ addWarning LexWarningBOM - setStartCode bol_section - lexToken - -alex_action_1 = \_pos len inp -> checkWhitespace len inp >> adjustPos retPos >> lexToken -alex_action_3 = \pos len inp -> checkLeadingWhitespace len inp >> - if B.length inp == len - then return (L pos EOF) - else setStartCode in_section - >> return (L pos (Indent len)) -alex_action_4 = tok OpenBrace -alex_action_5 = tok CloseBrace -alex_action_8 = toki TokSym -alex_action_9 = \pos len inp -> return $! L pos (TokStr (B.take (len - 2) (B.tail inp))) -alex_action_10 = toki TokOther -alex_action_11 = toki TokOther -alex_action_12 = tok Colon -alex_action_13 = tok OpenBrace -alex_action_14 = tok CloseBrace -alex_action_15 = \_ _ _ -> adjustPos retPos >> setStartCode bol_section >> lexToken -alex_action_16 = \pos len inp -> checkLeadingWhitespace len inp >>= \len' -> - if B.length inp == len - then return (L pos EOF) - else setStartCode in_field_layout - >> return (L pos (Indent len')) -alex_action_18 = toki TokFieldLine -alex_action_19 = \_ _ _ -> adjustPos retPos >> setStartCode bol_field_layout >> lexToken -alex_action_20 = \_ _ _ -> setStartCode in_field_braces >> lexToken -alex_action_22 = toki TokFieldLine -alex_action_23 = tok OpenBrace -alex_action_24 = tok CloseBrace -alex_action_25 = \_ _ _ -> adjustPos retPos >> setStartCode bol_field_braces >> lexToken -{-# LINE 1 "templates/GenericTemplate.hs" #-} --- ----------------------------------------------------------------------------- --- ALEX TEMPLATE --- --- This code is in the PUBLIC DOMAIN; you may copy it freely and use --- it for any purpose whatsoever. - --- ----------------------------------------------------------------------------- --- INTERNALS and main scanner engine - --- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex. -#if __GLASGOW_HASKELL__ > 706 -#define GTE(n,m) (tagToEnum# (n >=# m)) -#define EQ(n,m) (tagToEnum# (n ==# m)) -#else -#define GTE(n,m) (n >=# m) -#define EQ(n,m) (n ==# m) -#endif - -data AlexAddr = AlexA# Addr# --- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex. -#if __GLASGOW_HASKELL__ < 503 -uncheckedShiftL# = shiftL# -#endif - -{-# INLINE alexIndexInt16OffAddr #-} -alexIndexInt16OffAddr :: AlexAddr -> Int# -> Int# -alexIndexInt16OffAddr (AlexA# arr) off = -#ifdef WORDS_BIGENDIAN - narrow16Int# i - where - i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low) - high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) - low = int2Word# (ord# (indexCharOffAddr# arr off')) - off' = off *# 2# -#else -#if __GLASGOW_HASKELL__ >= 901 - int16ToInt# -#endif - (indexInt16OffAddr# arr off) -#endif - -{-# INLINE alexIndexInt32OffAddr #-} -alexIndexInt32OffAddr :: AlexAddr -> Int# -> Int# -alexIndexInt32OffAddr (AlexA# arr) off = -#ifdef WORDS_BIGENDIAN - narrow32Int# i - where - i = word2Int# ((b3 `uncheckedShiftL#` 24#) `or#` - (b2 `uncheckedShiftL#` 16#) `or#` - (b1 `uncheckedShiftL#` 8#) `or#` b0) - b3 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 3#))) - b2 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 2#))) - b1 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) - b0 = int2Word# (ord# (indexCharOffAddr# arr off')) - off' = off *# 4# -#else -#if __GLASGOW_HASKELL__ >= 901 - int32ToInt# -#endif - (indexInt32OffAddr# arr off) -#endif - -#if __GLASGOW_HASKELL__ < 503 -quickIndex arr i = arr ! i -#else --- GHC >= 503, unsafeAt is available from Data.Array.Base. -quickIndex = unsafeAt -#endif - --- ----------------------------------------------------------------------------- --- Main lexing routines - -data AlexReturn a - = AlexEOF - | AlexError !AlexInput - | AlexSkip !AlexInput !Int - | AlexToken !AlexInput !Int a - --- alexScan :: AlexInput -> StartCode -> AlexReturn a -alexScan input__ (I# (sc)) - = alexScanUser undefined input__ (I# (sc)) - -alexScanUser user__ input__ (I# (sc)) - = case alex_scan_tkn user__ input__ 0# input__ sc AlexNone of - (AlexNone, input__') -> - case alexGetByte input__ of - Nothing -> - - AlexEOF - Just _ -> - - AlexError input__' - - (AlexLastSkip input__'' len, _) -> - - AlexSkip input__'' len - - (AlexLastAcc k input__''' len, _) -> - - AlexToken input__''' len (alex_actions ! k) - --- Push the input through the DFA, remembering the most recent accepting --- state it encountered. - -alex_scan_tkn user__ orig_input len input__ s last_acc = - input__ `seq` -- strict in the input - let - new_acc = (check_accs (alex_accept `quickIndex` (I# (s)))) - in - new_acc `seq` - case alexGetByte input__ of - Nothing -> (new_acc, input__) - Just (c, new_input) -> - - case fromIntegral c of { (I# (ord_c)) -> - let - base = alexIndexInt32OffAddr alex_base s - offset = (base +# ord_c) - check = alexIndexInt16OffAddr alex_check offset - - new_s = if GTE(offset,0#) && EQ(check,ord_c) - then alexIndexInt16OffAddr alex_table offset - else alexIndexInt16OffAddr alex_deflt s - in - case new_s of - -1# -> (new_acc, input__) - -- on an error, we want to keep the input *before* the - -- character that failed, not after. - _ -> alex_scan_tkn user__ orig_input (if c < 0x80 || c >= 0xC0 then (len +# 1#) else len) - -- note that the length is increased ONLY if this is the 1st byte in a char encoding) - new_input new_s new_acc - } - where - check_accs (AlexAccNone) = last_acc - check_accs (AlexAcc a ) = AlexLastAcc a input__ (I# (len)) - check_accs (AlexAccSkip) = AlexLastSkip input__ (I# (len)) - -data AlexLastAcc - = AlexNone - | AlexLastAcc !Int !AlexInput !Int - | AlexLastSkip !AlexInput !Int - -data AlexAcc user - = AlexAccNone - | AlexAcc Int - | AlexAccSkip - diff --git a/src/Distribution/Fields/LexerMonad.hs b/src/Distribution/Fields/LexerMonad.hs deleted file mode 100644 --- a/src/Distribution/Fields/LexerMonad.hs +++ /dev/null @@ -1,155 +0,0 @@ -{-# LANGUAGE CPP #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Fields.LexerMonad --- License : BSD3 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable -module Distribution.Fields.LexerMonad ( - InputStream, - LexState(..), - LexResult(..), - - Lex(..), - execLexer, - - getPos, - setPos, - adjustPos, - - getInput, - setInput, - - getStartCode, - setStartCode, - - LexWarning(..), - LexWarningType(..), - addWarning, - toPWarnings, - - ) where - -import qualified Data.ByteString as B -import qualified Data.List.NonEmpty as NE -import Distribution.Compat.Prelude -import Distribution.Parsec.Position (Position (..), showPos) -import Distribution.Parsec.Warning (PWarnType (..), PWarning (..)) -import Prelude () - -import qualified Data.Map.Strict as Map - -#ifdef CABAL_PARSEC_DEBUG --- testing only: -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Data.Vector as V -#endif - --- simple state monad -newtype Lex a = Lex { unLex :: LexState -> LexResult a } - -instance Functor Lex where - fmap = liftM - -instance Applicative Lex where - pure = returnLex - (<*>) = ap - -instance Monad Lex where - return = pure - (>>=) = thenLex - -data LexResult a = LexResult {-# UNPACK #-} !LexState a - -data LexWarningType - = LexWarningNBSP -- ^ Encountered non breaking space - | LexWarningBOM -- ^ BOM at the start of the cabal file - | LexWarningTab -- ^ Leading tags - deriving (Eq, Ord, Show) - -data LexWarning = LexWarning !LexWarningType - {-# UNPACK #-} !Position - deriving (Show) - -toPWarnings :: [LexWarning] -> [PWarning] -toPWarnings - = map (uncurry toWarning) - . Map.toList - . Map.fromListWith (<>) - . map (\(LexWarning t p) -> (t, pure p)) - where - toWarning LexWarningBOM poss = - PWarning PWTLexBOM (NE.head poss) "Byte-order mark found at the beginning of the file" - toWarning LexWarningNBSP poss = - PWarning PWTLexNBSP (NE.head poss) $ "Non breaking spaces at " ++ intercalate ", " (NE.toList $ fmap showPos poss) - toWarning LexWarningTab poss = - PWarning PWTLexTab (NE.head poss) $ "Tabs used as indentation at " ++ intercalate ", " (NE.toList $ fmap showPos poss) - -data LexState = LexState { - curPos :: {-# UNPACK #-} !Position, -- ^ position at current input location - curInput :: {-# UNPACK #-} !InputStream, -- ^ the current input - curCode :: {-# UNPACK #-} !StartCode, -- ^ lexer code - warnings :: [LexWarning] -#ifdef CABAL_PARSEC_DEBUG - , dbgText :: V.Vector T.Text -- ^ input lines, to print pretty debug info -#endif - } --TODO: check if we should cache the first token - -- since it looks like parsec's uncons can be called many times on the same input - -type StartCode = Int -- ^ An @alex@ lexer start code -type InputStream = B.ByteString - - - --- | Execute the given lexer on the supplied input stream. -execLexer :: Lex a -> InputStream -> ([LexWarning], a) -execLexer (Lex lexer) input = - case lexer initialState of - LexResult LexState{ warnings = ws } result -> (ws, result) - where - initialState = LexState - -- TODO: add 'startPosition' - { curPos = Position 1 1 - , curInput = input - , curCode = 0 - , warnings = [] -#ifdef CABAL_PARSEC_DEBUG - , dbgText = V.fromList . T.lines . T.decodeUtf8 $ input -#endif - } - -{-# INLINE returnLex #-} -returnLex :: a -> Lex a -returnLex a = Lex $ \s -> LexResult s a - -{-# INLINE thenLex #-} -thenLex :: Lex a -> (a -> Lex b) -> Lex b -(Lex m) `thenLex` k = Lex $ \s -> case m s of LexResult s' a -> (unLex (k a)) s' - -setPos :: Position -> Lex () -setPos pos = Lex $ \s -> LexResult s{ curPos = pos } () - -getPos :: Lex Position -getPos = Lex $ \s@LexState{ curPos = pos } -> LexResult s pos - -adjustPos :: (Position -> Position) -> Lex () -adjustPos f = Lex $ \s@LexState{ curPos = pos } -> LexResult s{ curPos = f pos } () - -getInput :: Lex InputStream -getInput = Lex $ \s@LexState{ curInput = i } -> LexResult s i - -setInput :: InputStream -> Lex () -setInput i = Lex $ \s -> LexResult s{ curInput = i } () - -getStartCode :: Lex Int -getStartCode = Lex $ \s@LexState{ curCode = c } -> LexResult s c - -setStartCode :: Int -> Lex () -setStartCode c = Lex $ \s -> LexResult s{ curCode = c } () - --- | Add warning at the current position -addWarning :: LexWarningType -> Lex () -addWarning wt = Lex $ \s@LexState{ curPos = pos, warnings = ws } -> - LexResult s{ warnings = LexWarning wt pos : ws } () diff --git a/src/Distribution/Fields/ParseResult.hs b/src/Distribution/Fields/ParseResult.hs deleted file mode 100644 --- a/src/Distribution/Fields/ParseResult.hs +++ /dev/null @@ -1,196 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} --- | A parse result type for parsers from AST to Haskell types. -module Distribution.Fields.ParseResult ( - ParseResult, - runParseResult, - recoverWith, - parseWarning, - parseWarnings, - parseFailure, - parseFatalFailure, - parseFatalFailure', - getCabalSpecVersion, - setCabalSpecVersion, - readAndParseFile, - parseString, - withoutWarnings, - ) where - -import qualified Data.ByteString.Char8 as BS -import Distribution.Compat.Prelude -import Distribution.Parsec.Error (PError (..), showPError) -import Distribution.Parsec.Position (Position (..), zeroPos) -import Distribution.Parsec.Warning (PWarnType (..), PWarning (..), showPWarning) -import Distribution.Simple.Utils (die', warn) -import Distribution.Verbosity (Verbosity) -import Distribution.Version (Version) -import Prelude () -import System.Directory (doesFileExist) - -#if MIN_VERSION_base(4,10,0) -import Control.Applicative (Applicative (..)) -#endif - --- | A monad with failure and accumulating errors and warnings. -newtype ParseResult a = PR - { unPR - :: forall r. PRState - -> (PRState -> r) -- failure, but we were able to recover a new-style spec-version declaration - -> (PRState -> a -> r) -- success - -> r - } - --- Note: we have version here, as we could get any version. -data PRState = PRState ![PWarning] ![PError] !(Maybe Version) - -emptyPRState :: PRState -emptyPRState = PRState [] [] Nothing - --- | Forget 'ParseResult's warnings. --- --- @since 3.4.0.0 -withoutWarnings :: ParseResult a -> ParseResult a -withoutWarnings m = PR $ \s failure success -> - unPR m s failure $ \ !s1 -> success (s1 `withWarningsOf` s) - where - withWarningsOf (PRState _ e v) (PRState w _ _) = PRState w e v - --- | Destruct a 'ParseResult' into the emitted warnings and either --- a successful value or --- list of errors and possibly recovered a spec-version declaration. -runParseResult :: ParseResult a -> ([PWarning], Either (Maybe Version, NonEmpty PError) a) -runParseResult pr = unPR pr emptyPRState failure success - where - failure (PRState warns [] v) = (warns, Left (v, PError zeroPos "panic" :| [])) - failure (PRState warns (err:errs) v) = (warns, Left (v, err :| errs)) where - success (PRState warns [] _) x = (warns, Right x) - -- If there are any errors, don't return the result - success (PRState warns (err:errs) v) _ = (warns, Left (v, err :| errs)) - -instance Functor ParseResult where - fmap f (PR pr) = PR $ \ !s failure success -> - pr s failure $ \ !s' a -> - success s' (f a) - {-# INLINE fmap #-} - -instance Applicative ParseResult where - pure x = PR $ \ !s _ success -> success s x - {-# INLINE pure #-} - - f <*> x = PR $ \ !s0 failure success -> - unPR f s0 failure $ \ !s1 f' -> - unPR x s1 failure $ \ !s2 x' -> - success s2 (f' x') - {-# INLINE (<*>) #-} - - x *> y = PR $ \ !s0 failure success -> - unPR x s0 failure $ \ !s1 _ -> - unPR y s1 failure success - {-# INLINE (*>) #-} - - x <* y = PR $ \ !s0 failure success -> - unPR x s0 failure $ \ !s1 x' -> - unPR y s1 failure $ \ !s2 _ -> - success s2 x' - {-# INLINE (<*) #-} - -#if MIN_VERSION_base(4,10,0) - liftA2 f x y = PR $ \ !s0 failure success -> - unPR x s0 failure $ \ !s1 x' -> - unPR y s1 failure $ \ !s2 y' -> - success s2 (f x' y') - {-# INLINE liftA2 #-} -#endif - -instance Monad ParseResult where - return = pure - (>>) = (*>) - - m >>= k = PR $ \ !s failure success -> - unPR m s failure $ \ !s' a -> - unPR (k a) s' failure success - {-# INLINE (>>=) #-} - --- | "Recover" the parse result, so we can proceed parsing. --- 'runParseResult' will still result in 'Nothing', if there are recorded errors. -recoverWith :: ParseResult a -> a -> ParseResult a -recoverWith (PR pr) x = PR $ \ !s _failure success -> - pr s (\ !s' -> success s' x) success - --- | Set cabal spec version. -setCabalSpecVersion :: Maybe Version -> ParseResult () -setCabalSpecVersion v = PR $ \(PRState warns errs _) _failure success -> - success (PRState warns errs v) () - --- | Get cabal spec version. -getCabalSpecVersion :: ParseResult (Maybe Version) -getCabalSpecVersion = PR $ \s@(PRState _ _ v) _failure success -> - success s v - --- | Add a warning. This doesn't fail the parsing process. -parseWarning :: Position -> PWarnType -> String -> ParseResult () -parseWarning pos t msg = PR $ \(PRState warns errs v) _failure success -> - success (PRState (PWarning t pos msg : warns) errs v) () - --- | Add multiple warnings at once. -parseWarnings :: [PWarning] -> ParseResult () -parseWarnings newWarns = PR $ \(PRState warns errs v) _failure success -> - success (PRState (newWarns ++ warns) errs v) () - --- | Add an error, but not fail the parser yet. --- --- For fatal failure use 'parseFatalFailure' -parseFailure :: Position -> String -> ParseResult () -parseFailure pos msg = PR $ \(PRState warns errs v) _failure success -> - success (PRState warns (PError pos msg : errs) v) () - --- | Add an fatal error. -parseFatalFailure :: Position -> String -> ParseResult a -parseFatalFailure pos msg = PR $ \(PRState warns errs v) failure _success -> - failure (PRState warns (PError pos msg : errs) v) - --- | A 'mzero'. -parseFatalFailure' :: ParseResult a -parseFatalFailure' = PR pr - where - pr (PRState warns [] v) failure _success = failure (PRState warns [err] v) - pr s failure _success = failure s - - err = PError zeroPos "Unknown fatal error" - --- | Helper combinator to do parsing plumbing for files. --- --- Given a parser and a filename, return the parse of the file, --- after checking if the file exists. --- --- Argument order is chosen to encourage partial application. -readAndParseFile - :: (BS.ByteString -> ParseResult a) -- ^ File contents to final value parser - -> Verbosity -- ^ Verbosity level - -> FilePath -- ^ File to read - -> IO a -readAndParseFile parser verbosity fpath = do - exists <- doesFileExist fpath - unless exists $ - die' verbosity $ - "Error Parsing: file \"" ++ fpath ++ "\" doesn't exist. Cannot continue." - bs <- BS.readFile fpath - parseString parser verbosity fpath bs - -parseString - :: (BS.ByteString -> ParseResult a) -- ^ File contents to final value parser - -> Verbosity -- ^ Verbosity level - -> String -- ^ File name - -> BS.ByteString - -> IO a -parseString parser verbosity name bs = do - let (warnings, result) = runParseResult (parser bs) - traverse_ (warn verbosity . showPWarning name) warnings - case result of - Right x -> return x - Left (_, errors) -> do - traverse_ (warn verbosity . showPError name) errors - die' verbosity $ "Failed parsing \"" ++ name ++ "\"." diff --git a/src/Distribution/Fields/Parser.hs b/src/Distribution/Fields/Parser.hs deleted file mode 100644 --- a/src/Distribution/Fields/Parser.hs +++ /dev/null @@ -1,377 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternGuards #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Fields.Parser --- License : BSD3 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable -module Distribution.Fields.Parser ( - -- * Types - Field(..), - Name(..), - FieldLine(..), - SectionArg(..), - -- * Grammar and parsing - -- $grammar - readFields, - readFields', -#ifdef CABAL_PARSEC_DEBUG - -- * Internal - parseFile, - parseStr, - parseBS, -#endif - ) where - -import qualified Data.ByteString.Char8 as B8 -import Data.Functor.Identity -import Distribution.Compat.Prelude -import Distribution.Fields.Field -import Distribution.Fields.Lexer -import Distribution.Fields.LexerMonad - (LexResult (..), LexState (..), LexWarning (..), unLex) -import Distribution.Parsec.Position (Position (..)) -import Prelude () -import Text.Parsec.Combinator hiding (eof, notFollowedBy) -import Text.Parsec.Error -import Text.Parsec.Pos -import Text.Parsec.Prim hiding (many, (<|>)) - -#ifdef CABAL_PARSEC_DEBUG -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Data.Text.Encoding.Error as T -#endif - --- | The 'LexState'' (with a prime) is an instance of parsec's 'Stream' --- wrapped around lexer's 'LexState' (without a prime) -data LexState' = LexState' !LexState (LToken, LexState') - -mkLexState' :: LexState -> LexState' -mkLexState' st = LexState' st - (case unLex lexToken st of LexResult st' tok -> (tok, mkLexState' st')) - -type Parser a = ParsecT LexState' () Identity a - -instance Stream LexState' Identity LToken where - uncons (LexState' _ (tok, st')) = - case tok of - L _ EOF -> return Nothing - _ -> return (Just (tok, st')) - --- | Get lexer warnings accumulated so far -getLexerWarnings :: Parser [LexWarning] -getLexerWarnings = do - LexState' (LexState { warnings = ws }) _ <- getInput - return ws - --- | Set Alex code i.e. the mode "state" lexer is in. -setLexerMode :: Int -> Parser () -setLexerMode code = do - LexState' ls _ <- getInput - setInput $! mkLexState' ls { curCode = code } - -getToken :: (Token -> Maybe a) -> Parser a -getToken getTok = getTokenWithPos (\(L _ t) -> getTok t) - -getTokenWithPos :: (LToken -> Maybe a) -> Parser a -getTokenWithPos getTok = tokenPrim (\(L _ t) -> describeToken t) updatePos getTok - where - updatePos :: SourcePos -> LToken -> LexState' -> SourcePos - updatePos pos (L (Position col line) _) _ = newPos (sourceName pos) col line - -describeToken :: Token -> String -describeToken t = case t of - TokSym s -> "symbol " ++ show s - TokStr s -> "string " ++ show s - TokOther s -> "operator " ++ show s - Indent _ -> "new line" - TokFieldLine _ -> "field content" - Colon -> "\":\"" - OpenBrace -> "\"{\"" - CloseBrace -> "\"}\"" --- SemiColon -> "\";\"" - EOF -> "end of file" - LexicalError is -> "character in input " ++ show (B8.head is) - -tokSym :: Parser (Name Position) -tokSym', tokStr, tokOther :: Parser (SectionArg Position) -tokIndent :: Parser Int -tokColon, tokOpenBrace, tokCloseBrace :: Parser () -tokFieldLine :: Parser (FieldLine Position) - -tokSym = getTokenWithPos $ \t -> case t of L pos (TokSym x) -> Just (mkName pos x); _ -> Nothing -tokSym' = getTokenWithPos $ \t -> case t of L pos (TokSym x) -> Just (SecArgName pos x); _ -> Nothing -tokStr = getTokenWithPos $ \t -> case t of L pos (TokStr x) -> Just (SecArgStr pos x); _ -> Nothing -tokOther = getTokenWithPos $ \t -> case t of L pos (TokOther x) -> Just (SecArgOther pos x); _ -> Nothing -tokIndent = getToken $ \t -> case t of Indent x -> Just x; _ -> Nothing -tokColon = getToken $ \t -> case t of Colon -> Just (); _ -> Nothing -tokOpenBrace = getToken $ \t -> case t of OpenBrace -> Just (); _ -> Nothing -tokCloseBrace = getToken $ \t -> case t of CloseBrace -> Just (); _ -> Nothing -tokFieldLine = getTokenWithPos $ \t -> case t of L pos (TokFieldLine s) -> Just (FieldLine pos s); _ -> Nothing - -colon, openBrace, closeBrace :: Parser () - -sectionArg :: Parser (SectionArg Position) -sectionArg = tokSym' <|> tokStr <|> tokOther "section parameter" - -fieldSecName :: Parser (Name Position) -fieldSecName = tokSym "field or section name" - -colon = tokColon "\":\"" -openBrace = tokOpenBrace "\"{\"" -closeBrace = tokCloseBrace "\"}\"" - -fieldContent :: Parser (FieldLine Position) -fieldContent = tokFieldLine "field contents" - -newtype IndentLevel = IndentLevel Int - -zeroIndentLevel :: IndentLevel -zeroIndentLevel = IndentLevel 0 - -incIndentLevel :: IndentLevel -> IndentLevel -incIndentLevel (IndentLevel i) = IndentLevel (succ i) - -indentOfAtLeast :: IndentLevel -> Parser IndentLevel -indentOfAtLeast (IndentLevel i) = try $ do - j <- tokIndent - guard (j >= i) "indentation of at least " ++ show i - return (IndentLevel j) - - -newtype LexerMode = LexerMode Int - -inLexerMode :: LexerMode -> Parser p -> Parser p -inLexerMode (LexerMode mode) p = - do setLexerMode mode; x <- p; setLexerMode in_section; return x - - ------------------------ --- Cabal file grammar --- - --- $grammar --- --- @ --- CabalStyleFile ::= SecElems --- --- SecElems ::= SecElem* '\\n'? --- SecElem ::= '\\n' SecElemLayout | SecElemBraces --- SecElemLayout ::= FieldLayout | FieldBraces | SectionLayout | SectionBraces --- SecElemBraces ::= FieldInline | FieldBraces | SectionBraces --- FieldLayout ::= name ':' line? ('\\n' line)* --- FieldBraces ::= name ':' '\\n'? '{' content '}' --- FieldInline ::= name ':' content --- SectionLayout ::= name arg* SecElems --- SectionBraces ::= name arg* '\\n'? '{' SecElems '}' --- @ --- --- and the same thing but left factored... --- --- @ --- SecElems ::= SecElem* --- SecElem ::= '\\n' name SecElemLayout --- | name SecElemBraces --- SecElemLayout ::= ':' FieldLayoutOrBraces --- | arg* SectionLayoutOrBraces --- FieldLayoutOrBraces ::= '\\n'? '{' content '}' --- | line? ('\\n' line)* --- SectionLayoutOrBraces ::= '\\n'? '{' SecElems '\\n'? '}' --- | SecElems --- SecElemBraces ::= ':' FieldInlineOrBraces --- | arg* '\\n'? '{' SecElems '\\n'? '}' --- FieldInlineOrBraces ::= '\\n'? '{' content '}' --- | content --- @ --- --- Note how we have several productions with the sequence: --- --- > '\\n'? '{' --- --- That is, an optional newline (and indent) followed by a @{@ token. --- In the @SectionLayoutOrBraces@ case you can see that this makes it --- not fully left factored (because @SecElems@ can start with a @\\n@). --- Fully left factoring here would be ugly, and though we could use a --- lookahead of two tokens to resolve the alternatives, we can't --- conveniently use Parsec's 'try' here to get a lookahead of only two. --- So instead we deal with this case in the lexer by making a line --- where the first non-space is @{@ lex as just the @{@ token, without --- the usual indent token. Then in the parser we can resolve everything --- with just one token of lookahead and so without using 'try'. - --- Top level of a file using cabal syntax --- -cabalStyleFile :: Parser [Field Position] -cabalStyleFile = do es <- elements zeroIndentLevel - eof - return es - --- Elements that live at the top level or inside a section, ie fields --- and sectionscontent --- --- elements ::= element* -elements :: IndentLevel -> Parser [Field Position] -elements ilevel = many (element ilevel) - --- An individual element, ie a field or a section. These can either use --- layout style or braces style. For layout style then it must start on --- a line on its own (so that we know its indentation level). --- --- element ::= '\\n' name elementInLayoutContext --- | name elementInNonLayoutContext -element :: IndentLevel -> Parser (Field Position) -element ilevel = - (do ilevel' <- indentOfAtLeast ilevel - name <- fieldSecName - elementInLayoutContext (incIndentLevel ilevel') name) - <|> (do name <- fieldSecName - elementInNonLayoutContext name) - --- An element (field or section) that is valid in a layout context. --- In a layout context we can have fields and sections that themselves --- either use layout style or that use braces style. --- --- elementInLayoutContext ::= ':' fieldLayoutOrBraces --- | arg* sectionLayoutOrBraces -elementInLayoutContext :: IndentLevel -> Name Position -> Parser (Field Position) -elementInLayoutContext ilevel name = - (do colon; fieldLayoutOrBraces ilevel name) - <|> (do args <- many sectionArg - elems <- sectionLayoutOrBraces ilevel - return (Section name args elems)) - --- An element (field or section) that is valid in a non-layout context. --- In a non-layout context we can have only have fields and sections that --- themselves use braces style, or inline style fields. --- --- elementInNonLayoutContext ::= ':' FieldInlineOrBraces --- | arg* '\\n'? '{' elements '\\n'? '}' -elementInNonLayoutContext :: Name Position -> Parser (Field Position) -elementInNonLayoutContext name = - (do colon; fieldInlineOrBraces name) - <|> (do args <- many sectionArg - openBrace - elems <- elements zeroIndentLevel - optional tokIndent - closeBrace - return (Section name args elems)) - --- The body of a field, using either layout style or braces style. --- --- fieldLayoutOrBraces ::= '\\n'? '{' content '}' --- | line? ('\\n' line)* -fieldLayoutOrBraces :: IndentLevel -> Name Position -> Parser (Field Position) -fieldLayoutOrBraces ilevel name = braces <|> fieldLayout - where - braces = do - openBrace - ls <- inLexerMode (LexerMode in_field_braces) (many fieldContent) - closeBrace - return (Field name ls) - fieldLayout = inLexerMode (LexerMode in_field_layout) $ do - l <- optionMaybe fieldContent - ls <- many (do _ <- indentOfAtLeast ilevel; fieldContent) - return $ case l of - Nothing -> Field name ls - Just l' -> Field name (l' : ls) - --- The body of a section, using either layout style or braces style. --- --- sectionLayoutOrBraces ::= '\\n'? '{' elements \\n? '}' --- | elements -sectionLayoutOrBraces :: IndentLevel -> Parser [Field Position] -sectionLayoutOrBraces ilevel = - (do openBrace - elems <- elements zeroIndentLevel - optional tokIndent - closeBrace - return elems) - <|> (elements ilevel) - --- The body of a field, using either inline style or braces. --- --- fieldInlineOrBraces ::= '\\n'? '{' content '}' --- | content -fieldInlineOrBraces :: Name Position -> Parser (Field Position) -fieldInlineOrBraces name = - (do openBrace - ls <- inLexerMode (LexerMode in_field_braces) (many fieldContent) - closeBrace - return (Field name ls)) - <|> (do ls <- inLexerMode (LexerMode in_field_braces) (option [] (fmap (\l -> [l]) fieldContent)) - return (Field name ls)) - - --- | Parse cabal style 'B8.ByteString' into list of 'Field's, i.e. the cabal AST. -readFields :: B8.ByteString -> Either ParseError [Field Position] -readFields s = fmap fst (readFields' s) - --- | Like 'readFields' but also return lexer warnings -readFields' :: B8.ByteString -> Either ParseError ([Field Position], [LexWarning]) -readFields' s = do - parse parser "the input" lexSt - where - parser = do - fields <- cabalStyleFile - ws <- getLexerWarnings - pure (fields, ws) - - lexSt = mkLexState' (mkLexState s) - -#ifdef CABAL_PARSEC_DEBUG -parseTest' :: Show a => Parsec LexState' () a -> SourceName -> B8.ByteString -> IO () -parseTest' p fname s = - case parse p fname (lexSt s) of - Left err -> putStrLn (formatError s err) - - Right x -> print x - where - lexSt = mkLexState' . mkLexState - -parseFile :: Show a => Parser a -> FilePath -> IO () -parseFile p f = B8.readFile f >>= \s -> parseTest' p f s - -parseStr :: Show a => Parser a -> String -> IO () -parseStr p = parseBS p . B8.pack - -parseBS :: Show a => Parser a -> B8.ByteString -> IO () -parseBS p = parseTest' p "" - -formatError :: B8.ByteString -> ParseError -> String -formatError input perr = - unlines - [ "Parse error "++ show (errorPos perr) ++ ":" - , errLine - , indicator ++ errmsg ] - where - pos = errorPos perr - ls = lines' (T.decodeUtf8With T.lenientDecode input) - errLine = T.unpack (ls !! (sourceLine pos - 1)) - indicator = replicate (sourceColumn pos) ' ' ++ "^" - errmsg = showErrorMessages "or" "unknown parse error" - "expecting" "unexpected" "end of file" - (errorMessages perr) - --- | Handles windows/osx/unix line breaks uniformly -lines' :: T.Text -> [T.Text] -lines' s1 - | T.null s1 = [] - | otherwise = case T.break (\c -> c == '\r' || c == '\n') s1 of - (l, s2) | Just (c,s3) <- T.uncons s2 - -> case T.uncons s3 of - Just ('\n', s4) | c == '\r' -> l : lines' s4 - _ -> l : lines' s3 - | otherwise -> [l] -#endif - -eof :: Parser () -eof = notFollowedBy anyToken "end of file" - where - notFollowedBy :: Parser LToken -> Parser () - notFollowedBy p = try ( (do L _ t <- try p; unexpected (describeToken t)) - <|> return ()) diff --git a/src/Distribution/Fields/Pretty.hs b/src/Distribution/Fields/Pretty.hs deleted file mode 100644 --- a/src/Distribution/Fields/Pretty.hs +++ /dev/null @@ -1,176 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveTraversable #-} --- | Cabal-like file AST types: 'Field', 'Section' etc, --- --- This (intermediate) data type is used for pretty-printing. --- --- @since 3.0.0.0 --- -module Distribution.Fields.Pretty ( - -- * Fields - PrettyField (..), - showFields, - showFields', - -- * Transformation from 'P.Field' - fromParsecFields, - genericFromParsecFields, - prettyFieldLines, - prettySectionArgs, - ) where - -import Distribution.Compat.Prelude -import Distribution.Pretty (showToken) -import Prelude () - -import Distribution.Fields.Field (FieldName) -import Distribution.Simple.Utils (fromUTF8BS) - -import qualified Distribution.Fields.Parser as P - -import qualified Data.ByteString as BS -import qualified Text.PrettyPrint as PP - -data PrettyField ann - = PrettyField ann FieldName PP.Doc - | PrettySection ann FieldName [PP.Doc] [PrettyField ann] - deriving (Functor, Foldable, Traversable) - --- | Prettyprint a list of fields. --- --- Note: the first argument should return 'String's without newlines --- and properly prefixes (with @--@) to count as comments. --- This unsafety is left in place so one could generate empty lines --- between comment lines. --- -showFields :: (ann -> [String]) -> [PrettyField ann] -> String -showFields rann = showFields' rann (const id) 4 - --- | 'showFields' with user specified indentation. -showFields' - :: (ann -> [String]) - -- ^ Convert an annotation to lined to preceed the field or section. - -> (ann -> [String] -> [String]) - -- ^ Post-process non-annotation produced lines. - -> Int - -- ^ Indentation level. - -> [PrettyField ann] - -- ^ Fields/sections to show. - -> String -showFields' rann post n = unlines . renderFields (Opts rann indent post) - where - -- few hardcoded, "unrolled" variants. - indent | n == 4 = indent4 - | n == 2 = indent2 - | otherwise = (replicate (max n 1) ' ' ++) - - indent4 :: String -> String - indent4 [] = [] - indent4 xs = ' ' : ' ' : ' ' : ' ' : xs - - indent2 :: String -> String - indent2 [] = [] - indent2 xs = ' ' : ' ' : xs - -data Opts ann = Opts - { _optAnnotation ::(ann -> [String]) - , _optIndent ::(String -> String) - , _optPostprocess :: ann -> [String] -> [String] - } - -renderFields :: Opts ann -> [PrettyField ann] -> [String] -renderFields opts fields = flattenBlocks $ map (renderField opts len) fields - where - len = maxNameLength 0 fields - - maxNameLength !acc [] = acc - maxNameLength !acc (PrettyField _ name _ : rest) = maxNameLength (max acc (BS.length name)) rest - maxNameLength !acc (PrettySection {} : rest) = maxNameLength acc rest - --- | Block of lines, --- Boolean parameter tells whether block should be surrounded by empty lines -data Block = Block Margin Margin [String] - -data Margin = Margin | NoMargin - deriving Eq - --- | Collapse margins, any margin = margin -instance Semigroup Margin where - NoMargin <> NoMargin = NoMargin - _ <> _ = Margin - -flattenBlocks :: [Block] -> [String] -flattenBlocks = go0 where - go0 [] = [] - go0 (Block _before after strs : blocks) = strs ++ go after blocks - - go _surr' [] = [] - go surr' (Block before after strs : blocks) = ins $ strs ++ go after blocks where - ins | surr' <> before == Margin = ("" :) - | otherwise = id - -renderField :: Opts ann -> Int -> PrettyField ann -> Block -renderField (Opts rann indent post) fw (PrettyField ann name doc) = - Block before after $ comments ++ post ann lines' - where - comments = rann ann - before = if null comments then NoMargin else Margin - - (lines', after) = case lines narrow of - [] -> ([ name' ++ ":" ], NoMargin) - [singleLine] | length singleLine < 60 - -> ([ name' ++ ": " ++ replicate (fw - length name') ' ' ++ narrow ], NoMargin) - _ -> ((name' ++ ":") : map indent (lines (PP.render doc)), Margin) - - name' = fromUTF8BS name - narrow = PP.renderStyle narrowStyle doc - - narrowStyle :: PP.Style - narrowStyle = PP.style { PP.lineLength = PP.lineLength PP.style - fw } - -renderField opts@(Opts rann indent post) _ (PrettySection ann name args fields) = Block Margin Margin $ - rann ann - ++ - post ann [ PP.render $ PP.hsep $ PP.text (fromUTF8BS name) : args ] - ++ - (map indent $ renderFields opts fields) - -------------------------------------------------------------------------------- --- Transform from Parsec.Field -------------------------------------------------------------------------------- - -genericFromParsecFields - :: Applicative f - => (FieldName -> [P.FieldLine ann] -> f PP.Doc) -- ^ transform field contents - -> (FieldName -> [P.SectionArg ann] -> f [PP.Doc]) -- ^ transform section arguments - -> [P.Field ann] - -> f [PrettyField ann] -genericFromParsecFields f g = goMany where - goMany = traverse go - - go (P.Field (P.Name ann name) fls) = PrettyField ann name <$> f name fls - go (P.Section (P.Name ann name) secargs fs) = PrettySection ann name <$> g name secargs <*> goMany fs - --- | Used in 'fromParsecFields'. -prettyFieldLines :: FieldName -> [P.FieldLine ann] -> PP.Doc -prettyFieldLines _ fls = PP.vcat - [ PP.text $ fromUTF8BS bs - | P.FieldLine _ bs <- fls - ] - --- | Used in 'fromParsecFields'. -prettySectionArgs :: FieldName -> [P.SectionArg ann] -> [PP.Doc] -prettySectionArgs _ = map $ \sa -> case sa of - P.SecArgName _ bs -> showToken $ fromUTF8BS bs - P.SecArgStr _ bs -> showToken $ fromUTF8BS bs - P.SecArgOther _ bs -> PP.text $ fromUTF8BS bs - --- | Simple variant of 'genericFromParsecField' -fromParsecFields :: [P.Field ann] -> [PrettyField ann] -fromParsecFields = runIdentity . genericFromParsecFields - (Identity .: prettyFieldLines) - (Identity .: prettySectionArgs) - where - (.:) :: (a -> b) -> (c -> d -> a) -> (c -> d -> b) - (f .: g) x y = f (g x y) diff --git a/src/Distribution/GetOpt.hs b/src/Distribution/GetOpt.hs --- a/src/Distribution/GetOpt.hs +++ b/src/Distribution/GetOpt.hs @@ -17,9 +17,10 @@ -- * Line wrapping in the 'usageInfo' output, plus a more compact -- rendering of short options, and slightly less padding. -- --- If you want to take on the challenge of merging this with the GetOpt --- from the base package then go for it! +-- * Parsing of option arguments is allowed to fail. -- +-- * 'ReturnInOrder' argument order is removed. +-- {-# LANGUAGE TupleSections #-} {-# LANGUAGE NamedFieldPuns #-} module Distribution.GetOpt ( @@ -36,9 +37,35 @@ import Prelude () import Distribution.Compat.Prelude -import System.Console.GetOpt - ( ArgOrder(..), OptDescr(..), ArgDescr(..) ) +-- | What to do with options following non-options +data ArgOrder a + = RequireOrder -- ^ no option processing after first non-option + | Permute -- ^ freely intersperse options and non-options + +data OptDescr a = -- description of a single options: + Option [Char] -- list of short option characters + [String] -- list of long option strings (without "--") + (ArgDescr a) -- argument descriptor + String -- explanation of option for user + +instance Functor OptDescr where + fmap f (Option a b argDescr c) = Option a b (fmap f argDescr) c + +-- | Describes whether an option takes an argument or not, and if so +-- how the argument is parsed to a value of type @a@. +-- +-- Compared to System.Console.GetOpt, we allow for parse errors. +data ArgDescr a + = NoArg a -- ^ no argument expected + | ReqArg (String -> Either String a) String -- ^ option requires argument + | OptArg (Maybe String -> Either String a) String -- ^ optional argument + +instance Functor ArgDescr where + fmap f (NoArg a) = NoArg (f a) + fmap f (ReqArg g s) = ReqArg (fmap f . g) s + fmap f (OptArg g s) = OptArg (fmap f . g) s + data OptKind a -- kind of cmd line arg (internal use only): = Opt a -- an option | UnreqOpt String -- an un-recognized option @@ -46,8 +73,8 @@ | EndOfOpts -- end-of-options marker (i.e. "--") | OptErr String -- something went wrong... -data OptHelp a = OptHelp { - optNames :: a, +data OptHelp = OptHelp { + optNames :: String, optHelp :: String } @@ -56,7 +83,7 @@ -- second argument. usageInfo :: String -- header -> [OptDescr a] -- option descriptors - -> String -- nicely formatted decription of options + -> String -- nicely formatted description of options usageInfo header optDescr = unlines (header : table) where options = flip map optDescr $ \(Option sos los ad d) -> @@ -155,10 +182,8 @@ procNextOpt (UnreqOpt u) _ = (os,xs,u:us,es) procNextOpt (NonOpt x) RequireOrder = ([],x:rest,[],[]) procNextOpt (NonOpt x) Permute = (os,x:xs,us,es) - procNextOpt (NonOpt x) (ReturnInOrder f) = (f x :os, xs,us,es) procNextOpt EndOfOpts RequireOrder = ([],rest,[],[]) procNextOpt EndOfOpts Permute = ([],rest,[],[]) - procNextOpt EndOfOpts (ReturnInOrder f) = (map f rest,[],[],[]) procNextOpt (OptErr e) _ = (os,xs,us,e:es) (opt,rest) = getNext arg args optDescr @@ -181,15 +206,16 @@ options = if null exact then getWith isPrefixOf else exact ads = [ ad | Option _ _ ad _ <- options ] optStr = "--" ++ opt + fromRes = fromParseResult optStr long (_:_:_) _ rest = (errAmbig options optStr,rest) long [NoArg a ] [] rest = (Opt a,rest) long [NoArg _ ] ('=':_) rest = (errNoArg optStr,rest) long [ReqArg _ d] [] [] = (errReq d optStr,[]) - long [ReqArg f _] [] (r:rest) = (Opt (f r),rest) - long [ReqArg f _] ('=':xs) rest = (Opt (f xs),rest) - long [OptArg f _] [] rest = (Opt (f Nothing),rest) - long [OptArg f _] ('=':xs) rest = (Opt (f (Just xs)),rest) + long [ReqArg f _] [] (r:rest) = (fromRes (f r),rest) + long [ReqArg f _] ('=':xs) rest = (fromRes (f xs),rest) + long [OptArg f _] [] rest = (fromRes (f Nothing),rest) + long [OptArg f _] ('=':xs) rest = (fromRes (f (Just xs)),rest) long _ _ rest = (UnreqOpt ("--"++ls),rest) -- handle short option @@ -198,15 +224,16 @@ where options = [ o | o@(Option ss _ _ _) <- optDescr, s <- ss, y == s ] ads = [ ad | Option _ _ ad _ <- options ] optStr = '-':[y] + fromRes = fromParseResult optStr short (_:_:_) _ rest = (errAmbig options optStr,rest) short (NoArg a :_) [] rest = (Opt a,rest) short (NoArg a :_) xs rest = (Opt a,('-':xs):rest) short (ReqArg _ d:_) [] [] = (errReq d optStr,[]) - short (ReqArg f _:_) [] (r:rest) = (Opt (f r),rest) - short (ReqArg f _:_) xs rest = (Opt (f xs),rest) - short (OptArg f _:_) [] rest = (Opt (f Nothing),rest) - short (OptArg f _:_) xs rest = (Opt (f (Just xs)),rest) + short (ReqArg f _:_) [] (r:rest) = (fromRes (f r),rest) + short (ReqArg f _:_) xs rest = (fromRes (f xs),rest) + short (OptArg f _:_) [] rest = (fromRes (f Nothing),rest) + short (OptArg f _:_) xs rest = (fromRes (f (Just xs)),rest) short [] [] rest = (UnreqOpt optStr,rest) short [] xs rest = (UnreqOpt (optStr++xs),rest) -- This is different vs upstream = (UnreqOpt optStr,('-':xs):rest) @@ -215,9 +242,14 @@ -- But why was no equivalent change required for longOpt? So could -- this change go upstream? +fromParseResult :: String -> Either String a -> OptKind a +fromParseResult optStr res = case res of + Right x -> Opt x + Left err -> OptErr ("invalid argument to option `" ++ optStr ++ "': " ++ err ++ "\n") + -- miscellaneous error formatting -errAmbig :: [OptDescr a] -> String -> OptKind a +errAmbig :: [OptDescr a] -> String -> OptKind b errAmbig ods optStr = OptErr (usageInfo header ods) where header = "option `" ++ optStr ++ "' is ambiguous; could be one of:" diff --git a/src/Distribution/InstalledPackageInfo.hs b/src/Distribution/InstalledPackageInfo.hs deleted file mode 100644 --- a/src/Distribution/InstalledPackageInfo.hs +++ /dev/null @@ -1,145 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.InstalledPackageInfo --- Copyright : (c) The University of Glasgow 2004 --- --- Maintainer : libraries@haskell.org --- Portability : portable --- --- This is the information about an /installed/ package that --- is communicated to the @ghc-pkg@ program in order to register --- a package. @ghc-pkg@ now consumes this package format (as of version --- 6.4). This is specific to GHC at the moment. --- --- The @.cabal@ file format is for describing a package that is not yet --- installed. It has a lot of flexibility, like conditionals and dependency --- ranges. As such, that format is not at all suitable for describing a package --- that has already been built and installed. By the time we get to that stage, --- we have resolved all conditionals and resolved dependency version --- constraints to exact versions of dependent packages. So, this module defines --- the 'InstalledPackageInfo' data structure that contains all the info we keep --- about an installed package. There is a parser and pretty printer. The --- textual format is rather simpler than the @.cabal@ format: there are no --- sections, for example. - --- This module is meant to be local-only to Distribution... - -module Distribution.InstalledPackageInfo ( - InstalledPackageInfo(..), - installedComponentId, - installedOpenUnitId, - sourceComponentName, - requiredSignatures, - ExposedModule(..), - AbiDependency(..), - emptyInstalledPackageInfo, - parseInstalledPackageInfo, - showInstalledPackageInfo, - showFullInstalledPackageInfo, - showInstalledPackageInfoField, - showSimpleInstalledPackageInfoField, - ) where - -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Backpack -import Distribution.CabalSpecVersion (cabalSpecLatest) -import Distribution.FieldGrammar -import Distribution.FieldGrammar.FieldDescrs -import Distribution.ModuleName -import Distribution.Package hiding (installedUnitId) -import Distribution.Types.ComponentName -import Distribution.Utils.Generic (toUTF8BS) - -import Data.ByteString (ByteString) - -import qualified Data.Map as Map -import qualified Distribution.Fields as P -import qualified Text.PrettyPrint as Disp - -import Distribution.Types.InstalledPackageInfo -import Distribution.Types.InstalledPackageInfo.FieldGrammar - --- $setup --- >>> :set -XOverloadedStrings - -installedComponentId :: InstalledPackageInfo -> ComponentId -installedComponentId ipi = - case unComponentId (installedComponentId_ ipi) of - "" -> mkComponentId (unUnitId (installedUnitId ipi)) - _ -> installedComponentId_ ipi - --- | Get the indefinite unit identity representing this package. --- This IS NOT guaranteed to give you a substitution; for --- instantiated packages you will get @DefiniteUnitId (installedUnitId ipi)@. --- For indefinite libraries, however, you will correctly get --- an @OpenUnitId@ with the appropriate 'OpenModuleSubst'. -installedOpenUnitId :: InstalledPackageInfo -> OpenUnitId -installedOpenUnitId ipi - = mkOpenUnitId (installedUnitId ipi) (installedComponentId ipi) (Map.fromList (instantiatedWith ipi)) - --- | Returns the set of module names which need to be filled for --- an indefinite package, or the empty set if the package is definite. -requiredSignatures :: InstalledPackageInfo -> Set ModuleName -requiredSignatures ipi = openModuleSubstFreeHoles (Map.fromList (instantiatedWith ipi)) - --- ----------------------------------------------------------------------------- --- Munging - -sourceComponentName :: InstalledPackageInfo -> ComponentName -sourceComponentName = CLibName . sourceLibName - --- ----------------------------------------------------------------------------- --- Parsing - --- | Return either errors, or IPI with list of warnings -parseInstalledPackageInfo - :: ByteString - -> Either (NonEmpty String) ([String], InstalledPackageInfo) -parseInstalledPackageInfo s = case P.readFields s of - Left err -> Left (show err :| []) - Right fs -> case partitionFields fs of - (fs', _) -> case P.runParseResult $ parseFieldGrammar cabalSpecLatest fs' ipiFieldGrammar of - (ws, Right x) -> x `deepseq` Right (ws', x) where - ws' = [ P.showPWarning "" w - | w@(P.PWarning wt _ _) <- ws - -- filter out warnings about experimental features - , wt /= P.PWTExperimental - ] - (_, Left (_, errs)) -> Left errs' where - errs' = fmap (P.showPError "") errs - --- ----------------------------------------------------------------------------- --- Pretty-printing - --- | Pretty print 'InstalledPackageInfo'. --- --- @pkgRoot@ isn't printed, as ghc-pkg prints it manually (as GHC-8.4). -showInstalledPackageInfo :: InstalledPackageInfo -> String -showInstalledPackageInfo ipi = - showFullInstalledPackageInfo ipi { pkgRoot = Nothing } - --- | The variant of 'showInstalledPackageInfo' which outputs @pkgroot@ field too. -showFullInstalledPackageInfo :: InstalledPackageInfo -> String -showFullInstalledPackageInfo = P.showFields (const []) . prettyFieldGrammar cabalSpecLatest ipiFieldGrammar - --- | --- --- >>> let ipi = emptyInstalledPackageInfo { maintainer = "Tester" } --- >>> fmap ($ ipi) $ showInstalledPackageInfoField "maintainer" --- Just "maintainer: Tester" -showInstalledPackageInfoField :: String -> Maybe (InstalledPackageInfo -> String) -showInstalledPackageInfoField fn = - fmap (\g -> Disp.render . ppField fn . g) $ fieldDescrPretty ipiFieldGrammar (toUTF8BS fn) - -showSimpleInstalledPackageInfoField :: String -> Maybe (InstalledPackageInfo -> String) -showSimpleInstalledPackageInfoField fn = - fmap (Disp.renderStyle myStyle .) $ fieldDescrPretty ipiFieldGrammar (toUTF8BS fn) - where - myStyle = Disp.style { Disp.mode = Disp.LeftMode } - -ppField :: String -> Disp.Doc -> Disp.Doc -ppField name fielddoc - | Disp.isEmpty fielddoc = mempty - | otherwise = Disp.text name <<>> Disp.colon Disp.<+> fielddoc diff --git a/src/Distribution/License.hs b/src/Distribution/License.hs deleted file mode 100644 --- a/src/Distribution/License.hs +++ /dev/null @@ -1,252 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} - ------------------------------------------------------------------------------ --- | --- Module : Distribution.License --- Description : The License data type. --- Copyright : Isaac Jones 2003-2005 --- Duncan Coutts 2008 --- License : BSD3 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- Package descriptions contain fields for specifying the name of a software --- license and the name of the file containing the text of that license. While --- package authors may choose any license they like, Cabal provides an --- enumeration of a small set of common free and open source software licenses. --- This is done so that Hackage can recognise licenses, so that tools can detect --- , --- and to deter --- . --- --- It is recommended that all package authors use the @license-file@ or --- @license-files@ fields in their package descriptions. Further information --- about these fields can be found in the --- . --- --- = Additional resources --- --- The following websites provide information about free and open source --- software licenses: --- --- * --- --- * --- --- = Disclaimer --- --- The descriptions of software licenses provided by this documentation are --- intended for informational purposes only and in no way constitute legal --- advice. Please read the text of the licenses and consult a lawyer for any --- advice regarding software licensing. - -module Distribution.License ( - License(..), - knownLicenses, - licenseToSPDX, - licenseFromSPDX, - ) where - -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Parsec -import Distribution.Pretty -import Distribution.Version - -import qualified Distribution.Compat.CharParsing as P -import qualified Data.Map.Strict as Map -import qualified Distribution.SPDX as SPDX -import qualified Text.PrettyPrint as Disp - --- | Indicates the license under which a package's source code is released. --- Versions of the licenses not listed here will be rejected by Hackage and --- cause @cabal check@ to issue a warning. -data License = - -- TODO: * remove BSD4 - - -- | GNU General Public License, - -- or - -- . - GPL (Maybe Version) - - -- | . - | AGPL (Maybe Version) - - -- | GNU Lesser General Public License, - -- or - -- . - | LGPL (Maybe Version) - - -- | . - | BSD2 - - -- | . - | BSD3 - - -- | . - -- This license has not been approved by the OSI and is incompatible with - -- the GNU GPL. It is provided for historical reasons and should be avoided. - | BSD4 - - -- | . - | MIT - - -- | - | ISC - - -- | . - | MPL Version - - -- | . - | Apache (Maybe Version) - - -- | The author of a package disclaims any copyright to its source code and - -- dedicates it to the public domain. This is not a software license. Please - -- note that it is not possible to dedicate works to the public domain in - -- every jurisdiction, nor is a work that is in the public domain in one - -- jurisdiction necessarily in the public domain elsewhere. - | PublicDomain - - -- | Explicitly 'All Rights Reserved', eg for proprietary software. The - -- package may not be legally modified or redistributed by anyone but the - -- rightsholder. - | AllRightsReserved - - -- | No license specified which legally defaults to 'All Rights Reserved'. - -- The package may not be legally modified or redistributed by anyone but - -- the rightsholder. - | UnspecifiedLicense - - -- | Any other software license. - | OtherLicense - - -- | Indicates an erroneous license name. - | UnknownLicense String - deriving (Generic, Read, Show, Eq, Typeable, Data) - -instance Binary License -instance Structured License -instance NFData License where rnf = genericRnf - --- | The list of all currently recognised licenses. -knownLicenses :: [License] -knownLicenses = [ GPL unversioned, GPL (version [2]), GPL (version [3]) - , LGPL unversioned, LGPL (version [2, 1]), LGPL (version [3]) - , AGPL unversioned, AGPL (version [3]) - , BSD2, BSD3, MIT, ISC - , MPL (mkVersion [2, 0]) - , Apache unversioned, Apache (version [2, 0]) - , PublicDomain, AllRightsReserved, OtherLicense] - where - unversioned = Nothing - version = Just . mkVersion - --- | Convert old 'License' to SPDX 'SPDX.License'. --- Non-SPDX licenses are converted to 'SPDX.LicenseRef'. --- --- @since 2.2.0.0 -licenseToSPDX :: License -> SPDX.License -licenseToSPDX l = case l of - GPL v | v == version [2] -> spdx SPDX.GPL_2_0_only - GPL v | v == version [3] -> spdx SPDX.GPL_3_0_only - LGPL v | v == version [2,1] -> spdx SPDX.LGPL_2_1_only - LGPL v | v == version [3] -> spdx SPDX.LGPL_3_0_only - AGPL v | v == version [3] -> spdx SPDX.AGPL_3_0_only - BSD2 -> spdx SPDX.BSD_2_Clause - BSD3 -> spdx SPDX.BSD_3_Clause - BSD4 -> spdx SPDX.BSD_4_Clause - MIT -> spdx SPDX.MIT - ISC -> spdx SPDX.ISC - MPL v | v == mkVersion [2,0] -> spdx SPDX.MPL_2_0 - Apache v | v == version [2,0] -> spdx SPDX.Apache_2_0 - AllRightsReserved -> SPDX.NONE - UnspecifiedLicense -> SPDX.NONE - OtherLicense -> ref (SPDX.mkLicenseRef' Nothing "OtherLicense") - PublicDomain -> ref (SPDX.mkLicenseRef' Nothing "PublicDomain") - UnknownLicense str -> ref (SPDX.mkLicenseRef' Nothing str) - _ -> ref (SPDX.mkLicenseRef' Nothing $ prettyShow l) - where - version = Just . mkVersion - spdx = SPDX.License . SPDX.simpleLicenseExpression - ref r = SPDX.License $ SPDX.ELicense (SPDX.ELicenseRef r) Nothing - --- | Convert 'SPDX.License' to 'License', --- --- This is lossy conversion. We try our best. --- --- >>> licenseFromSPDX . licenseToSPDX $ BSD3 --- BSD3 --- --- >>> licenseFromSPDX . licenseToSPDX $ GPL (Just (mkVersion [3])) --- GPL (Just (mkVersion [3])) --- --- >>> licenseFromSPDX . licenseToSPDX $ PublicDomain --- UnknownLicense "LicenseRefPublicDomain" --- --- >>> licenseFromSPDX $ SPDX.License $ SPDX.simpleLicenseExpression SPDX.EUPL_1_1 --- UnknownLicense "EUPL-1.1" --- --- >>> licenseFromSPDX . licenseToSPDX $ AllRightsReserved --- AllRightsReserved --- --- >>> licenseFromSPDX <$> simpleParsec "BSD-3-Clause OR GPL-3.0-only" --- Just (UnknownLicense "BSD3ClauseORGPL30only") --- --- @since 2.2.0.0 -licenseFromSPDX :: SPDX.License -> License -licenseFromSPDX SPDX.NONE = AllRightsReserved -licenseFromSPDX l = - fromMaybe (mungle $ prettyShow l) $ Map.lookup l m - where - m :: Map.Map SPDX.License License - m = Map.fromList $ filter (isSimple . fst ) $ - map (\x -> (licenseToSPDX x, x)) knownLicenses - - isSimple (SPDX.License (SPDX.ELicense (SPDX.ELicenseId _) Nothing)) = True - isSimple _ = False - - mungle name = fromMaybe (UnknownLicense (mapMaybe mangle name)) (simpleParsec name) - - mangle c - | isAlphaNum c = Just c - | otherwise = Nothing - -instance Pretty License where - pretty (GPL version) = Disp.text "GPL" <<>> dispOptVersion version - pretty (LGPL version) = Disp.text "LGPL" <<>> dispOptVersion version - pretty (AGPL version) = Disp.text "AGPL" <<>> dispOptVersion version - pretty (MPL version) = Disp.text "MPL" <<>> dispVersion version - pretty (Apache version) = Disp.text "Apache" <<>> dispOptVersion version - pretty (UnknownLicense other) = Disp.text other - pretty other = Disp.text (show other) - -instance Parsec License where - parsec = do - name <- P.munch1 isAlphaNum - version <- P.optional (P.char '-' *> parsec) - return $! case (name, version :: Maybe Version) of - ("GPL", _ ) -> GPL version - ("LGPL", _ ) -> LGPL version - ("AGPL", _ ) -> AGPL version - ("BSD2", Nothing) -> BSD2 - ("BSD3", Nothing) -> BSD3 - ("BSD4", Nothing) -> BSD4 - ("ISC", Nothing) -> ISC - ("MIT", Nothing) -> MIT - ("MPL", Just version') -> MPL version' - ("Apache", _ ) -> Apache version - ("PublicDomain", Nothing) -> PublicDomain - ("AllRightsReserved", Nothing) -> AllRightsReserved - ("OtherLicense", Nothing) -> OtherLicense - _ -> UnknownLicense $ name ++ - maybe "" (('-':) . prettyShow) version - -dispOptVersion :: Maybe Version -> Disp.Doc -dispOptVersion Nothing = Disp.empty -dispOptVersion (Just v) = dispVersion v - -dispVersion :: Version -> Disp.Doc -dispVersion v = Disp.char '-' <<>> pretty v diff --git a/src/Distribution/ModuleName.hs b/src/Distribution/ModuleName.hs deleted file mode 100644 --- a/src/Distribution/ModuleName.hs +++ /dev/null @@ -1,131 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE ScopedTypeVariables #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.ModuleName --- Copyright : Duncan Coutts 2008 --- License : BSD3 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- Data type for Haskell module names. - -module Distribution.ModuleName ( - ModuleName, - fromString, - fromComponents, - components, - toFilePath, - main, - -- * Internal - validModuleComponent, - ) where - -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Parsec -import Distribution.Pretty -import Distribution.Utils.ShortText (ShortText, fromShortText, toShortText) -import System.FilePath (pathSeparator) - -import qualified Distribution.Compat.CharParsing as P -import qualified Distribution.Compat.DList as DList -import qualified Text.PrettyPrint as Disp - --- | A valid Haskell module name. --- -newtype ModuleName = ModuleName ShortText - deriving (Eq, Generic, Ord, Read, Show, Typeable, Data) - -unModuleName :: ModuleName -> String -unModuleName (ModuleName s) = fromShortText s - -instance Binary ModuleName -instance Structured ModuleName - -instance NFData ModuleName where - rnf (ModuleName ms) = rnf ms - -instance Pretty ModuleName where - pretty = Disp.text . unModuleName - -instance Parsec ModuleName where - parsec = parsecModuleName - -parsecModuleName :: forall m. CabalParsing m => m ModuleName -parsecModuleName = state0 DList.empty where - upper :: m Char - !upper = P.satisfy isUpper - - ch :: m Char - !ch = P.satisfy (\c -> validModuleChar c || c == '.') - - alt :: m ModuleName -> m ModuleName -> m ModuleName - !alt = (<|>) - - state0 :: DList.DList Char -> m ModuleName - state0 acc = do - c <- upper - state1 (DList.snoc acc c) - - state1 :: DList.DList Char -> m ModuleName - state1 acc = state1' acc `alt` return (fromString (DList.toList acc)) - - state1' :: DList.DList Char -> m ModuleName - state1' acc = do - c <- ch - case c of - '.' -> state0 (DList.snoc acc c) - _ -> state1 (DList.snoc acc c) - -validModuleChar :: Char -> Bool -validModuleChar c = isAlphaNum c || c == '_' || c == '\'' - -validModuleComponent :: String -> Bool -validModuleComponent [] = False -validModuleComponent (c:cs) = isUpper c && all validModuleChar cs - --- | Construct a 'ModuleName' from a valid module name 'String'. --- --- This is just a convenience function intended for valid module strings. It is --- an error if it is used with a string that is not a valid module name. If you --- are parsing user input then use 'Distribution.Text.simpleParse' instead. --- -instance IsString ModuleName where - fromString = ModuleName . toShortText - --- | Construct a 'ModuleName' from valid module components, i.e. parts --- separated by dots. -fromComponents :: [String] -> ModuleName -fromComponents comps = fromString (intercalate "." comps) -{-# DEPRECATED fromComponents "Exists for cabal-install only" #-} - --- | The module name @Main@. --- -main :: ModuleName -main = ModuleName (fromString "Main") - --- | The individual components of a hierarchical module name. For example --- --- > components (fromString "A.B.C") = ["A", "B", "C"] --- -components :: ModuleName -> [String] -components mn = split (unModuleName mn) - where - split cs = case break (=='.') cs of - (chunk,[]) -> chunk : [] - (chunk,_:rest) -> chunk : split rest - --- | Convert a module name to a file path, but without any file extension. --- For example: --- --- > toFilePath (fromString "A.B.C") = "A/B/C" --- -toFilePath :: ModuleName -> FilePath -toFilePath = map f . unModuleName where - f '.' = pathSeparator - f c = c diff --git a/src/Distribution/Package.hs b/src/Distribution/Package.hs deleted file mode 100644 --- a/src/Distribution/Package.hs +++ /dev/null @@ -1,96 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - ------------------------------------------------------------------------------ --- | --- Module : Distribution.Package --- Copyright : Isaac Jones 2003-2004 --- License : BSD3 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- Defines a package identifier along with a parser and pretty printer for it. --- 'PackageIdentifier's consist of a name and an exact version. It also defines --- a 'Dependency' data type. A dependency is a package name and a version --- range, like @\"foo >= 1.2 && < 2\"@. - -module Distribution.Package - ( module Distribution.Types.AbiHash - , module Distribution.Types.ComponentId - , module Distribution.Types.PackageId - , module Distribution.Types.UnitId - , module Distribution.Types.Module - , module Distribution.Types.PackageName - , module Distribution.Types.PkgconfigName - , module Distribution.Types.Dependency - , Package(..), packageName, packageVersion - , HasMungedPackageId(..), mungedName', mungedVersion' - , HasUnitId(..) - , PackageInstalled(..) - ) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Version - ( Version ) - -import Distribution.Types.AbiHash -import Distribution.Types.ComponentId -import Distribution.Types.Dependency -import Distribution.Types.MungedPackageId -import Distribution.Types.PackageId -import Distribution.Types.UnitId -import Distribution.Types.Module -import Distribution.Types.MungedPackageName -import Distribution.Types.PackageName -import Distribution.Types.PkgconfigName - --- | Class of things that have a 'PackageIdentifier' --- --- Types in this class are all notions of a package. This allows us to have --- different types for the different phases that packages go though, from --- simple name\/id, package description, configured or installed packages. --- --- Not all kinds of packages can be uniquely identified by a --- 'PackageIdentifier'. In particular, installed packages cannot, there may be --- many installed instances of the same source package. --- -class Package pkg where - packageId :: pkg -> PackageIdentifier - -mungedName' :: HasMungedPackageId pkg => pkg -> MungedPackageName -mungedName' = mungedName . mungedId - -mungedVersion' :: HasMungedPackageId munged => munged -> Version -mungedVersion' = mungedVersion . mungedId - -class HasMungedPackageId pkg where - mungedId :: pkg -> MungedPackageId - -instance Package PackageIdentifier where - packageId = id - -packageName :: Package pkg => pkg -> PackageName -packageName = pkgName . packageId - -packageVersion :: Package pkg => pkg -> Version -packageVersion = pkgVersion . packageId - -instance HasMungedPackageId MungedPackageId where - mungedId = id - --- | Packages that have an installed unit ID -class Package pkg => HasUnitId pkg where - installedUnitId :: pkg -> UnitId - --- | Class of installed packages. --- --- The primary data type which is an instance of this package is --- 'InstalledPackageInfo', but when we are doing install plans in Cabal install --- we may have other, installed package-like things which contain more metadata. --- Installed packages have exact dependencies 'installedDepends'. -class (HasUnitId pkg) => PackageInstalled pkg where - installedDepends :: pkg -> [UnitId] diff --git a/src/Distribution/PackageDescription.hs b/src/Distribution/PackageDescription.hs deleted file mode 100644 --- a/src/Distribution/PackageDescription.hs +++ /dev/null @@ -1,113 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.PackageDescription --- Copyright : Isaac Jones 2003-2005 --- License : BSD3 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- Backwards compatibility reexport of most things you need to know --- about @.cabal@ files. - -module Distribution.PackageDescription ( - -- * PD and GPD - module Distribution.Types.PackageDescription, - module Distribution.Types.GenericPackageDescription, - -- * Components - module Distribution.Types.ComponentName, - -- ** Library - module Distribution.Types.Library, - module Distribution.Types.LibraryName, - module Distribution.Types.LibraryVisibility, - -- ** Executable - module Distribution.Types.Executable, - module Distribution.Types.ExecutableScope, - -- ** TestSuite - module Distribution.Types.TestSuite, - module Distribution.Types.TestType, - module Distribution.Types.TestSuiteInterface, - -- ** Benchmark - module Distribution.Types.Benchmark, - module Distribution.Types.BenchmarkType, - module Distribution.Types.BenchmarkInterface, - -- ** Foreign library - module Distribution.Types.ForeignLib, - module Distribution.Types.ForeignLibType, - module Distribution.Types.ForeignLibOption, - -- * BuildInfo - module Distribution.Types.BuildType, - module Distribution.Types.BuildInfo, - module Distribution.Types.HookedBuildInfo, - module Distribution.Types.SetupBuildInfo, - -- * Flags - module Distribution.Types.Flag, - -- * Identifiers - module Distribution.Types.PackageId, - module Distribution.Types.PackageName, - module Distribution.Types.UnqualComponentName, - -- * Pkgconfig - module Distribution.Types.PkgconfigName, - module Distribution.Types.PkgconfigVersion, - module Distribution.Types.PkgconfigVersionRange, - -- * Dependencies - module Distribution.Types.Dependency, - module Distribution.Types.ExeDependency, - module Distribution.Types.LegacyExeDependency, - module Distribution.Types.PkgconfigDependency, - -- * Condition trees - module Distribution.Types.CondTree, - module Distribution.Types.Condition, - module Distribution.Types.ConfVar, - -- * Mixin - module Distribution.Types.IncludeRenaming, - module Distribution.Types.Mixin, - module Distribution.Types.ModuleReexport, - module Distribution.Types.ModuleRenaming, - -- * Source repository - module Distribution.Types.SourceRepo, - ) where - -import Prelude () ---import Distribution.Compat.Prelude - -import Distribution.Types.Benchmark -import Distribution.Types.BenchmarkInterface -import Distribution.Types.BenchmarkType -import Distribution.Types.BuildInfo -import Distribution.Types.BuildType -import Distribution.Types.ComponentName -import Distribution.Types.Condition -import Distribution.Types.CondTree -import Distribution.Types.ConfVar -import Distribution.Types.Dependency -import Distribution.Types.Executable -import Distribution.Types.ExecutableScope -import Distribution.Types.ExeDependency -import Distribution.Types.Flag -import Distribution.Types.ForeignLib -import Distribution.Types.ForeignLibOption -import Distribution.Types.ForeignLibType -import Distribution.Types.GenericPackageDescription -import Distribution.Types.HookedBuildInfo -import Distribution.Types.IncludeRenaming -import Distribution.Types.LegacyExeDependency -import Distribution.Types.Library -import Distribution.Types.LibraryName -import Distribution.Types.LibraryVisibility -import Distribution.Types.Mixin -import Distribution.Types.ModuleReexport -import Distribution.Types.ModuleRenaming -import Distribution.Types.PackageDescription -import Distribution.Types.PackageId -import Distribution.Types.PackageName -import Distribution.Types.PkgconfigDependency -import Distribution.Types.PkgconfigName -import Distribution.Types.PkgconfigVersion -import Distribution.Types.PkgconfigVersionRange -import Distribution.Types.SetupBuildInfo -import Distribution.Types.SourceRepo -import Distribution.Types.TestSuite -import Distribution.Types.TestSuiteInterface -import Distribution.Types.TestType -import Distribution.Types.UnqualComponentName diff --git a/src/Distribution/PackageDescription/Check.hs b/src/Distribution/PackageDescription/Check.hs --- a/src/Distribution/PackageDescription/Check.hs +++ b/src/Distribution/PackageDescription/Check.hs @@ -52,6 +52,7 @@ import Distribution.Simple.Utils hiding (findPackageDesc, notice) import Distribution.System import Distribution.Types.ComponentRequestedSpec +import Distribution.Types.PackageName.Magic import Distribution.Utils.Generic (isAscii) import Distribution.Verbosity import Distribution.Version @@ -154,6 +155,8 @@ ++ checkUnusedFlags gpkg ++ checkUnicodeXFields gpkg ++ checkPathsModuleExtensions pkg + ++ checkSetupVersions gpkg + ++ checkDuplicateModules gpkg where pkg = fromMaybe (flattenPackageDescription gpkg) mpkg @@ -240,13 +243,8 @@ checkLibrary pkg lib = catMaybes [ - check (not (null moduleDuplicates)) $ - PackageBuildImpossible $ - "Duplicate modules in library: " - ++ commaSep (map prettyShow moduleDuplicates) - -- TODO: This check is bogus if a required-signature was passed through - , check (null (explicitLibModules lib) && null (reexportedModules lib)) $ + check (null (explicitLibModules lib) && null (reexportedModules lib)) $ PackageDistSuspiciousWarn $ showLibraryName (libName lib) ++ " does not expose any modules" @@ -277,10 +275,6 @@ | specVersion pkg >= ver = Nothing | otherwise = check cond pc - -- TODO: not sure if this check is always right in Backpack - moduleDuplicates = dups (explicitLibModules lib ++ - map moduleReexportName (reexportedModules lib)) - allExplicitIncludes :: L.HasBuildInfo a => a -> [FilePath] allExplicitIncludes x = view L.includes x ++ view L.installIncludes x @@ -291,8 +285,9 @@ check (null (modulePath exe)) $ PackageBuildImpossible $ "No 'main-is' field found for executable " ++ prettyShow (exeName exe) - - , check (not (null (modulePath exe)) + -- This check does not apply to scripts. + , check (package pkg /= fakePackageId + && not (null (modulePath exe)) && (not $ fileExtensionSupportedLanguage $ modulePath exe)) $ PackageBuildImpossible $ "The 'main-is' field must specify a '.hs' or '.lhs' file " @@ -304,12 +299,7 @@ && takeExtension (modulePath exe) `notElem` [".hs", ".lhs"]) $ PackageDistInexcusable $ "The package uses a C/C++/obj-C source file for the 'main-is' field. " - ++ "To use this feature you must specify 'cabal-version: >= 1.18'." - - , check (not (null moduleDuplicates)) $ - PackageBuildImpossible $ - "Duplicate modules in executable '" ++ prettyShow (exeName exe) ++ "': " - ++ commaSep (map prettyShow moduleDuplicates) + ++ "To use this feature you need to specify 'cabal-version: 1.18' or higher." -- check that all autogen-modules appear on other-modules , check @@ -323,8 +313,6 @@ (not $ and $ map (flip elem (view L.includes exe)) (view L.autogenIncludes exe)) $ PackageBuildImpossible "An include in 'autogen-includes' is not in 'includes'." ] - where - moduleDuplicates = dups (exeModules exe) checkTestSuite :: PackageDescription -> TestSuite -> [PackageCheck] checkTestSuite pkg test = @@ -334,21 +322,18 @@ TestSuiteUnsupported tt@(TestTypeUnknown _ _) -> Just $ PackageBuildWarning $ quote (prettyShow tt) ++ " is not a known type of test suite. " + ++ "Either remove the 'type' field or use a known type. " ++ "The known test suite types are: " ++ commaSep (map prettyShow knownTestTypes) TestSuiteUnsupported tt -> Just $ PackageBuildWarning $ quote (prettyShow tt) ++ " is not a supported test suite version. " + ++ "Either remove the 'type' field or use a known type. " ++ "The known test suite types are: " ++ commaSep (map prettyShow knownTestTypes) _ -> Nothing - , check (not $ null moduleDuplicates) $ - PackageBuildImpossible $ - "Duplicate modules in test suite '" ++ prettyShow (testName test) ++ "': " - ++ commaSep (map prettyShow moduleDuplicates) - , check mainIsWrongExt $ PackageBuildImpossible $ "The 'main-is' field must specify a '.hs' or '.lhs' file " @@ -358,7 +343,7 @@ , checkSpecVersion pkg CabalSpecV1_18 (mainIsNotHsExt && not mainIsWrongExt) $ PackageDistInexcusable $ "The package uses a C/C++/obj-C source file for the 'main-is' field. " - ++ "To use this feature you must specify 'cabal-version: >= 1.18'." + ++ "To use this feature you need to specify 'cabal-version: 1.18' or higher." -- check that all autogen-modules appear on other-modules , check @@ -373,8 +358,6 @@ PackageBuildImpossible "An include in 'autogen-includes' is not in 'includes'." ] where - moduleDuplicates = dups $ testModules test - mainIsWrongExt = case testInterface test of TestSuiteExeV10 _ f -> not $ fileExtensionSupportedLanguage f _ -> False @@ -391,21 +374,18 @@ BenchmarkUnsupported tt@(BenchmarkTypeUnknown _ _) -> Just $ PackageBuildWarning $ quote (prettyShow tt) ++ " is not a known type of benchmark. " + ++ "Either remove the 'type' field or use a known type. " ++ "The known benchmark types are: " ++ commaSep (map prettyShow knownBenchmarkTypes) BenchmarkUnsupported tt -> Just $ PackageBuildWarning $ quote (prettyShow tt) ++ " is not a supported benchmark version. " + ++ "Either remove the 'type' field or use a known type. " ++ "The known benchmark types are: " ++ commaSep (map prettyShow knownBenchmarkTypes) _ -> Nothing - , check (not $ null moduleDuplicates) $ - PackageBuildImpossible $ - "Duplicate modules in benchmark '" ++ prettyShow (benchmarkName bm) ++ "': " - ++ commaSep (map prettyShow moduleDuplicates) - , check mainIsWrongExt $ PackageBuildImpossible $ "The 'main-is' field must specify a '.hs' or '.lhs' file " @@ -424,8 +404,6 @@ PackageBuildImpossible "An include in 'autogen-includes' is not in 'includes'." ] where - moduleDuplicates = dups $ benchmarkModules bm - mainIsWrongExt = case benchmarkInterface bm of BenchmarkExeV10 _ f -> takeExtension f `notElem` [".hs", ".lhs"] _ -> False @@ -440,10 +418,9 @@ check (not . FilePath.Windows.isValid . prettyShow . packageName $ pkg) $ PackageDistInexcusable $ - "Unfortunately, the package name '" ++ prettyShow (packageName pkg) - ++ "' is one of the reserved system file names on Windows. Many tools " - ++ "need to convert package names to file names so using this name " - ++ "would cause problems." + "The package name '" ++ prettyShow (packageName pkg) ++ "' is " + ++ "invalid on Windows. Many tools need to convert package names to " + ++ "file names so using this name would cause problems." , check ((isPrefixOf "z-") . prettyShow . packageName $ pkg) $ PackageDistInexcusable $ @@ -509,7 +486,7 @@ --TODO: recommend not using the stability field --TODO: recommend specifying a source repo - , check (ShortText.length (synopsis pkg) >= 80) $ + , check (ShortText.length (synopsis pkg) > 80) $ PackageDistSuspicious "The 'synopsis' field is rather long (max 80 chars is recommended)." @@ -525,9 +502,8 @@ ++ "The 'description' field content is typically shown by tooling " ++ "(e.g. 'cabal info', Haddock, Hackage) below the 'synopsis' which " ++ "serves as a headline. " - ++ "Please refer to " - ++ " for more details." + ++ "Please refer to for more details." -- check use of impossible constraints "tested-with: GHC== 6.10 && ==6.12" , check (not (null testedWithImpossibleRanges)) $ @@ -768,10 +744,6 @@ PackageDistInexcusable "The 'subdir' field of a source-repository must be a relative path." - , check (maybe False isAbsoluteOnAnyPlatform (repoSubdir repo)) $ - PackageDistInexcusable - "The 'subdir' field of a source-repository must be a relative path." - , do subdir <- repoSubdir repo err <- isGoodRelativeDirectoryPath subdir @@ -915,9 +887,15 @@ , checkAlternatives fieldName "extra-libraries" [ (flag, lib) | flag@('-':'l':lib) <- all_ghc_options ] + , checkAlternatives fieldName "extra-libraries-static" + [ (flag, lib) | flag@('-':'l':lib) <- all_ghc_options ] + , checkAlternatives fieldName "extra-lib-dirs" [ (flag, dir) | flag@('-':'L':dir) <- all_ghc_options ] + , checkAlternatives fieldName "extra-lib-dirs-static" + [ (flag, dir) | flag@('-':'L':dir) <- all_ghc_options ] + , checkAlternatives fieldName "frameworks" [ (flag, fmwk) | (flag@"-framework", fmwk) <- zip all_ghc_options (safeTail all_ghc_options) ] @@ -1035,7 +1013,7 @@ [ (flag, dir) | flag@('-':'I':dir) <- all_cppOptions ] ] ++ - [ PackageBuildWarning $ "'cpp-options': " ++ opt ++ " is not portable C-preprocessor flag" + [ PackageBuildWarning $ "'cpp-options: " ++ opt ++ "' is not a portable C-preprocessor flag." | opt <- all_cppOptions -- "-I" is handled above, we allow only -DNEWSTUFF and -UOLDSTUFF , not $ any (`isPrefixOf` opt) ["-D", "-U", "-I" ] @@ -1057,9 +1035,15 @@ = PathKindFile | PathKindDirectory | PathKindGlob + deriving (Eq) checkPaths :: PackageDescription -> [PackageCheck] checkPaths pkg = + checkPackageFileNamesWithGlob + [ (kind == PathKindGlob, path) + | (path, _, kind) <- relPaths ++ absPaths + ] + ++ [ PackageBuildWarning $ quote (field ++ ": " ++ path) ++ " is a relative path outside of the source tree. " @@ -1068,12 +1052,13 @@ , isOutsideTree path ] ++ [ PackageDistInexcusable $ - quote (field ++ ": " ++ path) ++ " is an absolute path." + quote (field ++ ": " ++ path) ++ " specifies an absolute path, but the " + ++ quote field ++ " field must use relative paths." | (path, field, _) <- relPaths , isAbsoluteOnAnyPlatform path ] ++ [ PackageDistInexcusable $ - quote (field ++ ": " ++ path) ++ " is not good relative path: " ++ err + quote (field ++ ": " ++ path) ++ " is not a good relative path: " ++ show err | (path, field, kind) <- relPaths -- these are not paths, but globs... , err <- maybeToList $ case kind of @@ -1092,7 +1077,7 @@ , isInsideDist path ] ++ [ PackageDistInexcusable $ - "The 'ghc-options' contains the path '" ++ path ++ "' which points " + "The 'ghc-options' contain the path '" ++ path ++ "' which points " ++ "inside the 'dist' directory. This is not reliable because the " ++ "location of this directory is configurable by the user (or package " ++ "manager). In addition the layout of the 'dist' directory is subject " @@ -1154,7 +1139,8 @@ absPaths = concat [ [ (path, "includes", PathKindFile) | path <- includes bi ] ++ [ (path, "include-dirs", PathKindDirectory) | path <- includeDirs bi ] ++ - [ (path, "extra-lib-dirs", PathKindDirectory) | path <- extraLibDirs bi ] + [ (path, "extra-lib-dirs", PathKindDirectory) | path <- extraLibDirs bi ] ++ + [ (path, "extra-lib-dirs-static", PathKindDirectory) | path <- extraLibDirsStatic bi ] | bi <- allBuildInfo pkg ] @@ -1200,7 +1186,7 @@ (not . null $ extraDocFiles pkg) $ PackageDistInexcusable $ "To use the 'extra-doc-files' field the package needs to specify " - ++ "at least 'cabal-version: >= 1.18'." + ++ "'cabal-version: 1.18' or higher." , checkVersion CabalSpecV2_0 (not (null (subLibraries pkg))) $ @@ -1213,7 +1199,7 @@ (any (not.null.reexportedModules) (allLibraries pkg)) $ PackageDistInexcusable $ "To use the 'reexported-module' field the package needs to specify " - ++ "at least 'cabal-version: >= 1.22'." + ++ "'cabal-version: 1.22' or higher." -- check use of thinning and renaming , checkVersion CabalSpecV2_0 usesBackpackIncludes $ @@ -1226,7 +1212,7 @@ -- Just a warning, because this won't break on old Cabal versions. PackageDistSuspiciousWarn $ "To use the 'extra-framework-dirs' field the package needs to specify" - ++ " at least 'cabal-version: >= 1.24'." + ++ " 'cabal-version: 1.24' or higher." -- check use of default-extensions field -- don't need to do the equivalent check for other-extensions @@ -1278,12 +1264,12 @@ ++ "so you need to specify 'cabal-version: >= 1.6'." -- check for new language extensions - , checkVersion CabalSpecV1_4 (not (null mentionedExtensionsThatNeedCabal12)) $ + , checkVersion CabalSpecV1_2 (not (null mentionedExtensionsThatNeedCabal12)) $ PackageDistInexcusable $ "Unfortunately the language extensions " ++ commaSep (map (quote . prettyShow) mentionedExtensionsThatNeedCabal12) ++ " break the parser in earlier Cabal versions so you need to " - ++ "specify 'cabal-version: >= 1.4'. Alternatively if you require " + ++ "specify 'cabal-version: >= 1.2'. Alternatively if you require " ++ "compatibility with earlier Cabal versions then you may be able to " ++ "use an equivalent compiler-specific flag." @@ -1300,7 +1286,7 @@ && isNothing (setupBuildInfo pkg) && buildType pkg == Custom) $ PackageBuildWarning $ - "Packages using 'cabal-version: >= 1.24' with 'build-type: Custom' " + "Packages using 'cabal-version: 1.24' or higher with 'build-type: Custom' " ++ "must use a 'custom-setup' section with a 'setup-depends' field " ++ "that specifies the dependencies of the Setup.hs script itself. " ++ "The 'setup-depends' field uses the same syntax as 'build-depends', " @@ -1311,8 +1297,8 @@ && buildType pkg == Custom) $ PackageDistSuspiciousWarn $ "From version 1.24 cabal supports specifying explicit dependencies " - ++ "for Custom setup scripts. Consider using cabal-version >= 1.24 and " - ++ "adding a 'custom-setup' section with a 'setup-depends' field " + ++ "for Custom setup scripts. Consider using 'cabal-version: 1.24' or higher " + ++ "and adding a 'custom-setup' section with a 'setup-depends' field " ++ "that specifies the dependencies of the Setup.hs script itself. " ++ "The 'setup-depends' field uses the same syntax as 'build-depends', " ++ "so a simple example would be 'setup-depends: base, Cabal'." @@ -1407,7 +1393,7 @@ -- For example this bans "build-depends: base >= 3". -- It should probably be "build-depends: base >= 3 && < 4" -- which is the same as "build-depends: base == 3.*" - check (not (boundedAbove baseDependency)) $ + check (not (hasUpperBound baseDependency)) $ PackageDistInexcusable $ "The dependency 'build-depends: base' does not specify an upper " ++ "bound on the version number. Each major release of the 'base' " @@ -1422,21 +1408,7 @@ ] where - -- TODO: What we really want to do is test if there exists any - -- configuration in which the base version is unbounded above. - -- However that's a bit tricky because there are many possible - -- configurations. As a cheap easy and safe approximation we will - -- pick a single "typical" configuration and check if that has an - -- open upper bound. To get a typical configuration we finalise - -- using no package index and the current platform. - finalised = finalizePD - mempty defaultComponentRequestedSpec (const True) - buildPlatform - (unknownCompilerInfo - (CompilerId buildCompilerFlavor nullVersion) - NoAbiTag) - [] pkg - baseDependency = case finalised of + baseDependency = case typicalPkg pkg of Right (pkg', _) | not (null baseDeps) -> foldr intersectVersionRanges anyVersion baseDeps where @@ -1446,18 +1418,9 @@ -- Just in case finalizePD fails for any reason, -- or if the package doesn't depend on the base package at all, - -- then we will just skip the check, since boundedAbove noVersion = True + -- then we will just skip the check, since hasUpperBound noVersion = True _ -> noVersion - -- TODO: move to Distribution.Version - boundedAbove :: VersionRange -> Bool - boundedAbove vr = case asVersionIntervals vr of - [] -> True -- this is the inconsistent version range. - (x:xs) -> case last (x:|xs) of - VersionInterval _ UpperBound {} -> True - VersionInterval _ NoUpperBound -> False - - checkConditionals :: GenericPackageDescription -> [PackageCheck] checkConditionals pkg = catMaybes [ @@ -1565,11 +1528,11 @@ | specVersion pd >= CabalSpecV2_2 = [] | any checkBI (allBuildInfo pd) || any checkLib (allLibraries pd) = return $ PackageBuildImpossible $ unwords - [ "The package uses RebindableSyntax with OverloadedStrings or OverloadedLists" - , "in default-extensions, and also Paths_ autogen module." - , "That configuration is known to cause compile failures with Cabal < 2.2." - , "To use these default-extensions with Paths_ autogen module" - , "specify at least 'cabal-version: 2.2'." + [ "Packages using RebindableSyntax with OverloadedStrings or" + , "OverloadedLists in default-extensions, in conjunction with the" + , "autogenerated module Paths_*, are known to cause compile failures" + , "with Cabal < 2.2. To use these default-extensions with a Paths_*" + , "autogen module, specify at least 'cabal-version: 2.2'." ] | otherwise = [] where @@ -1591,7 +1554,7 @@ -- | Checks GHC options from all ghc-*-options fields from the given BuildInfo -- and reports flags that are OK during development process, but are --- unacceptable in a distrubuted package +-- unacceptable in a distributed package checkDevelopmentOnlyFlagsBuildInfo :: BuildInfo -> [PackageCheck] checkDevelopmentOnlyFlagsBuildInfo bi = checkDevelopmentOnlyFlagsOptions "ghc-options" (hcOptions GHC bi) @@ -1616,7 +1579,7 @@ PackageDistInexcusable $ "'" ++ fieldName ++ ": -Werror' makes the package easy to " ++ "break with future GHC versions because new GHC versions often " - ++ "add new warnings. " + ++ "add new warnings." ++ extraExplanation , check (has_J) $ @@ -1628,7 +1591,7 @@ , checkFlags ["-fdefer-type-errors"] $ PackageDistInexcusable $ "'" ++ fieldName ++ ": -fdefer-type-errors' is fine during development but " - ++ "is not appropriate for a distributed package. " + ++ "is not appropriate for a distributed package." ++ extraExplanation -- -dynamic is not a debug flag @@ -1636,7 +1599,7 @@ ghcOptions) $ PackageDistInexcusable $ "'" ++ fieldName ++ ": -d*' debug flags are not appropriate " - ++ "for a distributed package. " + ++ "for a distributed package." ++ extraExplanation , checkFlags ["-fprof-auto", "-fprof-auto-top", "-fprof-auto-calls", @@ -1649,7 +1612,7 @@ ++ "that use this one these flags clutter the profile output with " ++ "excessive detail. If you think other packages really want to see " ++ "cost centres from this package then use '-fprof-auto-exported' " - ++ "which puts cost centres only on exported functions. " + ++ "which puts cost centres only on exported functions." ++ extraExplanation ] where @@ -1834,8 +1797,8 @@ Right pdfile | takeFileName pdfile == expectedCabalname -> return Nothing | otherwise -> return $ Just $ PackageDistInexcusable $ - "The filename " ++ pdfile ++ " does not match package name " ++ - "(expected: " ++ expectedCabalname ++ ")" + "The filename " ++ quote pdfile ++ " does not match package name " ++ + "(expected: " ++ quote expectedCabalname ++ ")" where pkgname = unPackageName . packageName $ pkg expectedCabalname = pkgname <.> "cabal" @@ -1918,6 +1881,7 @@ | bi <- allBuildInfo pkg , (dir, kind) <- [ (dir, "extra-lib-dirs") | dir <- extraLibDirs bi ] + ++ [ (dir, "extra-lib-dirs-static") | dir <- extraLibDirsStatic bi ] ++ [ (dir, "extra-framework-dirs") | dir <- extraFrameworkDirs bi ] ++ [ (dir, "include-dirs") | dir <- includeDirs bi ] @@ -1926,7 +1890,7 @@ missing <- filterM (liftM not . doesDirectoryExist ops . fst) dirs return [ PackageBuildWarning { explanation = quote (kind ++ ": " ++ dir) - ++ " directory does not exist." + ++ " specifies a directory which does not exist." } | (dir, kind) <- missing ] @@ -1968,25 +1932,39 @@ -- should be done for example when creating or validating a package tarball. -- checkPackageFileNames :: [FilePath] -> [PackageCheck] -checkPackageFileNames files = - (take 1 . mapMaybe checkWindowsPath $ files) - ++ (take 1 . mapMaybe checkTarPath $ files) - -- If we get any of these checks triggering then we're likely to get - -- many, and that's probably not helpful, so return at most one. +checkPackageFileNames = checkPackageFileNamesWithGlob . zip (repeat True) -checkWindowsPath :: FilePath -> Maybe PackageCheck -checkWindowsPath path = - check (not $ FilePath.Windows.isValid path') $ - PackageDistInexcusable $ - "Unfortunately, the file " ++ quote path ++ " is not a valid file " - ++ "name on Windows which would cause portability problems for this " - ++ "package. Windows file names cannot contain any of the characters " - ++ "\":*?<>|\" and there are a few reserved names including \"aux\", " - ++ "\"nul\", \"con\", \"prn\", \"com1-9\", \"lpt1-9\" and \"clock$\"." +checkPackageFileNamesWithGlob :: [(Bool, FilePath)] -> [PackageCheck] +checkPackageFileNamesWithGlob files = + catMaybes $ + checkWindowsPaths files + : + [ checkTarPath file + | (_, file) <- files + ] + +checkWindowsPaths :: [(Bool, FilePath)] -> Maybe PackageCheck +checkWindowsPaths paths = + case filter (not . FilePath.Windows.isValid . escape) paths of + [] -> Nothing + ps -> Just $ + PackageDistInexcusable $ + "The " ++ quotes (map snd ps) ++ " invalid on Windows, which " + ++ "would cause portability problems for this package. Windows file " + ++ "names cannot contain any of the characters \":*?<>|\" and there " + ++ "a few reserved names including \"aux\", \"nul\", \"con\", " + ++ "\"prn\", \"com1-9\", \"lpt1-9\" and \"clock$\"." where - path' = ".\\" ++ path -- force a relative name to catch invalid file names like "f:oo" which -- otherwise parse as file "oo" in the current directory on the 'f' drive. + escape (isGlob, path) = (".\\" ++) + -- glob paths will be expanded before being dereferenced, so asterisks + -- shouldn't count against them. + $ map (\c -> if c == '*' && isGlob then 'x' else c) path + quotes [failed] = + "path " ++ quote failed ++ " is" + quotes failed = + "paths " ++ intercalate ", " (map quote failed) ++ " are" -- | Check a file name is valid for the portable POSIX tar format. -- @@ -2127,6 +2105,64 @@ ++ " directory by that name." ] +-- | Check that setup dependencies, have proper bounds. +-- In particular, @base@ and @Cabal@ upper bounds are mandatory. +checkSetupVersions :: GenericPackageDescription -> [PackageCheck] +checkSetupVersions pkg = + [ emitError nameStr + | (name, vr) <- Map.toList deps + , not (hasUpperBound vr) + , let nameStr = unPackageName name + , nameStr `elem` criticalPkgs + ] + where + criticalPkgs = ["Cabal", "base"] + deps = case typicalPkg pkg of + Right (pkgs', _) -> + Map.fromListWith intersectVersionRanges + [ (pname, vr) + | sbi <- maybeToList $ setupBuildInfo pkgs' + , Dependency pname vr _ <- setupDepends sbi + ] + _ -> Map.empty + emitError nm = + PackageDistInexcusable $ + "The dependency 'setup-depends: '"++nm++"' does not specify an " + ++ "upper bound on the version number. Each major release of the " + ++ "'"++nm++"' package changes the API in various ways and most " + ++ "packages will need some changes to compile with it. If you are " + ++ "not sure what upper bound to use then use the next major " + ++ "version." + +checkDuplicateModules :: GenericPackageDescription -> [PackageCheck] +checkDuplicateModules pkg = + concatMap checkLib (maybe id (:) (condLibrary pkg) . map snd $ condSubLibraries pkg) + ++ concatMap checkExe (map snd $ condExecutables pkg) + ++ concatMap checkTest (map snd $ condTestSuites pkg) + ++ concatMap checkBench (map snd $ condBenchmarks pkg) + where + -- the duplicate modules check is has not been thoroughly vetted for backpack + checkLib = checkDups "library" (\l -> explicitLibModules l ++ map moduleReexportName (reexportedModules l)) + checkExe = checkDups "executable" exeModules + checkTest = checkDups "test suite" testModules + checkBench = checkDups "benchmark" benchmarkModules + checkDups s getModules t = + let sumPair (x,x') (y,y') = (x + x' :: Int, y + y' :: Int) + mergePair (x, x') (y, y') = (x + x', max y y') + maxPair (x, x') (y, y') = (max x x', max y y') + libMap = foldCondTree Map.empty + (\(_,v) -> Map.fromListWith sumPair . map (\x -> (x,(1, 1))) $ getModules v ) + (Map.unionWith mergePair) -- if a module may occur in nonexclusive branches count it twice strictly and once loosely. + (Map.unionWith maxPair) -- a module occurs the max of times it might appear in exclusive branches + t + dupLibsStrict = Map.keys $ Map.filter ((>1) . fst) libMap + dupLibsLax = Map.keys $ Map.filter ((>1) . snd) libMap + in if not (null dupLibsLax) + then [PackageBuildImpossible $ "Duplicate modules in " ++ s ++ ": " ++ commaSep (map prettyShow dupLibsLax)] + else if not (null dupLibsStrict) + then [PackageDistSuspicious $ "Potential duplicate modules (subject to conditionals) in " ++ s ++ ": " ++ commaSep (map prettyShow dupLibsStrict)] + else [] + -- ------------------------------------------------------------ -- * Utils -- ------------------------------------------------------------ @@ -2148,12 +2184,18 @@ isHaskell = extension `elem` [".hs", ".lhs"] isC = isJust (filenameCDialect extension) --- | Whether a path is a good relative path. +-- | Whether a path is a good relative path. We aren't worried about perfect +-- cross-platform compatibility here; this function just checks the paths in +-- the (local) @.cabal@ file, while only Hackage needs the portability. -- -- >>> let test fp = putStrLn $ show (isGoodRelativeDirectoryPath fp) ++ "; " ++ show (isGoodRelativeFilePath fp) -- --- >>> test "foo/bar/quu" +-- Note that "foo./bar.hs" would be invalid on Windows. +-- +-- >>> traverse_ test ["foo/bar/quu", "a/b.hs", "foo./bar.hs"] -- Nothing; Nothing +-- Nothing; Nothing +-- Nothing; Nothing -- -- Trailing slash is not allowed for files, for directories it is ok. -- @@ -2169,68 +2211,56 @@ -- -- Lastly, not good file nor directory cases: -- --- >>> traverse_ test ["", "/tmp/src", "foo//bar", "foo/.", "foo/./bar", "foo/../bar", "foo*bar"] +-- >>> traverse_ test ["", "/tmp/src", "foo//bar", "foo/.", "foo/./bar", "foo/../bar"] -- Just "empty path"; Just "empty path" -- Just "posix absolute path"; Just "posix absolute path" -- Just "empty path segment"; Just "empty path segment" -- Just "trailing same directory segment: ."; Just "trailing same directory segment: ." --- Just "same directory segment: ."; Just "same directory segment: .." +-- Just "same directory segment: ."; Just "same directory segment: ." -- Just "parent directory segment: .."; Just "parent directory segment: .." --- Just "reserved character '*'"; Just "reserved character '*'" -- -- For the last case, 'isGoodRelativeGlob' doesn't warn: -- --- >>> traverse_ (print . isGoodRelativeGlob) ["foo/../bar", "foo*bar"] +-- >>> traverse_ (print . isGoodRelativeGlob) ["foo/../bar"] -- Just "parent directory segment: .." --- Nothing -- isGoodRelativeFilePath :: FilePath -> Maybe String isGoodRelativeFilePath = state0 where - -- Reserved characters - -- https://docs.microsoft.com/en-us/windows/win32/fileio/naming-a-file - isReserved c = c `elem` "<>:\"\\/|?*" - -- initial state state0 [] = Just "empty path" state0 (c:cs) | c == '.' = state1 cs | c == '/' = Just "posix absolute path" - | isReserved c = Just ("reserved character " ++ show c) - | otherwise = state3 cs + | otherwise = state5 cs - -- after . + -- after initial . state1 [] = Just "trailing dot segment" state1 (c:cs) | c == '.' = state4 cs | c == '/' = state2 cs - | isReserved c = Just ("reserved character " ++ show c) | otherwise = state5 cs - -- after ./ + -- after ./ or after / between segments state2 [] = Just "trailing slash" state2 (c:cs) | c == '.' = state3 cs | c == '/' = Just "empty path segment" - | isReserved c = Just ("reserved character " ++ show c) | otherwise = state5 cs -- after non-first segment's . state3 [] = Just "trailing same directory segment: ." state3 (c:cs) | c == '.' = state4 cs - | c == '/' = Just "same directory segment: .." - | isReserved c = Just ("reserved character " ++ show c) + | c == '/' = Just "same directory segment: ." | otherwise = state5 cs - -- after non-first segment's .. + -- after .. state4 [] = Just "trailing parent directory segment: .." state4 (c:cs) | c == '.' = state5 cs | c == '/' = Just "parent directory segment: .." - | isReserved c = Just ("reserved character " ++ show c) | otherwise = state5 cs -- in a segment which is ok. state5 [] = Nothing - state5 (c:cs) | c == '.' = state3 cs + state5 (c:cs) | c == '.' = state5 cs | c == '/' = state2 cs - | isReserved c = Just ("reserved character " ++ show c) | otherwise = state5 cs -- | See 'isGoodRelativeFilePath'. @@ -2246,50 +2276,40 @@ isGoodRelativeDirectoryPath :: FilePath -> Maybe String isGoodRelativeDirectoryPath = state0 where - -- Reserved characters - -- https://docs.microsoft.com/en-us/windows/win32/fileio/naming-a-file - isReserved c = c `elem` "<>:\"\\/|?*" - -- initial state state0 [] = Just "empty path" state0 (c:cs) | c == '.' = state5 cs | c == '/' = Just "posix absolute path" - | isReserved c = Just ("reserved character " ++ show c) | otherwise = state4 cs - -- after ./ - state1 [] = Nothing -- "./" + -- after initial ./ or after / between segments + state1 [] = Nothing state1 (c:cs) | c == '.' = state2 cs | c == '/' = Just "empty path segment" - | isReserved c = Just ("reserved character " ++ show c) | otherwise = state4 cs -- after non-first setgment's . state2 [] = Just "trailing same directory segment: ." state2 (c:cs) | c == '.' = state3 cs | c == '/' = Just "same directory segment: ." - | isReserved c = Just ("reserved character " ++ show c) | otherwise = state4 cs - -- after non-first segment's .. - state3 [] = Just "trailing parent directory segment: ." + -- after .. + state3 [] = Just "trailing parent directory segment: .." state3 (c:cs) | c == '.' = state4 cs | c == '/' = Just "parent directory segment: .." - | isReserved c = Just ("reserved character " ++ show c) | otherwise = state4 cs -- in a segment which is ok. state4 [] = Nothing state4 (c:cs) | c == '.' = state4 cs | c == '/' = state1 cs - | isReserved c = Just ("reserved character " ++ show c) | otherwise = state4 cs - -- after . + -- after initial . state5 [] = Nothing -- "." state5 (c:cs) | c == '.' = state3 cs | c == '/' = state1 cs - | isReserved c = Just ("reserved character " ++ show c) | otherwise = state4 cs -- [Note: Good relative paths] @@ -2301,11 +2321,11 @@ -- import Kleene -- import Kleene.ERE (ERE (..), intersections) -- --- data C = CDot | CSlash | COtherReserved | CChar +-- data C = CDot | CSlash | CChar -- deriving (Eq, Ord, Enum, Bounded, Show) -- -- reservedR :: ERE C --- reservedR = notChar CSlash /\ notChar COtherReserved +-- reservedR = notChar CSlash -- -- pathPieceR :: ERE C -- pathPieceR = intersections @@ -2332,31 +2352,24 @@ -- @ -- 0 -> \x -> if -- | x <= CDot -> 1 --- | x <= COtherReserved -> 6 -- | otherwise -> 5 -- 1 -> \x -> if -- | x <= CDot -> 4 -- | x <= CSlash -> 2 --- | x <= COtherReserved -> 6 -- | otherwise -> 5 -- 2 -> \x -> if -- | x <= CDot -> 3 --- | x <= COtherReserved -> 6 -- | otherwise -> 5 -- 3 -> \x -> if -- | x <= CDot -> 4 --- | x <= COtherReserved -> 6 -- | otherwise -> 5 -- 4 -> \x -> if -- | x <= CDot -> 5 --- | x <= COtherReserved -> 6 -- | otherwise -> 5 -- 5+ -> \x -> if -- | x <= CDot -> 5 -- | x <= CSlash -> 2 --- | x <= COtherReserved -> 6 -- | otherwise -> 5 --- 6 -> \_ -> 6 -- black hole -- @ -- -- and @dirPathR@: @@ -2364,29 +2377,40 @@ -- @ -- 0 -> \x -> if -- | x <= CDot -> 5 --- | x <= COtherReserved -> 6 -- | otherwise -> 4 -- 1+ -> \x -> if -- | x <= CDot -> 2 --- | x <= COtherReserved -> 6 -- | otherwise -> 4 -- 2 -> \x -> if -- | x <= CDot -> 3 --- | x <= COtherReserved -> 6 -- | otherwise -> 4 -- 3 -> \x -> if -- | x <= CDot -> 4 --- | x <= COtherReserved -> 6 -- | otherwise -> 4 -- 4+ -> \x -> if -- | x <= CDot -> 4 -- | x <= CSlash -> 1 --- | x <= COtherReserved -> 6 -- | otherwise -> 4 -- 5+ -> \x -> if -- | x <= CDot -> 3 -- | x <= CSlash -> 1 --- | x <= COtherReserved -> 6 -- | otherwise -> 4 --- 6 -> \_ -> 6 -- black hole -- @ + +-- +-- TODO: What we really want to do is test if there exists any +-- configuration in which the base version is unbounded above. +-- However that's a bit tricky because there are many possible +-- configurations. As a cheap easy and safe approximation we will +-- pick a single "typical" configuration and check if that has an +-- open upper bound. To get a typical configuration we finalise +-- using no package index and the current platform. +typicalPkg :: GenericPackageDescription + -> Either [Dependency] (PackageDescription, FlagAssignment) +typicalPkg = finalizePD + mempty defaultComponentRequestedSpec (const True) + buildPlatform + (unknownCompilerInfo + (CompilerId buildCompilerFlavor nullVersion) + NoAbiTag) + [] diff --git a/src/Distribution/PackageDescription/Configuration.hs b/src/Distribution/PackageDescription/Configuration.hs deleted file mode 100644 --- a/src/Distribution/PackageDescription/Configuration.hs +++ /dev/null @@ -1,600 +0,0 @@ --- -fno-warn-deprecations for use of Map.foldWithKey -{-# OPTIONS_GHC -fno-warn-deprecations #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.PackageDescription.Configuration --- Copyright : Thomas Schilling, 2007 --- License : BSD3 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This is about the cabal configurations feature. It exports --- 'finalizePD' and 'flattenPackageDescription' which are --- functions for converting 'GenericPackageDescription's down to --- 'PackageDescription's. It has code for working with the tree of conditions --- and resolving or flattening conditions. - -module Distribution.PackageDescription.Configuration ( - finalizePD, - flattenPackageDescription, - - -- Utils - parseCondition, - freeVars, - extractCondition, - extractConditions, - addBuildableCondition, - mapCondTree, - mapTreeData, - mapTreeConds, - mapTreeConstrs, - transformAllBuildInfos, - transformAllBuildDepends, - transformAllBuildDependsN, - ) where - -import Distribution.Compat.Prelude -import Prelude () - --- lens -import qualified Distribution.Types.BuildInfo.Lens as L -import qualified Distribution.Types.GenericPackageDescription.Lens as L -import qualified Distribution.Types.PackageDescription.Lens as L -import qualified Distribution.Types.SetupBuildInfo.Lens as L - -import Distribution.Compat.CharParsing hiding (char) -import qualified Distribution.Compat.CharParsing as P -import Distribution.Compat.Lens -import Distribution.Compiler -import Distribution.PackageDescription -import Distribution.PackageDescription.Utils -import Distribution.Parsec -import Distribution.Pretty -import Distribution.Simple.Utils -import Distribution.System -import Distribution.Types.Component -import Distribution.Utils.Path -import Distribution.Types.ComponentRequestedSpec -import Distribution.Types.DependencyMap -import Distribution.Types.PackageVersionConstraint -import Distribution.Version - -import qualified Data.Map.Lazy as Map -import Data.Tree (Tree (Node)) - ------------------------------------------------------------------------------- - --- | Simplify a configuration condition using the OS and arch names. Returns --- the names of all the flags occurring in the condition. -simplifyWithSysParams :: OS -> Arch -> CompilerInfo -> Condition ConfVar - -> (Condition FlagName, [FlagName]) -simplifyWithSysParams os arch cinfo cond = (cond', flags) - where - (cond', flags) = simplifyCondition cond interp - interp (OS os') = Right $ os' == os - interp (Arch arch') = Right $ arch' == arch - interp (Impl comp vr) - | matchImpl (compilerInfoId cinfo) = Right True - | otherwise = case compilerInfoCompat cinfo of - -- fixme: treat Nothing as unknown, rather than empty list once we - -- support partial resolution of system parameters - Nothing -> Right False - Just compat -> Right (any matchImpl compat) - where - matchImpl (CompilerId c v) = comp == c && v `withinRange` vr - interp (PackageFlag f) = Left f - --- TODO: Add instances and check --- --- prop_sC_idempotent cond a o = cond' == cond'' --- where --- cond' = simplifyCondition cond a o --- cond'' = simplifyCondition cond' a o --- --- prop_sC_noLits cond a o = isLit res || not (hasLits res) --- where --- res = simplifyCondition cond a o --- hasLits (Lit _) = True --- hasLits (CNot c) = hasLits c --- hasLits (COr l r) = hasLits l || hasLits r --- hasLits (CAnd l r) = hasLits l || hasLits r --- hasLits _ = False --- - --- | Parse a configuration condition from a string. -parseCondition :: CabalParsing m => m (Condition ConfVar) -parseCondition = condOr - where - condOr = sepByNonEmpty condAnd (oper "||") >>= return . foldl1 COr - condAnd = sepByNonEmpty cond (oper "&&")>>= return . foldl1 CAnd - -- TODO: try? - cond = sp >> (boolLiteral <|> inparens condOr <|> notCond <|> osCond - <|> archCond <|> flagCond <|> implCond ) - inparens = between (P.char '(' >> sp) (sp >> P.char ')' >> sp) - notCond = P.char '!' >> sp >> cond >>= return . CNot - osCond = string "os" >> sp >> inparens osIdent >>= return . Var - archCond = string "arch" >> sp >> inparens archIdent >>= return . Var - flagCond = string "flag" >> sp >> inparens flagIdent >>= return . Var - implCond = string "impl" >> sp >> inparens implIdent >>= return . Var - boolLiteral = fmap Lit parsec - archIdent = fmap Arch parsec - osIdent = fmap OS parsec - flagIdent = fmap (PackageFlag . mkFlagName . lowercase) (munch1 isIdentChar) - isIdentChar c = isAlphaNum c || c == '_' || c == '-' - oper s = sp >> string s >> sp - sp = spaces - implIdent = do i <- parsec - vr <- sp >> option anyVersion parsec - return $ Impl i vr - ------------------------------------------------------------------------------- - --- | Result of dependency test. Isomorphic to @Maybe d@ but renamed for --- clarity. -data DepTestRslt d = DepOk | MissingDeps d - -instance Semigroup d => Monoid (DepTestRslt d) where - mempty = DepOk - mappend = (<>) - -instance Semigroup d => Semigroup (DepTestRslt d) where - DepOk <> x = x - x <> DepOk = x - (MissingDeps d) <> (MissingDeps d') = MissingDeps (d <> d') - - --- | Try to find a flag assignment that satisfies the constraints of all trees. --- --- Returns either the missing dependencies, or a tuple containing the --- resulting data, the associated dependencies, and the chosen flag --- assignments. --- --- In case of failure, the union of the dependencies that led to backtracking --- on all branches is returned. --- [TODO: Could also be specified with a function argument.] --- --- TODO: The current algorithm is rather naive. A better approach would be to: --- --- * Rule out possible paths, by taking a look at the associated dependencies. --- --- * Infer the required values for the conditions of these paths, and --- calculate the required domains for the variables used in these --- conditions. Then picking a flag assignment would be linear (I guess). --- --- This would require some sort of SAT solving, though, thus it's not --- implemented unless we really need it. --- -resolveWithFlags :: - [(FlagName,[Bool])] - -- ^ Domain for each flag name, will be tested in order. - -> ComponentRequestedSpec - -> OS -- ^ OS as returned by Distribution.System.buildOS - -> Arch -- ^ Arch as returned by Distribution.System.buildArch - -> CompilerInfo -- ^ Compiler information - -> [PackageVersionConstraint] -- ^ Additional constraints - -> [CondTree ConfVar [Dependency] PDTagged] - -> ([Dependency] -> DepTestRslt [Dependency]) -- ^ Dependency test function. - -> Either [Dependency] (TargetSet PDTagged, FlagAssignment) - -- ^ Either the missing dependencies (error case), or a pair of - -- (set of build targets with dependencies, chosen flag assignments) -resolveWithFlags dom enabled os arch impl constrs trees checkDeps = - either (Left . fromDepMapUnion) Right $ explore (build mempty dom) - where - -- simplify trees by (partially) evaluating all conditions and converting - -- dependencies to dependency maps. - simplifiedTrees :: [CondTree FlagName DependencyMap PDTagged] - simplifiedTrees = map ( mapTreeConstrs toDepMap -- convert to maps - . addBuildableConditionPDTagged - . mapTreeConds (fst . simplifyWithSysParams os arch impl)) - trees - - -- @explore@ searches a tree of assignments, backtracking whenever a flag - -- introduces a dependency that cannot be satisfied. If there is no - -- solution, @explore@ returns the union of all dependencies that caused - -- it to backtrack. Since the tree is constructed lazily, we avoid some - -- computation overhead in the successful case. - explore :: Tree FlagAssignment - -> Either DepMapUnion (TargetSet PDTagged, FlagAssignment) - explore (Node flags ts) = - let targetSet = TargetSet $ flip map simplifiedTrees $ - -- apply additional constraints to all dependencies - first (`constrainBy` constrs) . - simplifyCondTree (env flags) - deps = overallDependencies enabled targetSet - in case checkDeps (fromDepMap deps) of - DepOk | null ts -> Right (targetSet, flags) - | otherwise -> tryAll $ map explore ts - MissingDeps mds -> Left (toDepMapUnion mds) - - -- Builds a tree of all possible flag assignments. Internal nodes - -- have only partial assignments. - build :: FlagAssignment -> [(FlagName, [Bool])] -> Tree FlagAssignment - build assigned [] = Node assigned [] - build assigned ((fn, vals) : unassigned) = - Node assigned $ map (\v -> build (insertFlagAssignment fn v assigned) unassigned) vals - - tryAll :: [Either DepMapUnion a] -> Either DepMapUnion a - tryAll = foldr mp mz - - -- special version of `mplus' for our local purposes - mp :: Either DepMapUnion a -> Either DepMapUnion a -> Either DepMapUnion a - mp m@(Right _) _ = m - mp _ m@(Right _) = m - mp (Left xs) (Left ys) = Left (xs <> ys) - - -- `mzero' - mz :: Either DepMapUnion a - mz = Left (DepMapUnion Map.empty) - - env :: FlagAssignment -> FlagName -> Either FlagName Bool - env flags flag = (maybe (Left flag) Right . lookupFlagAssignment flag) flags - --- | Transforms a 'CondTree' by putting the input under the "then" branch of a --- conditional that is True when Buildable is True. If 'addBuildableCondition' --- can determine that Buildable is always True, it returns the input unchanged. --- If Buildable is always False, it returns the empty 'CondTree'. -addBuildableCondition :: (Eq v, Monoid a, Monoid c) => (a -> BuildInfo) - -> CondTree v c a - -> CondTree v c a -addBuildableCondition getInfo t = - case extractCondition (buildable . getInfo) t of - Lit True -> t - Lit False -> CondNode mempty mempty [] - c -> CondNode mempty mempty [condIfThen c t] - --- | This is a special version of 'addBuildableCondition' for the 'PDTagged' --- type. --- --- It is not simply a specialisation. It is more complicated than it --- ought to be because of the way the 'PDTagged' monoid instance works. The --- @mempty = 'PDNull'@ forgets the component type, which has the effect of --- completely deleting components that are not buildable. --- --- See for more details. --- -addBuildableConditionPDTagged :: (Eq v, Monoid c) => - CondTree v c PDTagged - -> CondTree v c PDTagged -addBuildableConditionPDTagged t = - case extractCondition (buildable . getInfo) t of - Lit True -> t - Lit False -> deleteConstraints t - c -> CondNode mempty mempty [condIfThenElse c t (deleteConstraints t)] - where - deleteConstraints = mapTreeConstrs (const mempty) - - getInfo :: PDTagged -> BuildInfo - getInfo (Lib l) = libBuildInfo l - getInfo (SubComp _ c) = componentBuildInfo c - getInfo PDNull = mempty - - --- Note: extracting buildable conditions. --- -------------------------------------- --- --- If the conditions in a cond tree lead to Buildable being set to False, then --- none of the dependencies for this cond tree should actually be taken into --- account. On the other hand, some of the flags may only be decided in the --- solver, so we cannot necessarily make the decision whether a component is --- Buildable or not prior to solving. --- --- What we are doing here is to partially evaluate a condition tree in order to --- extract the condition under which Buildable is True. The predicate determines --- whether data under a 'CondTree' is buildable. - --- | Extract conditions matched by the given predicate from all cond trees in a --- 'GenericPackageDescription'. -extractConditions :: (BuildInfo -> Bool) -> GenericPackageDescription - -> [Condition ConfVar] -extractConditions f gpkg = - concat [ - extractCondition (f . libBuildInfo) <$> maybeToList (condLibrary gpkg) - , extractCondition (f . libBuildInfo) . snd <$> condSubLibraries gpkg - , extractCondition (f . buildInfo) . snd <$> condExecutables gpkg - , extractCondition (f . testBuildInfo) . snd <$> condTestSuites gpkg - , extractCondition (f . benchmarkBuildInfo) . snd <$> condBenchmarks gpkg - ] - - --- | A map of package constraints that combines version ranges using 'unionVersionRanges'. -newtype DepMapUnion = DepMapUnion { unDepMapUnion :: Map PackageName (VersionRange, NonEmptySet LibraryName) } - -instance Semigroup DepMapUnion where - DepMapUnion x <> DepMapUnion y = DepMapUnion $ - Map.unionWith unionVersionRanges' x y - -unionVersionRanges' - :: (VersionRange, NonEmptySet LibraryName) - -> (VersionRange, NonEmptySet LibraryName) - -> (VersionRange, NonEmptySet LibraryName) -unionVersionRanges' (vr, cs) (vr', cs') = (unionVersionRanges vr vr', cs <> cs') - -toDepMapUnion :: [Dependency] -> DepMapUnion -toDepMapUnion ds = - DepMapUnion $ Map.fromListWith unionVersionRanges' [ (p,(vr,cs)) | Dependency p vr cs <- ds ] - - -fromDepMapUnion :: DepMapUnion -> [Dependency] -fromDepMapUnion m = [ Dependency p vr cs | (p,(vr,cs)) <- Map.toList (unDepMapUnion m) ] - -freeVars :: CondTree ConfVar c a -> [FlagName] -freeVars t = [ f | PackageFlag f <- freeVars' t ] - where - freeVars' (CondNode _ _ ifs) = concatMap compfv ifs - compfv (CondBranch c ct mct) = condfv c ++ freeVars' ct ++ maybe [] freeVars' mct - condfv c = case c of - Var v -> [v] - Lit _ -> [] - CNot c' -> condfv c' - COr c1 c2 -> condfv c1 ++ condfv c2 - CAnd c1 c2 -> condfv c1 ++ condfv c2 - - ------------------------------------------------------------------------------- - --- | A set of targets with their package dependencies -newtype TargetSet a = TargetSet [(DependencyMap, a)] - --- | Combine the target-specific dependencies in a TargetSet to give the --- dependencies for the package as a whole. -overallDependencies :: ComponentRequestedSpec -> TargetSet PDTagged -> DependencyMap -overallDependencies enabled (TargetSet targets) = mconcat depss - where - (depss, _) = unzip $ filter (removeDisabledSections . snd) targets - removeDisabledSections :: PDTagged -> Bool - -- UGH. The embedded componentName in the 'Component's here is - -- BLANK. I don't know whose fault this is but I'll use the tag - -- instead. -- ezyang - removeDisabledSections (Lib _) = componentNameRequested - enabled - (CLibName LMainLibName) - removeDisabledSections (SubComp t c) - -- Do NOT use componentName - = componentNameRequested enabled - $ case c of - CLib _ -> CLibName (LSubLibName t) - CFLib _ -> CFLibName t - CExe _ -> CExeName t - CTest _ -> CTestName t - CBench _ -> CBenchName t - removeDisabledSections PDNull = True - --- | Collect up the targets in a TargetSet of tagged targets, storing the --- dependencies as we go. -flattenTaggedTargets :: TargetSet PDTagged -> (Maybe Library, [(UnqualComponentName, Component)]) -flattenTaggedTargets (TargetSet targets) = foldr untag (Nothing, []) targets where - untag (depMap, pdTagged) accum = case (pdTagged, accum) of - (Lib _, (Just _, _)) -> userBug "Only one library expected" - (Lib l, (Nothing, comps)) -> (Just $ redoBD l, comps) - (SubComp n c, (mb_lib, comps)) - | any ((== n) . fst) comps -> - userBug $ "There exist several components with the same name: '" ++ prettyShow n ++ "'" - | otherwise -> (mb_lib, (n, redoBD c) : comps) - (PDNull, x) -> x -- actually this should not happen, but let's be liberal - where - redoBD :: L.HasBuildInfo a => a -> a - redoBD = set L.targetBuildDepends $ fromDepMap depMap - ------------------------------------------------------------------------------- --- Convert GenericPackageDescription to PackageDescription --- - -data PDTagged = Lib Library - | SubComp UnqualComponentName Component - | PDNull - deriving Show - -instance Monoid PDTagged where - mempty = PDNull - mappend = (<>) - -instance Semigroup PDTagged where - PDNull <> x = x - x <> PDNull = x - Lib l <> Lib l' = Lib (l <> l') - SubComp n x <> SubComp n' x' | n == n' = SubComp n (x <> x') - _ <> _ = cabalBug "Cannot combine incompatible tags" - --- | Create a package description with all configurations resolved. --- --- This function takes a `GenericPackageDescription` and several environment --- parameters and tries to generate `PackageDescription` by finding a flag --- assignment that result in satisfiable dependencies. --- --- It takes as inputs a not necessarily complete specifications of flags --- assignments, an optional package index as well as platform parameters. If --- some flags are not assigned explicitly, this function will try to pick an --- assignment that causes this function to succeed. The package index is --- optional since on some platforms we cannot determine which packages have --- been installed before. When no package index is supplied, every dependency --- is assumed to be satisfiable, therefore all not explicitly assigned flags --- will get their default values. --- --- This function will fail if it cannot find a flag assignment that leads to --- satisfiable dependencies. (It will not try alternative assignments for --- explicitly specified flags.) In case of failure it will return the missing --- dependencies that it encountered when trying different flag assignments. --- On success, it will return the package description and the full flag --- assignment chosen. --- --- Note that this drops any stanzas which have @buildable: False@. While --- this is arguably the right thing to do, it means we give bad error --- messages in some situations, see #3858. --- -finalizePD :: - FlagAssignment -- ^ Explicitly specified flag assignments - -> ComponentRequestedSpec - -> (Dependency -> Bool) -- ^ Is a given dependency satisfiable from the set of - -- available packages? If this is unknown then use - -- True. - -> Platform -- ^ The 'Arch' and 'OS' - -> CompilerInfo -- ^ Compiler information - -> [PackageVersionConstraint] -- ^ Additional constraints - -> GenericPackageDescription - -> Either [Dependency] - (PackageDescription, FlagAssignment) - -- ^ Either missing dependencies or the resolved package - -- description along with the flag assignments chosen. -finalizePD userflags enabled satisfyDep - (Platform arch os) impl constraints - (GenericPackageDescription pkg _ver flags mb_lib0 sub_libs0 flibs0 exes0 tests0 bms0) = do - (targetSet, flagVals) <- - resolveWithFlags flagChoices enabled os arch impl constraints condTrees check - let - (mb_lib, comps) = flattenTaggedTargets targetSet - mb_lib' = fmap libFillInDefaults mb_lib - comps' = flip map comps $ \(n,c) -> foldComponent - (\l -> CLib (libFillInDefaults l) { libName = LSubLibName n - , libExposed = False }) - (\l -> CFLib (flibFillInDefaults l) { foreignLibName = n }) - (\e -> CExe (exeFillInDefaults e) { exeName = n }) - (\t -> CTest (testFillInDefaults t) { testName = n }) - (\b -> CBench (benchFillInDefaults b) { benchmarkName = n }) - c - (sub_libs', flibs', exes', tests', bms') = partitionComponents comps' - return ( pkg { library = mb_lib' - , subLibraries = sub_libs' - , foreignLibs = flibs' - , executables = exes' - , testSuites = tests' - , benchmarks = bms' - } - , flagVals ) - where - -- Combine lib, exes, and tests into one list of @CondTree@s with tagged data - condTrees = maybeToList (fmap (mapTreeData Lib) mb_lib0) - ++ map (\(name,tree) -> mapTreeData (SubComp name . CLib) tree) sub_libs0 - ++ map (\(name,tree) -> mapTreeData (SubComp name . CFLib) tree) flibs0 - ++ map (\(name,tree) -> mapTreeData (SubComp name . CExe) tree) exes0 - ++ map (\(name,tree) -> mapTreeData (SubComp name . CTest) tree) tests0 - ++ map (\(name,tree) -> mapTreeData (SubComp name . CBench) tree) bms0 - - flagChoices = map (\(MkPackageFlag n _ d manual) -> (n, d2c manual n d)) flags - d2c manual n b = case lookupFlagAssignment n userflags of - Just val -> [val] - Nothing - | manual -> [b] - | otherwise -> [b, not b] - --flagDefaults = map (\(n,x:_) -> (n,x)) flagChoices - check ds = let missingDeps = filter (not . satisfyDep) ds - in if null missingDeps - then DepOk - else MissingDeps missingDeps - -{- -let tst_p = (CondNode [1::Int] [Distribution.Package.Dependency "a" AnyVersion] []) -let tst_p2 = (CondNode [1::Int] [Distribution.Package.Dependency "a" (EarlierVersion (Version [1,0] [])), Distribution.Package.Dependency "a" (LaterVersion (Version [2,0] []))] []) - -let p_index = Distribution.Simple.PackageIndex.fromList [Distribution.Package.PackageIdentifier "a" (Version [0,5] []), Distribution.Package.PackageIdentifier "a" (Version [2,5] [])] -let look = not . null . Distribution.Simple.PackageIndex.lookupDependency p_index -let looks ds = mconcat $ map (\d -> if look d then DepOk else MissingDeps [d]) ds -resolveWithFlags [] Distribution.System.Linux Distribution.System.I386 (Distribution.Compiler.GHC,Version [6,8,2] []) [tst_p] looks ===> Right ... -resolveWithFlags [] Distribution.System.Linux Distribution.System.I386 (Distribution.Compiler.GHC,Version [6,8,2] []) [tst_p2] looks ===> Left ... --} - --- | Flatten a generic package description by ignoring all conditions and just --- join the field descriptors into on package description. Note, however, --- that this may lead to inconsistent field values, since all values are --- joined into one field, which may not be possible in the original package --- description, due to the use of exclusive choices (if ... else ...). --- --- TODO: One particularly tricky case is defaulting. In the original package --- description, e.g., the source directory might either be the default or a --- certain, explicitly set path. Since defaults are filled in only after the --- package has been resolved and when no explicit value has been set, the --- default path will be missing from the package description returned by this --- function. -flattenPackageDescription :: GenericPackageDescription -> PackageDescription -flattenPackageDescription - (GenericPackageDescription pkg _ _ mlib0 sub_libs0 flibs0 exes0 tests0 bms0) = - pkg { library = mlib - , subLibraries = reverse sub_libs - , foreignLibs = reverse flibs - , executables = reverse exes - , testSuites = reverse tests - , benchmarks = reverse bms - } - where - mlib = f <$> mlib0 - where f lib = (libFillInDefaults . fst . ignoreConditions $ lib) { libName = LMainLibName } - sub_libs = flattenLib <$> sub_libs0 - flibs = flattenFLib <$> flibs0 - exes = flattenExe <$> exes0 - tests = flattenTst <$> tests0 - bms = flattenBm <$> bms0 - flattenLib (n, t) = libFillInDefaults $ (fst $ ignoreConditions t) - { libName = LSubLibName n, libExposed = False } - flattenFLib (n, t) = flibFillInDefaults $ (fst $ ignoreConditions t) - { foreignLibName = n } - flattenExe (n, t) = exeFillInDefaults $ (fst $ ignoreConditions t) - { exeName = n } - flattenTst (n, t) = testFillInDefaults $ (fst $ ignoreConditions t) - { testName = n } - flattenBm (n, t) = benchFillInDefaults $ (fst $ ignoreConditions t) - { benchmarkName = n } - --- This is in fact rather a hack. The original version just overrode the --- default values, however, when adding conditions we had to switch to a --- modifier-based approach. There, nothing is ever overwritten, but only --- joined together. --- --- This is the cleanest way i could think of, that doesn't require --- changing all field parsing functions to return modifiers instead. -libFillInDefaults :: Library -> Library -libFillInDefaults lib@(Library { libBuildInfo = bi }) = - lib { libBuildInfo = biFillInDefaults bi } - -flibFillInDefaults :: ForeignLib -> ForeignLib -flibFillInDefaults flib@(ForeignLib { foreignLibBuildInfo = bi }) = - flib { foreignLibBuildInfo = biFillInDefaults bi } - -exeFillInDefaults :: Executable -> Executable -exeFillInDefaults exe@(Executable { buildInfo = bi }) = - exe { buildInfo = biFillInDefaults bi } - -testFillInDefaults :: TestSuite -> TestSuite -testFillInDefaults tst@(TestSuite { testBuildInfo = bi }) = - tst { testBuildInfo = biFillInDefaults bi } - -benchFillInDefaults :: Benchmark -> Benchmark -benchFillInDefaults bm@(Benchmark { benchmarkBuildInfo = bi }) = - bm { benchmarkBuildInfo = biFillInDefaults bi } - -biFillInDefaults :: BuildInfo -> BuildInfo -biFillInDefaults bi = - if null (hsSourceDirs bi) - then bi { hsSourceDirs = [sameDirectory] } - else bi - --- Walk a 'GenericPackageDescription' and apply @onBuildInfo@/@onSetupBuildInfo@ --- to all nested 'BuildInfo'/'SetupBuildInfo' values. -transformAllBuildInfos :: (BuildInfo -> BuildInfo) - -> (SetupBuildInfo -> SetupBuildInfo) - -> GenericPackageDescription - -> GenericPackageDescription -transformAllBuildInfos onBuildInfo onSetupBuildInfo = - over L.traverseBuildInfos onBuildInfo - . over (L.packageDescription . L.setupBuildInfo . traverse) onSetupBuildInfo - --- | Walk a 'GenericPackageDescription' and apply @f@ to all nested --- @build-depends@ fields. -transformAllBuildDepends :: (Dependency -> Dependency) - -> GenericPackageDescription - -> GenericPackageDescription -transformAllBuildDepends f = - over (L.traverseBuildInfos . L.targetBuildDepends . traverse) f - . over (L.packageDescription . L.setupBuildInfo . traverse . L.setupDepends . traverse) f - -- cannot be point-free as normal because of higher rank - . over (\f' -> L.allCondTrees $ traverseCondTreeC f') (map f) - --- | Walk a 'GenericPackageDescription' and apply @f@ to all nested --- @build-depends@ fields. -transformAllBuildDependsN :: ([Dependency] -> [Dependency]) - -> GenericPackageDescription - -> GenericPackageDescription -transformAllBuildDependsN f = - over (L.traverseBuildInfos . L.targetBuildDepends) f - . over (L.packageDescription . L.setupBuildInfo . traverse . L.setupDepends) f - -- cannot be point-free as normal because of higher rank - . over (\f' -> L.allCondTrees $ traverseCondTreeC f') f diff --git a/src/Distribution/PackageDescription/FieldGrammar.hs b/src/Distribution/PackageDescription/FieldGrammar.hs deleted file mode 100644 --- a/src/Distribution/PackageDescription/FieldGrammar.hs +++ /dev/null @@ -1,802 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} --- | 'GenericPackageDescription' Field descriptions -module Distribution.PackageDescription.FieldGrammar ( - -- * Package description - packageDescriptionFieldGrammar, - -- * Library - libraryFieldGrammar, - -- * Foreign library - foreignLibFieldGrammar, - -- * Executable - executableFieldGrammar, - -- * Test suite - TestSuiteStanza (..), - testSuiteFieldGrammar, - validateTestSuite, - unvalidateTestSuite, - -- ** Lenses - testStanzaTestType, - testStanzaMainIs, - testStanzaTestModule, - testStanzaBuildInfo, - -- * Benchmark - BenchmarkStanza (..), - benchmarkFieldGrammar, - validateBenchmark, - unvalidateBenchmark, - -- * Field grammars - formatDependencyList, - formatExposedModules, - formatExtraSourceFiles, - formatHsSourceDirs, - formatMixinList, - formatOtherExtensions, - formatOtherModules, - -- ** Lenses - benchmarkStanzaBenchmarkType, - benchmarkStanzaMainIs, - benchmarkStanzaBenchmarkModule, - benchmarkStanzaBuildInfo, - -- * Flag - flagFieldGrammar, - -- * Source repository - sourceRepoFieldGrammar, - -- * Setup build info - setupBInfoFieldGrammar, - -- * Component build info - buildInfoFieldGrammar, - ) where - - -import Distribution.Compat.Lens -import Distribution.Compat.Prelude -import Language.Haskell.Extension -import Prelude () - -import Distribution.CabalSpecVersion -import Distribution.Compat.Newtype (Newtype, pack', unpack') -import Distribution.Compiler (CompilerFlavor (..), PerCompilerFlavor (..)) -import Distribution.FieldGrammar -import Distribution.Fields -import Distribution.ModuleName (ModuleName) -import Distribution.Package -import Distribution.PackageDescription -import Distribution.Parsec -import Distribution.Pretty (Pretty (..), prettyShow, showToken) -import Distribution.Utils.Path -import Distribution.Version (Version, VersionRange) - -import qualified Data.ByteString.Char8 as BS8 -import qualified Distribution.Compat.CharParsing as P -import qualified Distribution.SPDX as SPDX -import qualified Distribution.Types.Lens as L - -------------------------------------------------------------------------------- --- PackageDescription -------------------------------------------------------------------------------- - -packageDescriptionFieldGrammar - :: ( FieldGrammar c g, Applicative (g PackageDescription), Applicative (g PackageIdentifier) - , c (Identity BuildType) - , c (Identity PackageName) - , c (Identity Version) - , c (List FSep FilePathNT String) - , c (List FSep CompatFilePath String) - , c (List FSep (Identity (SymbolicPath PackageDir LicenseFile)) (SymbolicPath PackageDir LicenseFile)) - , c (List FSep TestedWith (CompilerFlavor, VersionRange)) - , c (List VCat FilePathNT String) - , c FilePathNT - , c CompatLicenseFile - , c CompatFilePath - , c SpecLicense - , c SpecVersion - ) - => g PackageDescription PackageDescription -packageDescriptionFieldGrammar = PackageDescription - <$> optionalFieldDefAla "cabal-version" SpecVersion L.specVersion CabalSpecV1_0 - <*> blurFieldGrammar L.package packageIdentifierGrammar - <*> optionalFieldDefAla "license" SpecLicense L.licenseRaw (Left SPDX.NONE) - <*> licenseFilesGrammar - <*> freeTextFieldDefST "copyright" L.copyright - <*> freeTextFieldDefST "maintainer" L.maintainer - <*> freeTextFieldDefST "author" L.author - <*> freeTextFieldDefST "stability" L.stability - <*> monoidalFieldAla "tested-with" (alaList' FSep TestedWith) L.testedWith - <*> freeTextFieldDefST "homepage" L.homepage - <*> freeTextFieldDefST "package-url" L.pkgUrl - <*> freeTextFieldDefST "bug-reports" L.bugReports - <*> pure [] -- source-repos are stanza - <*> freeTextFieldDefST "synopsis" L.synopsis - <*> freeTextFieldDefST "description" L.description - <*> freeTextFieldDefST "category" L.category - <*> prefixedFields "x-" L.customFieldsPD - <*> optionalField "build-type" L.buildTypeRaw - <*> pure Nothing -- custom-setup - -- components - <*> pure Nothing -- lib - <*> pure [] -- sub libs - <*> pure [] -- executables - <*> pure [] -- foreign libs - <*> pure [] -- test suites - <*> pure [] -- benchmarks - -- * Files - <*> monoidalFieldAla "data-files" (alaList' VCat FilePathNT) L.dataFiles - <*> optionalFieldDefAla "data-dir" CompatFilePath L.dataDir "." - ^^^ fmap (\x -> if null x then "." else x) -- map empty directories to "." - <*> monoidalFieldAla "extra-source-files" formatExtraSourceFiles L.extraSrcFiles - <*> monoidalFieldAla "extra-tmp-files" (alaList' VCat FilePathNT) L.extraTmpFiles - <*> monoidalFieldAla "extra-doc-files" (alaList' VCat FilePathNT) L.extraDocFiles - where - packageIdentifierGrammar = PackageIdentifier - <$> uniqueField "name" L.pkgName - <*> uniqueField "version" L.pkgVersion - - licenseFilesGrammar = (++) - -- TODO: neither field is deprecated - -- should we pretty print license-file if there's single license file - -- and license-files when more - <$> monoidalFieldAla "license-file" CompatLicenseFile L.licenseFiles - <*> monoidalFieldAla "license-files" (alaList FSep) L.licenseFiles - ^^^ hiddenField - -------------------------------------------------------------------------------- --- Library -------------------------------------------------------------------------------- - -libraryFieldGrammar - :: ( FieldGrammar c g, Applicative (g Library), Applicative (g BuildInfo) - , c (Identity LibraryVisibility) - , c (List CommaFSep (Identity ExeDependency) ExeDependency) - , c (List CommaFSep (Identity LegacyExeDependency) LegacyExeDependency) - , c (List CommaFSep (Identity PkgconfigDependency) PkgconfigDependency) - , c (List CommaVCat (Identity Dependency) Dependency) - , c (List CommaVCat (Identity Mixin) Mixin) - , c (List CommaVCat (Identity ModuleReexport) ModuleReexport) - , c (List FSep (MQuoted Extension) Extension) - , c (List FSep (MQuoted Language) Language) - , c (List FSep FilePathNT String) - , c (List FSep Token String) - , c (List NoCommaFSep Token' String) - , c (List VCat (MQuoted ModuleName) ModuleName) - , c (List VCat FilePathNT String) - , c (List FSep (Identity (SymbolicPath PackageDir SourceDir)) (SymbolicPath PackageDir SourceDir)) - , c (List VCat Token String) - , c (MQuoted Language) - ) - => LibraryName - -> g Library Library -libraryFieldGrammar n = Library n - <$> monoidalFieldAla "exposed-modules" formatExposedModules L.exposedModules - <*> monoidalFieldAla "reexported-modules" (alaList CommaVCat) L.reexportedModules - <*> monoidalFieldAla "signatures" (alaList' VCat MQuoted) L.signatures - ^^^ availableSince CabalSpecV2_0 [] - <*> booleanFieldDef "exposed" L.libExposed True - <*> visibilityField - <*> blurFieldGrammar L.libBuildInfo buildInfoFieldGrammar - where - visibilityField = case n of - -- nameless/"main" libraries are public - LMainLibName -> pure LibraryVisibilityPublic - -- named libraries have the field - LSubLibName _ -> - optionalFieldDef "visibility" L.libVisibility LibraryVisibilityPrivate - ^^^ availableSince CabalSpecV3_0 LibraryVisibilityPrivate - -{-# SPECIALIZE libraryFieldGrammar :: LibraryName -> ParsecFieldGrammar' Library #-} -{-# SPECIALIZE libraryFieldGrammar :: LibraryName -> PrettyFieldGrammar' Library #-} - -------------------------------------------------------------------------------- --- Foreign library -------------------------------------------------------------------------------- - -foreignLibFieldGrammar - :: ( FieldGrammar c g, Applicative (g ForeignLib), Applicative (g BuildInfo) - , c (Identity ForeignLibType) - , c (Identity LibVersionInfo) - , c (Identity Version) - , c (List CommaFSep (Identity ExeDependency) ExeDependency) - , c (List CommaFSep (Identity LegacyExeDependency) LegacyExeDependency) - , c (List CommaFSep (Identity PkgconfigDependency) PkgconfigDependency) - , c (List CommaVCat (Identity Dependency) Dependency) - , c (List CommaVCat (Identity Mixin) Mixin) - , c (List FSep (Identity ForeignLibOption) ForeignLibOption) - , c (List FSep (MQuoted Extension) Extension) - , c (List FSep (MQuoted Language) Language) - , c (List FSep FilePathNT String) - , c (List FSep Token String) - , c (List FSep (Identity (SymbolicPath PackageDir SourceDir)) (SymbolicPath PackageDir SourceDir)) - , c (List NoCommaFSep Token' String) - , c (List VCat (MQuoted ModuleName) ModuleName) - , c (List VCat FilePathNT String), c (List VCat Token String) - , c (MQuoted Language) - ) - => UnqualComponentName -> g ForeignLib ForeignLib -foreignLibFieldGrammar n = ForeignLib n - <$> optionalFieldDef "type" L.foreignLibType ForeignLibTypeUnknown - <*> monoidalFieldAla "options" (alaList FSep) L.foreignLibOptions - <*> blurFieldGrammar L.foreignLibBuildInfo buildInfoFieldGrammar - <*> optionalField "lib-version-info" L.foreignLibVersionInfo - <*> optionalField "lib-version-linux" L.foreignLibVersionLinux - <*> monoidalFieldAla "mod-def-file" (alaList' FSep FilePathNT) L.foreignLibModDefFile -{-# SPECIALIZE foreignLibFieldGrammar :: UnqualComponentName -> ParsecFieldGrammar' ForeignLib #-} -{-# SPECIALIZE foreignLibFieldGrammar :: UnqualComponentName -> PrettyFieldGrammar' ForeignLib #-} - -------------------------------------------------------------------------------- --- Executable -------------------------------------------------------------------------------- - -executableFieldGrammar - :: ( FieldGrammar c g, Applicative (g Executable), Applicative (g BuildInfo) - , c (Identity ExecutableScope) - , c (List CommaFSep (Identity ExeDependency) ExeDependency) - , c (List CommaFSep (Identity LegacyExeDependency) LegacyExeDependency) - , c (List CommaFSep (Identity PkgconfigDependency) PkgconfigDependency) - , c (List CommaVCat (Identity Dependency) Dependency) - , c (List CommaVCat (Identity Mixin) Mixin) - , c (List FSep (MQuoted Extension) Extension) - , c (List FSep (MQuoted Language) Language) - , c (List FSep FilePathNT String) - , c (List FSep Token String) - , c (List FSep (Identity (SymbolicPath PackageDir SourceDir)) (SymbolicPath PackageDir SourceDir)) - , c (List NoCommaFSep Token' String) - , c (List VCat (MQuoted ModuleName) ModuleName) - , c (List VCat FilePathNT String) - , c (List VCat Token String) - , c (MQuoted Language) - ) - => UnqualComponentName -> g Executable Executable -executableFieldGrammar n = Executable n - -- main-is is optional as conditional blocks don't have it - <$> optionalFieldDefAla "main-is" FilePathNT L.modulePath "" - <*> optionalFieldDef "scope" L.exeScope ExecutablePublic - ^^^ availableSince CabalSpecV2_0 ExecutablePublic - <*> blurFieldGrammar L.buildInfo buildInfoFieldGrammar -{-# SPECIALIZE executableFieldGrammar :: UnqualComponentName -> ParsecFieldGrammar' Executable #-} -{-# SPECIALIZE executableFieldGrammar :: UnqualComponentName -> PrettyFieldGrammar' Executable #-} - -------------------------------------------------------------------------------- --- TestSuite -------------------------------------------------------------------------------- - --- | An intermediate type just used for parsing the test-suite stanza. --- After validation it is converted into the proper 'TestSuite' type. -data TestSuiteStanza = TestSuiteStanza - { _testStanzaTestType :: Maybe TestType - , _testStanzaMainIs :: Maybe FilePath - , _testStanzaTestModule :: Maybe ModuleName - , _testStanzaBuildInfo :: BuildInfo - } - -instance L.HasBuildInfo TestSuiteStanza where - buildInfo = testStanzaBuildInfo - -testStanzaTestType :: Lens' TestSuiteStanza (Maybe TestType) -testStanzaTestType f s = fmap (\x -> s { _testStanzaTestType = x }) (f (_testStanzaTestType s)) -{-# INLINE testStanzaTestType #-} - -testStanzaMainIs :: Lens' TestSuiteStanza (Maybe FilePath) -testStanzaMainIs f s = fmap (\x -> s { _testStanzaMainIs = x }) (f (_testStanzaMainIs s)) -{-# INLINE testStanzaMainIs #-} - -testStanzaTestModule :: Lens' TestSuiteStanza (Maybe ModuleName) -testStanzaTestModule f s = fmap (\x -> s { _testStanzaTestModule = x }) (f (_testStanzaTestModule s)) -{-# INLINE testStanzaTestModule #-} - -testStanzaBuildInfo :: Lens' TestSuiteStanza BuildInfo -testStanzaBuildInfo f s = fmap (\x -> s { _testStanzaBuildInfo = x }) (f (_testStanzaBuildInfo s)) -{-# INLINE testStanzaBuildInfo #-} - -testSuiteFieldGrammar - :: ( FieldGrammar c g, Applicative (g TestSuiteStanza), Applicative (g BuildInfo) - , c (Identity ModuleName) - , c (Identity TestType) - , c (List CommaFSep (Identity ExeDependency) ExeDependency) - , c (List CommaFSep (Identity LegacyExeDependency) LegacyExeDependency) - , c (List CommaFSep (Identity PkgconfigDependency) PkgconfigDependency) - , c (List CommaVCat (Identity Dependency) Dependency) - , c (List CommaVCat (Identity Mixin) Mixin) - , c (List FSep (MQuoted Extension) Extension) - , c (List FSep (MQuoted Language) Language) - , c (List FSep FilePathNT String) - , c (List FSep Token String) - , c (List NoCommaFSep Token' String) - , c (List VCat (MQuoted ModuleName) ModuleName) - , c (List VCat FilePathNT String) - , c (List FSep (Identity (SymbolicPath PackageDir SourceDir)) (SymbolicPath PackageDir SourceDir)) - , c (List VCat Token String) - , c (MQuoted Language) - ) - => g TestSuiteStanza TestSuiteStanza -testSuiteFieldGrammar = TestSuiteStanza - <$> optionalField "type" testStanzaTestType - <*> optionalFieldAla "main-is" FilePathNT testStanzaMainIs - <*> optionalField "test-module" testStanzaTestModule - <*> blurFieldGrammar testStanzaBuildInfo buildInfoFieldGrammar - -validateTestSuite :: Position -> TestSuiteStanza -> ParseResult TestSuite -validateTestSuite pos stanza = case _testStanzaTestType stanza of - Nothing -> return $ - emptyTestSuite { testBuildInfo = _testStanzaBuildInfo stanza } - - Just tt@(TestTypeUnknown _ _) -> - pure emptyTestSuite - { testInterface = TestSuiteUnsupported tt - , testBuildInfo = _testStanzaBuildInfo stanza - } - - Just tt | tt `notElem` knownTestTypes -> - pure emptyTestSuite - { testInterface = TestSuiteUnsupported tt - , testBuildInfo = _testStanzaBuildInfo stanza - } - - Just tt@(TestTypeExe ver) -> case _testStanzaMainIs stanza of - Nothing -> do - parseFailure pos (missingField "main-is" tt) - pure emptyTestSuite - Just file -> do - when (isJust (_testStanzaTestModule stanza)) $ - parseWarning pos PWTExtraBenchmarkModule (extraField "test-module" tt) - pure emptyTestSuite - { testInterface = TestSuiteExeV10 ver file - , testBuildInfo = _testStanzaBuildInfo stanza - } - - Just tt@(TestTypeLib ver) -> case _testStanzaTestModule stanza of - Nothing -> do - parseFailure pos (missingField "test-module" tt) - pure emptyTestSuite - Just module_ -> do - when (isJust (_testStanzaMainIs stanza)) $ - parseWarning pos PWTExtraMainIs (extraField "main-is" tt) - pure emptyTestSuite - { testInterface = TestSuiteLibV09 ver module_ - , testBuildInfo = _testStanzaBuildInfo stanza - } - - where - missingField name tt = "The '" ++ name ++ "' field is required for the " - ++ prettyShow tt ++ " test suite type." - - extraField name tt = "The '" ++ name ++ "' field is not used for the '" - ++ prettyShow tt ++ "' test suite type." - -unvalidateTestSuite :: TestSuite -> TestSuiteStanza -unvalidateTestSuite t = TestSuiteStanza - { _testStanzaTestType = ty - , _testStanzaMainIs = ma - , _testStanzaTestModule = mo - , _testStanzaBuildInfo = testBuildInfo t - } - where - (ty, ma, mo) = case testInterface t of - TestSuiteExeV10 ver file -> (Just $ TestTypeExe ver, Just file, Nothing) - TestSuiteLibV09 ver modu -> (Just $ TestTypeLib ver, Nothing, Just modu) - _ -> (Nothing, Nothing, Nothing) - -------------------------------------------------------------------------------- --- Benchmark -------------------------------------------------------------------------------- - --- | An intermediate type just used for parsing the benchmark stanza. --- After validation it is converted into the proper 'Benchmark' type. -data BenchmarkStanza = BenchmarkStanza - { _benchmarkStanzaBenchmarkType :: Maybe BenchmarkType - , _benchmarkStanzaMainIs :: Maybe FilePath - , _benchmarkStanzaBenchmarkModule :: Maybe ModuleName - , _benchmarkStanzaBuildInfo :: BuildInfo - } - -instance L.HasBuildInfo BenchmarkStanza where - buildInfo = benchmarkStanzaBuildInfo - -benchmarkStanzaBenchmarkType :: Lens' BenchmarkStanza (Maybe BenchmarkType) -benchmarkStanzaBenchmarkType f s = fmap (\x -> s { _benchmarkStanzaBenchmarkType = x }) (f (_benchmarkStanzaBenchmarkType s)) -{-# INLINE benchmarkStanzaBenchmarkType #-} - -benchmarkStanzaMainIs :: Lens' BenchmarkStanza (Maybe FilePath) -benchmarkStanzaMainIs f s = fmap (\x -> s { _benchmarkStanzaMainIs = x }) (f (_benchmarkStanzaMainIs s)) -{-# INLINE benchmarkStanzaMainIs #-} - -benchmarkStanzaBenchmarkModule :: Lens' BenchmarkStanza (Maybe ModuleName) -benchmarkStanzaBenchmarkModule f s = fmap (\x -> s { _benchmarkStanzaBenchmarkModule = x }) (f (_benchmarkStanzaBenchmarkModule s)) -{-# INLINE benchmarkStanzaBenchmarkModule #-} - -benchmarkStanzaBuildInfo :: Lens' BenchmarkStanza BuildInfo -benchmarkStanzaBuildInfo f s = fmap (\x -> s { _benchmarkStanzaBuildInfo = x }) (f (_benchmarkStanzaBuildInfo s)) -{-# INLINE benchmarkStanzaBuildInfo #-} - -benchmarkFieldGrammar - :: ( FieldGrammar c g, Applicative (g BenchmarkStanza), Applicative (g BuildInfo) - , c (Identity BenchmarkType) - , c (Identity ModuleName) - , c (List CommaFSep (Identity ExeDependency) ExeDependency) - , c (List CommaFSep (Identity LegacyExeDependency) LegacyExeDependency) - , c (List CommaFSep (Identity PkgconfigDependency) PkgconfigDependency) - , c (List CommaVCat (Identity Dependency) Dependency) - , c (List CommaVCat (Identity Mixin) Mixin) - , c (List FSep (MQuoted Extension) Extension) - , c (List FSep (MQuoted Language) Language) - , c (List FSep FilePathNT String) - , c (List FSep Token String) - , c (List NoCommaFSep Token' String) - , c (List VCat (MQuoted ModuleName) ModuleName) - , c (List VCat FilePathNT String) - , c (List FSep (Identity (SymbolicPath PackageDir SourceDir)) (SymbolicPath PackageDir SourceDir)) - , c (List VCat Token String) - , c (MQuoted Language) - ) - => g BenchmarkStanza BenchmarkStanza -benchmarkFieldGrammar = BenchmarkStanza - <$> optionalField "type" benchmarkStanzaBenchmarkType - <*> optionalFieldAla "main-is" FilePathNT benchmarkStanzaMainIs - <*> optionalField "benchmark-module" benchmarkStanzaBenchmarkModule - <*> blurFieldGrammar benchmarkStanzaBuildInfo buildInfoFieldGrammar - -validateBenchmark :: Position -> BenchmarkStanza -> ParseResult Benchmark -validateBenchmark pos stanza = case _benchmarkStanzaBenchmarkType stanza of - Nothing -> pure emptyBenchmark - { benchmarkBuildInfo = _benchmarkStanzaBuildInfo stanza } - - Just tt@(BenchmarkTypeUnknown _ _) -> pure emptyBenchmark - { benchmarkInterface = BenchmarkUnsupported tt - , benchmarkBuildInfo = _benchmarkStanzaBuildInfo stanza - } - - Just tt | tt `notElem` knownBenchmarkTypes -> pure emptyBenchmark - { benchmarkInterface = BenchmarkUnsupported tt - , benchmarkBuildInfo = _benchmarkStanzaBuildInfo stanza - } - - Just tt@(BenchmarkTypeExe ver) -> case _benchmarkStanzaMainIs stanza of - Nothing -> do - parseFailure pos (missingField "main-is" tt) - pure emptyBenchmark - Just file -> do - when (isJust (_benchmarkStanzaBenchmarkModule stanza)) $ - parseWarning pos PWTExtraBenchmarkModule (extraField "benchmark-module" tt) - pure emptyBenchmark - { benchmarkInterface = BenchmarkExeV10 ver file - , benchmarkBuildInfo = _benchmarkStanzaBuildInfo stanza - } - - where - missingField name tt = "The '" ++ name ++ "' field is required for the " - ++ prettyShow tt ++ " benchmark type." - - extraField name tt = "The '" ++ name ++ "' field is not used for the '" - ++ prettyShow tt ++ "' benchmark type." - -unvalidateBenchmark :: Benchmark -> BenchmarkStanza -unvalidateBenchmark b = BenchmarkStanza - { _benchmarkStanzaBenchmarkType = ty - , _benchmarkStanzaMainIs = ma - , _benchmarkStanzaBenchmarkModule = mo - , _benchmarkStanzaBuildInfo = benchmarkBuildInfo b - } - where - (ty, ma, mo) = case benchmarkInterface b of - BenchmarkExeV10 ver "" -> (Just $ BenchmarkTypeExe ver, Nothing, Nothing) - BenchmarkExeV10 ver ma' -> (Just $ BenchmarkTypeExe ver, Just ma', Nothing) - _ -> (Nothing, Nothing, Nothing) - -------------------------------------------------------------------------------- --- Build info -------------------------------------------------------------------------------- - -buildInfoFieldGrammar - :: ( FieldGrammar c g, Applicative (g BuildInfo) - , c (List CommaFSep (Identity ExeDependency) ExeDependency) - , c (List CommaFSep (Identity LegacyExeDependency) LegacyExeDependency) - , c (List CommaFSep (Identity PkgconfigDependency) PkgconfigDependency) - , c (List CommaVCat (Identity Dependency) Dependency) - , c (List CommaVCat (Identity Mixin) Mixin) - , c (List FSep (MQuoted Extension) Extension) - , c (List FSep (MQuoted Language) Language) - , c (List FSep FilePathNT String) - , c (List FSep Token String) - , c (List NoCommaFSep Token' String) - , c (List VCat (MQuoted ModuleName) ModuleName) - , c (List VCat FilePathNT String) - , c (List FSep (Identity (SymbolicPath PackageDir SourceDir)) (SymbolicPath PackageDir SourceDir)) - , c (List VCat Token String) - , c (MQuoted Language) - ) - => g BuildInfo BuildInfo -buildInfoFieldGrammar = BuildInfo - <$> booleanFieldDef "buildable" L.buildable True - <*> monoidalFieldAla "build-tools" (alaList CommaFSep) L.buildTools - ^^^ deprecatedSince CabalSpecV2_0 - "Please use 'build-tool-depends' field" - ^^^ removedIn CabalSpecV3_0 - "Please use 'build-tool-depends' field." - <*> monoidalFieldAla "build-tool-depends" (alaList CommaFSep) L.buildToolDepends - -- {- ^^^ availableSince [2,0] [] -} - -- here, we explicitly want to recognise build-tool-depends for all Cabal files - -- as otherwise cabal new-build cannot really work. - -- - -- I.e. we don't want trigger unknown field warning - <*> monoidalFieldAla "cpp-options" (alaList' NoCommaFSep Token') L.cppOptions - <*> monoidalFieldAla "asm-options" (alaList' NoCommaFSep Token') L.asmOptions - ^^^ availableSince CabalSpecV3_0 [] - <*> monoidalFieldAla "cmm-options" (alaList' NoCommaFSep Token') L.cmmOptions - ^^^ availableSince CabalSpecV3_0 [] - <*> monoidalFieldAla "cc-options" (alaList' NoCommaFSep Token') L.ccOptions - <*> monoidalFieldAla "cxx-options" (alaList' NoCommaFSep Token') L.cxxOptions - ^^^ availableSince CabalSpecV2_2 [] - <*> monoidalFieldAla "ld-options" (alaList' NoCommaFSep Token') L.ldOptions - <*> monoidalFieldAla "hsc2hs-options" (alaList' NoCommaFSep Token') L.hsc2hsOptions - ^^^ availableSince CabalSpecV3_6 [] - <*> monoidalFieldAla "pkgconfig-depends" (alaList CommaFSep) L.pkgconfigDepends - <*> monoidalFieldAla "frameworks" (alaList' FSep Token) L.frameworks - <*> monoidalFieldAla "extra-framework-dirs" (alaList' FSep FilePathNT) L.extraFrameworkDirs - <*> monoidalFieldAla "asm-sources" (alaList' VCat FilePathNT) L.asmSources - ^^^ availableSince CabalSpecV3_0 [] - <*> monoidalFieldAla "cmm-sources" (alaList' VCat FilePathNT) L.cmmSources - ^^^ availableSince CabalSpecV3_0 [] - <*> monoidalFieldAla "c-sources" (alaList' VCat FilePathNT) L.cSources - <*> monoidalFieldAla "cxx-sources" (alaList' VCat FilePathNT) L.cxxSources - ^^^ availableSince CabalSpecV2_2 [] - <*> monoidalFieldAla "js-sources" (alaList' VCat FilePathNT) L.jsSources - <*> hsSourceDirsGrammar - <*> monoidalFieldAla "other-modules" formatOtherModules L.otherModules - <*> monoidalFieldAla "virtual-modules" (alaList' VCat MQuoted) L.virtualModules - ^^^ availableSince CabalSpecV2_2 [] - <*> monoidalFieldAla "autogen-modules" (alaList' VCat MQuoted) L.autogenModules - ^^^ availableSince CabalSpecV2_0 [] - <*> optionalFieldAla "default-language" MQuoted L.defaultLanguage - ^^^ availableSince CabalSpecV1_10 Nothing - <*> monoidalFieldAla "other-languages" (alaList' FSep MQuoted) L.otherLanguages - ^^^ availableSince CabalSpecV1_10 [] - <*> monoidalFieldAla "default-extensions" (alaList' FSep MQuoted) L.defaultExtensions - ^^^ availableSince CabalSpecV1_10 [] - <*> monoidalFieldAla "other-extensions" formatOtherExtensions L.otherExtensions - ^^^ availableSinceWarn CabalSpecV1_10 - <*> monoidalFieldAla "extensions" (alaList' FSep MQuoted) L.oldExtensions - ^^^ deprecatedSince CabalSpecV1_12 - "Please use 'default-extensions' or 'other-extensions' fields." - ^^^ removedIn CabalSpecV3_0 - "Please use 'default-extensions' or 'other-extensions' fields." - <*> monoidalFieldAla "extra-libraries" (alaList' VCat Token) L.extraLibs - <*> monoidalFieldAla "extra-ghci-libraries" (alaList' VCat Token) L.extraGHCiLibs - <*> monoidalFieldAla "extra-bundled-libraries" (alaList' VCat Token) L.extraBundledLibs - <*> monoidalFieldAla "extra-library-flavours" (alaList' VCat Token) L.extraLibFlavours - <*> monoidalFieldAla "extra-dynamic-library-flavours" (alaList' VCat Token) L.extraDynLibFlavours - ^^^ availableSince CabalSpecV3_0 [] - <*> monoidalFieldAla "extra-lib-dirs" (alaList' FSep FilePathNT) L.extraLibDirs - <*> monoidalFieldAla "include-dirs" (alaList' FSep FilePathNT) L.includeDirs - <*> monoidalFieldAla "includes" (alaList' FSep FilePathNT) L.includes - <*> monoidalFieldAla "autogen-includes" (alaList' FSep FilePathNT) L.autogenIncludes - ^^^ availableSince CabalSpecV3_0 [] - <*> monoidalFieldAla "install-includes" (alaList' FSep FilePathNT) L.installIncludes - <*> optionsFieldGrammar - <*> profOptionsFieldGrammar - <*> sharedOptionsFieldGrammar - <*> pure mempty -- static-options ??? - <*> prefixedFields "x-" L.customFieldsBI - <*> monoidalFieldAla "build-depends" formatDependencyList L.targetBuildDepends - <*> monoidalFieldAla "mixins" formatMixinList L.mixins - ^^^ availableSince CabalSpecV2_0 [] -{-# SPECIALIZE buildInfoFieldGrammar :: ParsecFieldGrammar' BuildInfo #-} -{-# SPECIALIZE buildInfoFieldGrammar :: PrettyFieldGrammar' BuildInfo #-} - -hsSourceDirsGrammar - :: ( FieldGrammar c g, Applicative (g BuildInfo) - , c (List FSep (Identity (SymbolicPath PackageDir SourceDir)) (SymbolicPath PackageDir SourceDir)) - ) - => g BuildInfo [SymbolicPath PackageDir SourceDir] -hsSourceDirsGrammar = (++) - <$> monoidalFieldAla "hs-source-dirs" formatHsSourceDirs L.hsSourceDirs - <*> monoidalFieldAla "hs-source-dir" (alaList FSep) wrongLens - --- https://github.com/haskell/cabal/commit/49e3cdae3bdf21b017ccd42e66670ca402e22b44 - ^^^ deprecatedSince CabalSpecV1_2 "Please use 'hs-source-dirs'" - ^^^ removedIn CabalSpecV3_0 "Please use 'hs-source-dirs' field." - where - -- TODO: make pretty printer aware of CabalSpecVersion - wrongLens :: Functor f => LensLike' f BuildInfo [SymbolicPath PackageDir SourceDir] - wrongLens f bi = (\fps -> set L.hsSourceDirs fps bi) <$> f [] - -optionsFieldGrammar - :: (FieldGrammar c g, Applicative (g BuildInfo), c (List NoCommaFSep Token' String)) - => g BuildInfo (PerCompilerFlavor [String]) -optionsFieldGrammar = PerCompilerFlavor - <$> monoidalFieldAla "ghc-options" (alaList' NoCommaFSep Token') (extract GHC) - <*> monoidalFieldAla "ghcjs-options" (alaList' NoCommaFSep Token') (extract GHCJS) - -- NOTE: Hugs, NHC and JHC are not supported anymore, but these - -- fields are kept around so that we can still parse legacy .cabal - -- files that have them. - <* knownField "jhc-options" - <* knownField "hugs-options" - <* knownField "nhc98-options" - where - extract :: CompilerFlavor -> ALens' BuildInfo [String] - extract flavor = L.options . lookupLens flavor - -profOptionsFieldGrammar - :: (FieldGrammar c g, Applicative (g BuildInfo), c (List NoCommaFSep Token' String)) - => g BuildInfo (PerCompilerFlavor [String]) -profOptionsFieldGrammar = PerCompilerFlavor - <$> monoidalFieldAla "ghc-prof-options" (alaList' NoCommaFSep Token') (extract GHC) - <*> monoidalFieldAla "ghcjs-prof-options" (alaList' NoCommaFSep Token') (extract GHCJS) - where - extract :: CompilerFlavor -> ALens' BuildInfo [String] - extract flavor = L.profOptions . lookupLens flavor - -sharedOptionsFieldGrammar - :: (FieldGrammar c g, Applicative (g BuildInfo), c (List NoCommaFSep Token' String)) - => g BuildInfo (PerCompilerFlavor [String]) -sharedOptionsFieldGrammar = PerCompilerFlavor - <$> monoidalFieldAla "ghc-shared-options" (alaList' NoCommaFSep Token') (extract GHC) - <*> monoidalFieldAla "ghcjs-shared-options" (alaList' NoCommaFSep Token') (extract GHCJS) - where - extract :: CompilerFlavor -> ALens' BuildInfo [String] - extract flavor = L.sharedOptions . lookupLens flavor - -lookupLens :: (Functor f, Monoid v) => CompilerFlavor -> LensLike' f (PerCompilerFlavor v) v -lookupLens k f p@(PerCompilerFlavor ghc ghcjs) - | k == GHC = (\n -> PerCompilerFlavor n ghcjs) <$> f ghc - | k == GHCJS = (\n -> PerCompilerFlavor ghc n) <$> f ghcjs - | otherwise = p <$ f mempty - -------------------------------------------------------------------------------- --- Flag -------------------------------------------------------------------------------- - -flagFieldGrammar - :: (FieldGrammar c g, Applicative (g PackageFlag)) - => FlagName -> g PackageFlag PackageFlag -flagFieldGrammar name = MkPackageFlag name - <$> freeTextFieldDef "description" L.flagDescription - <*> booleanFieldDef "default" L.flagDefault True - <*> booleanFieldDef "manual" L.flagManual False -{-# SPECIALIZE flagFieldGrammar :: FlagName -> ParsecFieldGrammar' PackageFlag #-} -{-# SPECIALIZE flagFieldGrammar :: FlagName -> PrettyFieldGrammar' PackageFlag #-} - -------------------------------------------------------------------------------- --- SourceRepo -------------------------------------------------------------------------------- - -sourceRepoFieldGrammar - :: (FieldGrammar c g, Applicative (g SourceRepo), c (Identity RepoType), c Token, c FilePathNT) - => RepoKind -> g SourceRepo SourceRepo -sourceRepoFieldGrammar kind = SourceRepo kind - <$> optionalField "type" L.repoType - <*> freeTextField "location" L.repoLocation - <*> optionalFieldAla "module" Token L.repoModule - <*> optionalFieldAla "branch" Token L.repoBranch - <*> optionalFieldAla "tag" Token L.repoTag - <*> optionalFieldAla "subdir" FilePathNT L.repoSubdir -{-# SPECIALIZE sourceRepoFieldGrammar :: RepoKind -> ParsecFieldGrammar' SourceRepo #-} -{-# SPECIALIZE sourceRepoFieldGrammar :: RepoKind -> PrettyFieldGrammar' SourceRepo #-} - -------------------------------------------------------------------------------- --- SetupBuildInfo -------------------------------------------------------------------------------- - -setupBInfoFieldGrammar - :: (FieldGrammar c g, Functor (g SetupBuildInfo), c (List CommaVCat (Identity Dependency) Dependency)) - => Bool -> g SetupBuildInfo SetupBuildInfo -setupBInfoFieldGrammar def = flip SetupBuildInfo def - <$> monoidalFieldAla "setup-depends" (alaList CommaVCat) L.setupDepends -{-# SPECIALIZE setupBInfoFieldGrammar :: Bool -> ParsecFieldGrammar' SetupBuildInfo #-} -{-# SPECIALIZE setupBInfoFieldGrammar :: Bool -> PrettyFieldGrammar' SetupBuildInfo #-} - -------------------------------------------------------------------------------- --- Define how field values should be formatted for 'pretty'. -------------------------------------------------------------------------------- - -formatDependencyList :: [Dependency] -> List CommaVCat (Identity Dependency) Dependency -formatDependencyList = alaList CommaVCat - -formatMixinList :: [Mixin] -> List CommaVCat (Identity Mixin) Mixin -formatMixinList = alaList CommaVCat - -formatExtraSourceFiles :: [FilePath] -> List VCat FilePathNT FilePath -formatExtraSourceFiles = alaList' VCat FilePathNT - -formatExposedModules :: [ModuleName] -> List VCat (MQuoted ModuleName) ModuleName -formatExposedModules = alaList' VCat MQuoted - -formatHsSourceDirs :: [SymbolicPath PackageDir SourceDir] -> List FSep (Identity (SymbolicPath PackageDir SourceDir)) (SymbolicPath PackageDir SourceDir) -formatHsSourceDirs = alaList FSep - -formatOtherExtensions :: [Extension] -> List FSep (MQuoted Extension) Extension -formatOtherExtensions = alaList' FSep MQuoted - -formatOtherModules :: [ModuleName] -> List VCat (MQuoted ModuleName) ModuleName -formatOtherModules = alaList' VCat MQuoted - -------------------------------------------------------------------------------- --- newtypes -------------------------------------------------------------------------------- - --- | Compat FilePath accepts empty file path, --- but issues a warning. --- --- There are simply too many (~1200) package definition files --- --- @ --- license-file: "" --- @ --- --- and --- --- @ --- data-dir: "" --- @ --- --- across Hackage to outrule them completely. --- I suspect some of them are generated (e.g. formatted) by machine. --- -newtype CompatFilePath = CompatFilePath { getCompatFilePath :: FilePath } -- TODO: Change to use SymPath - -instance Newtype String CompatFilePath - -instance Parsec CompatFilePath where - parsec = do - token <- parsecToken - if null token - then do - parsecWarning PWTEmptyFilePath "empty FilePath" - return (CompatFilePath "") - else return (CompatFilePath token) - -instance Pretty CompatFilePath where - pretty = showToken . getCompatFilePath - -newtype CompatLicenseFile = CompatLicenseFile { getCompatLicenseFile :: [SymbolicPath PackageDir LicenseFile] } - -instance Newtype [SymbolicPath PackageDir LicenseFile] CompatLicenseFile - --- TODO -instance Parsec CompatLicenseFile where - parsec = emptyToken <|> CompatLicenseFile . unpack' (alaList FSep) <$> parsec - where - emptyToken = P.try $ do - token <- parsecToken - if null token - then return (CompatLicenseFile []) - else P.unexpected "non-empty-token" - -instance Pretty CompatLicenseFile where - pretty = pretty . pack' (alaList FSep) . getCompatLicenseFile - -------------------------------------------------------------------------------- --- vim syntax definitions -------------------------------------------------------------------------------- - --- | '_syntaxFieldNames' and '_syntaxExtensions' --- are for generating VIM syntax file definitions. --- -_syntaxFieldNames :: IO () -_syntaxFieldNames = sequence_ - [ BS8.putStrLn $ " \\ " <> n - | n <- nub $ sort $ mconcat - [ fieldGrammarKnownFieldList packageDescriptionFieldGrammar - , fieldGrammarKnownFieldList $ libraryFieldGrammar LMainLibName - , fieldGrammarKnownFieldList $ executableFieldGrammar "exe" - , fieldGrammarKnownFieldList $ foreignLibFieldGrammar "flib" - , fieldGrammarKnownFieldList testSuiteFieldGrammar - , fieldGrammarKnownFieldList benchmarkFieldGrammar - , fieldGrammarKnownFieldList $ flagFieldGrammar (error "flagname") - , fieldGrammarKnownFieldList $ sourceRepoFieldGrammar (error "repokind") - , fieldGrammarKnownFieldList $ setupBInfoFieldGrammar True - ] - ] - -_syntaxExtensions :: IO () -_syntaxExtensions = sequence_ - [ putStrLn $ " \\ " <> e - | e <- ["Safe","Trustworthy","Unsafe"] - ++ es - ++ map ("No"++) es - ] - where - es = nub $ sort - [ prettyShow e - | e <- [ minBound .. maxBound ] - , e `notElem` [Safe,Unsafe,Trustworthy] - ] diff --git a/src/Distribution/PackageDescription/Parsec.hs b/src/Distribution/PackageDescription/Parsec.hs deleted file mode 100644 --- a/src/Distribution/PackageDescription/Parsec.hs +++ /dev/null @@ -1,980 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE ScopedTypeVariables #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.PackageDescription.Parsec --- Copyright : Isaac Jones 2003-2005 --- License : BSD3 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This defined parsers and partial pretty printers for the @.cabal@ format. - -module Distribution.PackageDescription.Parsec ( - -- * Package descriptions - readGenericPackageDescription, - parseGenericPackageDescription, - parseGenericPackageDescriptionMaybe, - - -- ** Parsing - ParseResult, - runParseResult, - - -- * New-style spec-version - scanSpecVersion, - - -- ** Supplementary build information - readHookedBuildInfo, - parseHookedBuildInfo, - ) where - -import Distribution.Compat.Prelude -import Prelude () - -import Control.Monad.State.Strict (StateT, execStateT) -import Control.Monad.Trans.Class (lift) -import Distribution.CabalSpecVersion -import Distribution.Compat.Lens -import Distribution.FieldGrammar -import Distribution.FieldGrammar.Parsec (NamelessField (..)) -import Distribution.Fields.ConfVar (parseConditionConfVar) -import Distribution.Fields.Field (FieldName, getName) -import Distribution.Fields.LexerMonad (LexWarning, toPWarnings) -import Distribution.Fields.Parser -import Distribution.Fields.ParseResult -import Distribution.PackageDescription -import Distribution.PackageDescription.Configuration (freeVars, transformAllBuildInfos) -import Distribution.PackageDescription.FieldGrammar -import Distribution.PackageDescription.Quirks (patchQuirks) -import Distribution.Parsec (parsec, simpleParsecBS) -import Distribution.Parsec.FieldLineStream (fieldLineStreamFromBS) -import Distribution.Parsec.Position (Position (..), zeroPos) -import Distribution.Parsec.Warning (PWarnType (..)) -import Distribution.Pretty (prettyShow) -import Distribution.Simple.Utils (fromUTF8BS, toUTF8BS) -import Distribution.Utils.Generic (breakMaybe, unfoldrM, validateUTF8) -import Distribution.Verbosity (Verbosity) -import Distribution.Version (Version, mkVersion, versionNumbers) - -import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as BS8 -import qualified Data.Map.Strict as Map -import qualified Data.Set as Set -import qualified Distribution.Compat.Newtype as Newtype -import qualified Distribution.Compat.NonEmptySet as NES -import qualified Distribution.Types.BuildInfo.Lens as L -import qualified Distribution.Types.Executable.Lens as L -import qualified Distribution.Types.ForeignLib.Lens as L -import qualified Distribution.Types.GenericPackageDescription.Lens as L -import qualified Distribution.Types.PackageDescription.Lens as L -import qualified Distribution.Types.SetupBuildInfo.Lens as L -import qualified Text.Parsec as P - --- --------------------------------------------------------------- --- Parsing --- --------------------------------------------------------------- - --- | Parse the given package file. -readGenericPackageDescription :: Verbosity -> FilePath -> IO GenericPackageDescription -readGenericPackageDescription = readAndParseFile parseGenericPackageDescription - ------------------------------------------------------------------------------- --- | Parses the given file into a 'GenericPackageDescription'. --- --- In Cabal 1.2 the syntax for package descriptions was changed to a format --- with sections and possibly indented property descriptions. --- -parseGenericPackageDescription :: BS.ByteString -> ParseResult GenericPackageDescription -parseGenericPackageDescription bs = do - -- set scanned version - setCabalSpecVersion ver - - csv <- case ver of - -- if we get too new version, fail right away - Just v -> case cabalSpecFromVersionDigits (versionNumbers v) of - Just csv -> return (Just csv) - Nothing -> parseFatalFailure zeroPos $ - "Unsupported cabal-version " ++ prettyShow v ++ ". See https://github.com/haskell/cabal/issues/4899." - _ -> pure Nothing - - case readFields' bs'' of - Right (fs, lexWarnings) -> do - when patched $ - parseWarning zeroPos PWTQuirkyCabalFile "Legacy cabal file" - -- UTF8 is validated in a prepass step, afterwards parsing is lenient. - parseGenericPackageDescription' csv lexWarnings invalidUtf8 fs - -- TODO: better marshalling of errors - Left perr -> parseFatalFailure pos (show perr) where - ppos = P.errorPos perr - pos = Position (P.sourceLine ppos) (P.sourceColumn ppos) - where - (patched, bs') = patchQuirks bs - ver = scanSpecVersion bs' - - invalidUtf8 = validateUTF8 bs' - - -- if there are invalid utf8 characters, we make the bytestring valid. - bs'' = case invalidUtf8 of - Nothing -> bs' - Just _ -> toUTF8BS (fromUTF8BS bs') - - --- | 'Maybe' variant of 'parseGenericPackageDescription' -parseGenericPackageDescriptionMaybe :: BS.ByteString -> Maybe GenericPackageDescription -parseGenericPackageDescriptionMaybe = - either (const Nothing) Just . snd . runParseResult . parseGenericPackageDescription - -fieldlinesToBS :: [FieldLine ann] -> BS.ByteString -fieldlinesToBS = BS.intercalate "\n" . map (\(FieldLine _ bs) -> bs) - --- Monad in which sections are parsed -type SectionParser = StateT SectionS ParseResult - --- | State of section parser -data SectionS = SectionS - { _stateGpd :: !GenericPackageDescription - , _stateCommonStanzas :: !(Map String CondTreeBuildInfo) - } - -stateGpd :: Lens' SectionS GenericPackageDescription -stateGpd f (SectionS gpd cs) = (\x -> SectionS x cs) <$> f gpd -{-# INLINE stateGpd #-} - -stateCommonStanzas :: Lens' SectionS (Map String CondTreeBuildInfo) -stateCommonStanzas f (SectionS gpd cs) = SectionS gpd <$> f cs -{-# INLINE stateCommonStanzas #-} - --- Note [Accumulating parser] --- --- This parser has two "states": --- * first we parse fields of PackageDescription --- * then we parse sections (libraries, executables, etc) -parseGenericPackageDescription' - :: Maybe CabalSpecVersion - -> [LexWarning] - -> Maybe Int - -> [Field Position] - -> ParseResult GenericPackageDescription -parseGenericPackageDescription' scannedVer lexWarnings utf8WarnPos fs = do - parseWarnings (toPWarnings lexWarnings) - for_ utf8WarnPos $ \pos -> - parseWarning zeroPos PWTUTF $ "UTF8 encoding problem at byte offset " ++ show pos - let (syntax, fs') = sectionizeFields fs - let (fields, sectionFields) = takeFields fs' - - -- cabal-version - specVer <- case scannedVer of - Just v -> return v - Nothing -> case Map.lookup "cabal-version" fields >>= safeLast of - Nothing -> return CabalSpecV1_0 - Just (MkNamelessField pos fls) -> do - -- version will be parsed twice, therefore we parse without warnings. - v <- withoutWarnings $ - Newtype.unpack' SpecVersion <$> - -- Use version with || and && but before addition of ^>= and removal of -any - runFieldParser pos parsec CabalSpecV1_24 fls - - -- if it were at the beginning, scanner would found it - when (v >= CabalSpecV2_2) $ parseFailure pos $ - "cabal-version should be at the beginning of the file starting with spec version 2.2. " ++ - "See https://github.com/haskell/cabal/issues/4899" - - return v - - -- reset cabal version, it might not be set - let specVer' = mkVersion (cabalSpecToVersionDigits specVer) - setCabalSpecVersion (Just specVer') - - -- Package description - pd <- parseFieldGrammar specVer fields packageDescriptionFieldGrammar - - -- Check that scanned and parsed versions match. - unless (specVer == specVersion pd) $ parseFailure zeroPos $ - "Scanned and parsed cabal-versions don't match " ++ - prettyShow (SpecVersion specVer) ++ " /= " ++ prettyShow (SpecVersion (specVersion pd)) - - maybeWarnCabalVersion syntax pd - - -- Sections - let gpd = emptyGenericPackageDescription - & L.packageDescription .~ pd - gpd1 <- view stateGpd <$> execStateT (goSections specVer sectionFields) (SectionS gpd Map.empty) - - let gpd2 = postProcessInternalDeps specVer gpd1 - checkForUndefinedFlags gpd2 - checkForUndefinedCustomSetup gpd2 - -- See nothunks test, without this deepseq we get (at least): - -- Thunk in ThunkInfo {thunkContext = ["PackageIdentifier","PackageDescription","GenericPackageDescription"]} - -- - -- TODO: re-benchmark, whether `deepseq` is important (both cabal-benchmarks and solver-benchmarks) - -- TODO: remove the need for deepseq if `deepseq` in fact matters - -- NOTE: IIRC it does affect (maximal) memory usage, which causes less GC pressure - gpd2 `deepseq` return gpd2 - where - safeLast :: [a] -> Maybe a - safeLast = listToMaybe . reverse - - newSyntaxVersion :: CabalSpecVersion - newSyntaxVersion = CabalSpecV1_2 - - maybeWarnCabalVersion :: Syntax -> PackageDescription -> ParseResult () - maybeWarnCabalVersion syntax pkg - | syntax == NewSyntax && specVersion pkg < newSyntaxVersion - = parseWarning zeroPos PWTNewSyntax $ - "A package using section syntax must specify at least\n" - ++ "'cabal-version: >= 1.2'." - - maybeWarnCabalVersion syntax pkg - | syntax == OldSyntax && specVersion pkg >= newSyntaxVersion - = parseWarning zeroPos PWTOldSyntax $ - "A package using 'cabal-version: " - ++ prettyShow (SpecVersion (specVersion pkg)) - ++ "' must use section syntax. See the Cabal user guide for details." - - maybeWarnCabalVersion _ _ = return () - -goSections :: CabalSpecVersion -> [Field Position] -> SectionParser () -goSections specVer = traverse_ process - where - process (Field (Name pos name) _) = - lift $ parseWarning pos PWTTrailingFields $ - "Ignoring trailing fields after sections: " ++ show name - process (Section name args secFields) = - parseSection name args secFields - - snoc x xs = xs ++ [x] - - hasCommonStanzas = specHasCommonStanzas specVer - - -- we need signature, because this is polymorphic, but not-closed - parseCondTree' - :: L.HasBuildInfo a - => ParsecFieldGrammar' a -- ^ grammar - -> (BuildInfo -> a) - -> Map String CondTreeBuildInfo -- ^ common stanzas - -> [Field Position] - -> ParseResult (CondTree ConfVar [Dependency] a) - parseCondTree' = parseCondTreeWithCommonStanzas specVer - - parseSection :: Name Position -> [SectionArg Position] -> [Field Position] -> SectionParser () - parseSection (Name pos name) args fields - | hasCommonStanzas == NoCommonStanzas, name == "common" = lift $ do - parseWarning pos PWTUnknownSection $ "Ignoring section: common. You should set cabal-version: 2.2 or larger to use common stanzas." - - | name == "common" = do - commonStanzas <- use stateCommonStanzas - name' <- lift $ parseCommonName pos args - biTree <- lift $ parseCondTree' buildInfoFieldGrammar id commonStanzas fields - - case Map.lookup name' commonStanzas of - Nothing -> stateCommonStanzas .= Map.insert name' biTree commonStanzas - Just _ -> lift $ parseFailure pos $ - "Duplicate common stanza: " ++ name' - - | name == "library" && null args = do - prev <- use $ stateGpd . L.condLibrary - when (isJust prev) $ lift $ parseFailure pos $ - "Multiple main libraries; have you forgotten to specify a name for an internal library?" - - commonStanzas <- use stateCommonStanzas - let name'' = LMainLibName - lib <- lift $ parseCondTree' (libraryFieldGrammar name'') (libraryFromBuildInfo name'') commonStanzas fields - -- - -- TODO check that not set - stateGpd . L.condLibrary ?= lib - - -- Sublibraries - -- TODO: check cabal-version - | name == "library" = do - commonStanzas <- use stateCommonStanzas - name' <- parseUnqualComponentName pos args - let name'' = LSubLibName name' - lib <- lift $ parseCondTree' (libraryFieldGrammar name'') (libraryFromBuildInfo name'') commonStanzas fields - -- TODO check duplicate name here? - stateGpd . L.condSubLibraries %= snoc (name', lib) - - -- TODO: check cabal-version - | name == "foreign-library" = do - commonStanzas <- use stateCommonStanzas - name' <- parseUnqualComponentName pos args - flib <- lift $ parseCondTree' (foreignLibFieldGrammar name') (fromBuildInfo' name') commonStanzas fields - - let hasType ts = foreignLibType ts /= foreignLibType mempty - unless (onAllBranches hasType flib) $ lift $ parseFailure pos $ concat - [ "Foreign library " ++ show (prettyShow name') - , " is missing required field \"type\" or the field " - , "is not present in all conditional branches. The " - , "available test types are: " - , intercalate ", " (map prettyShow knownForeignLibTypes) - ] - - -- TODO check duplicate name here? - stateGpd . L.condForeignLibs %= snoc (name', flib) - - | name == "executable" = do - commonStanzas <- use stateCommonStanzas - name' <- parseUnqualComponentName pos args - exe <- lift $ parseCondTree' (executableFieldGrammar name') (fromBuildInfo' name') commonStanzas fields - -- TODO check duplicate name here? - stateGpd . L.condExecutables %= snoc (name', exe) - - | name == "test-suite" = do - commonStanzas <- use stateCommonStanzas - name' <- parseUnqualComponentName pos args - testStanza <- lift $ parseCondTree' testSuiteFieldGrammar (fromBuildInfo' name') commonStanzas fields - testSuite <- lift $ traverse (validateTestSuite pos) testStanza - - let hasType ts = testInterface ts /= testInterface mempty - unless (onAllBranches hasType testSuite) $ lift $ parseFailure pos $ concat - [ "Test suite " ++ show (prettyShow name') - , " is missing required field \"type\" or the field " - , "is not present in all conditional branches. The " - , "available test types are: " - , intercalate ", " (map prettyShow knownTestTypes) - ] - - -- TODO check duplicate name here? - stateGpd . L.condTestSuites %= snoc (name', testSuite) - - | name == "benchmark" = do - commonStanzas <- use stateCommonStanzas - name' <- parseUnqualComponentName pos args - benchStanza <- lift $ parseCondTree' benchmarkFieldGrammar (fromBuildInfo' name') commonStanzas fields - bench <- lift $ traverse (validateBenchmark pos) benchStanza - - let hasType ts = benchmarkInterface ts /= benchmarkInterface mempty - unless (onAllBranches hasType bench) $ lift $ parseFailure pos $ concat - [ "Benchmark " ++ show (prettyShow name') - , " is missing required field \"type\" or the field " - , "is not present in all conditional branches. The " - , "available benchmark types are: " - , intercalate ", " (map prettyShow knownBenchmarkTypes) - ] - - -- TODO check duplicate name here? - stateGpd . L.condBenchmarks %= snoc (name', bench) - - | name == "flag" = do - name' <- parseNameBS pos args - name'' <- lift $ runFieldParser' [pos] parsec specVer (fieldLineStreamFromBS name') `recoverWith` mkFlagName "" - flag <- lift $ parseFields specVer fields (flagFieldGrammar name'') - -- Check default flag - stateGpd . L.genPackageFlags %= snoc flag - - | name == "custom-setup" && null args = do - sbi <- lift $ parseFields specVer fields (setupBInfoFieldGrammar False) - stateGpd . L.packageDescription . L.setupBuildInfo ?= sbi - - | name == "source-repository" = do - kind <- lift $ case args of - [SecArgName spos secName] -> - runFieldParser' [spos] parsec specVer (fieldLineStreamFromBS secName) `recoverWith` RepoHead - [] -> do - parseFailure pos "'source-repository' requires exactly one argument" - pure RepoHead - _ -> do - parseFailure pos $ "Invalid source-repository kind " ++ show args - pure RepoHead - - sr <- lift $ parseFields specVer fields (sourceRepoFieldGrammar kind) - stateGpd . L.packageDescription . L.sourceRepos %= snoc sr - - | otherwise = lift $ - parseWarning pos PWTUnknownSection $ "Ignoring section: " ++ show name - -parseName :: Position -> [SectionArg Position] -> SectionParser String -parseName pos args = fromUTF8BS <$> parseNameBS pos args - -parseNameBS :: Position -> [SectionArg Position] -> SectionParser BS.ByteString --- TODO: use strict parser -parseNameBS pos args = case args of - [SecArgName _pos secName] -> - pure secName - [SecArgStr _pos secName] -> - pure secName - [] -> do - lift $ parseFailure pos "name required" - pure "" - _ -> do - -- TODO: pretty print args - lift $ parseFailure pos $ "Invalid name " ++ show args - pure "" - -parseCommonName :: Position -> [SectionArg Position] -> ParseResult String -parseCommonName pos args = case args of - [SecArgName _pos secName] -> - pure $ fromUTF8BS secName - [SecArgStr _pos secName] -> - pure $ fromUTF8BS secName - [] -> do - parseFailure pos $ "name required" - pure "" - _ -> do - -- TODO: pretty print args - parseFailure pos $ "Invalid name " ++ show args - pure "" - --- TODO: avoid conversion to 'String'. -parseUnqualComponentName :: Position -> [SectionArg Position] -> SectionParser UnqualComponentName -parseUnqualComponentName pos args = mkUnqualComponentName <$> parseName pos args - --- | Parse a non-recursive list of fields. -parseFields - :: CabalSpecVersion - -> [Field Position] -- ^ fields to be parsed - -> ParsecFieldGrammar' a - -> ParseResult a -parseFields v fields grammar = do - let (fs0, ss) = partitionFields fields - traverse_ (traverse_ warnInvalidSubsection) ss - parseFieldGrammar v fs0 grammar - -warnInvalidSubsection :: Section Position -> ParseResult () -warnInvalidSubsection (MkSection (Name pos name) _ _) = - void $ parseFailure pos $ "invalid subsection " ++ show name - -parseCondTree - :: forall a. L.HasBuildInfo a - => CabalSpecVersion - -> HasElif -- ^ accept @elif@ - -> ParsecFieldGrammar' a -- ^ grammar - -> Map String CondTreeBuildInfo -- ^ common stanzas - -> (BuildInfo -> a) -- ^ constructor from buildInfo - -> (a -> [Dependency]) -- ^ condition extractor - -> [Field Position] - -> ParseResult (CondTree ConfVar [Dependency] a) -parseCondTree v hasElif grammar commonStanzas fromBuildInfo cond = go - where - go fields0 = do - (fields, endo) <- - if v >= CabalSpecV3_0 - then processImports v fromBuildInfo commonStanzas fields0 - else traverse (warnImport v) fields0 >>= \fields1 -> return (catMaybes fields1, id) - - let (fs, ss) = partitionFields fields - x <- parseFieldGrammar v fs grammar - branches <- concat <$> traverse parseIfs ss - return $ endo $ CondNode x (cond x) branches - - parseIfs :: [Section Position] -> ParseResult [CondBranch ConfVar [Dependency] a] - parseIfs [] = return [] - parseIfs (MkSection (Name _ name) test fields : sections) | name == "if" = do - test' <- parseConditionConfVar test - fields' <- go fields - (elseFields, sections') <- parseElseIfs sections - return (CondBranch test' fields' elseFields : sections') - parseIfs (MkSection (Name pos name) _ _ : sections) = do - parseWarning pos PWTInvalidSubsection $ "invalid subsection " ++ show name - parseIfs sections - - parseElseIfs - :: [Section Position] - -> ParseResult (Maybe (CondTree ConfVar [Dependency] a), [CondBranch ConfVar [Dependency] a]) - parseElseIfs [] = return (Nothing, []) - parseElseIfs (MkSection (Name pos name) args fields : sections) | name == "else" = do - unless (null args) $ - parseFailure pos $ "`else` section has section arguments " ++ show args - elseFields <- go fields - sections' <- parseIfs sections - return (Just elseFields, sections') - - parseElseIfs (MkSection (Name _ name) test fields : sections) | hasElif == HasElif, name == "elif" = do - test' <- parseConditionConfVar test - fields' <- go fields - (elseFields, sections') <- parseElseIfs sections - -- we parse an empty 'Fields', to get empty value for a node - a <- parseFieldGrammar v mempty grammar - return (Just $ CondNode a (cond a) [CondBranch test' fields' elseFields], sections') - - parseElseIfs (MkSection (Name pos name) _ _ : sections) | name == "elif" = do - parseWarning pos PWTInvalidSubsection $ "invalid subsection \"elif\". You should set cabal-version: 2.2 or larger to use elif-conditionals." - (,) Nothing <$> parseIfs sections - - parseElseIfs sections = (,) Nothing <$> parseIfs sections - -{- Note [Accumulating parser] - -Note: Outdated a bit - -In there parser, @'FieldDescr' a@ is transformed into @Map FieldName (a -> -FieldParser a)@. The weird value is used because we accumulate structure of -@a@ by folding over the fields. There are various reasons for that: - -* Almost all fields are optional - -* This is simple approach so declarative bi-directional format (parsing and -printing) of structure could be specified (list of @'FieldDescr' a@) - -* There are surface syntax fields corresponding to single field in the file: - @license-file@ and @license-files@ - -* This is quite safe approach. - -When/if we re-implement the parser to support formatting preservging roundtrip -with new AST, this all need to be rewritten. --} - -------------------------------------------------------------------------------- --- Common stanzas -------------------------------------------------------------------------------- - --- $commonStanzas --- --- [Note: Common stanzas] --- --- In Cabal 2.2 we support simple common stanzas: --- --- * Commons stanzas define 'BuildInfo' --- --- * import "fields" can only occur at top of other stanzas (think: imports) --- --- In particular __there aren't__ --- --- * implicit stanzas --- --- * More specific common stanzas (executable, test-suite). --- --- --- The approach uses the fact that 'BuildInfo' is a 'Monoid': --- --- @ --- mergeCommonStanza' :: HasBuildInfo comp => BuildInfo -> comp -> comp --- mergeCommonStanza' bi = over L.BuildInfo (bi <>) --- @ --- --- Real 'mergeCommonStanza' is more complicated as we have to deal with --- conditional trees. --- --- The approach is simple, and have good properties: --- --- * Common stanzas are parsed exactly once, even if not-used. Thus we report errors in them. --- -type CondTreeBuildInfo = CondTree ConfVar [Dependency] BuildInfo - --- | Create @a@ from 'BuildInfo'. --- This class is used to implement common stanza parsing. --- --- Law: @view buildInfo . fromBuildInfo = id@ --- --- This takes name, as 'FieldGrammar's take names too. -class L.HasBuildInfo a => FromBuildInfo a where - fromBuildInfo' :: UnqualComponentName -> BuildInfo -> a - -libraryFromBuildInfo :: LibraryName -> BuildInfo -> Library -libraryFromBuildInfo n bi = emptyLibrary - { libName = n - , libVisibility = case n of - LMainLibName -> LibraryVisibilityPublic - LSubLibName _ -> LibraryVisibilityPrivate - , libBuildInfo = bi - } - -instance FromBuildInfo BuildInfo where fromBuildInfo' _ = id -instance FromBuildInfo ForeignLib where fromBuildInfo' n bi = set L.foreignLibName n $ set L.buildInfo bi emptyForeignLib -instance FromBuildInfo Executable where fromBuildInfo' n bi = set L.exeName n $ set L.buildInfo bi emptyExecutable - -instance FromBuildInfo TestSuiteStanza where - fromBuildInfo' _ bi = TestSuiteStanza Nothing Nothing Nothing bi - -instance FromBuildInfo BenchmarkStanza where - fromBuildInfo' _ bi = BenchmarkStanza Nothing Nothing Nothing bi - -parseCondTreeWithCommonStanzas - :: forall a. L.HasBuildInfo a - => CabalSpecVersion - -> ParsecFieldGrammar' a -- ^ grammar - -> (BuildInfo -> a) -- ^ construct fromBuildInfo - -> Map String CondTreeBuildInfo -- ^ common stanzas - -> [Field Position] - -> ParseResult (CondTree ConfVar [Dependency] a) -parseCondTreeWithCommonStanzas v grammar fromBuildInfo commonStanzas fields = do - (fields', endo) <- processImports v fromBuildInfo commonStanzas fields - x <- parseCondTree v hasElif grammar commonStanzas fromBuildInfo (view L.targetBuildDepends) fields' - return (endo x) - where - hasElif = specHasElif v - -processImports - :: forall a. L.HasBuildInfo a - => CabalSpecVersion - -> (BuildInfo -> a) -- ^ construct fromBuildInfo - -> Map String CondTreeBuildInfo -- ^ common stanzas - -> [Field Position] - -> ParseResult ([Field Position], CondTree ConfVar [Dependency] a -> CondTree ConfVar [Dependency] a) -processImports v fromBuildInfo commonStanzas = go [] - where - hasCommonStanzas = specHasCommonStanzas v - - getList' :: List CommaFSep Token String -> [String] - getList' = Newtype.unpack - - go acc (Field (Name pos name) _ : fields) | name == "import", hasCommonStanzas == NoCommonStanzas = do - parseWarning pos PWTUnknownField "Unknown field: import. You should set cabal-version: 2.2 or larger to use common stanzas" - go acc fields - -- supported: - go acc (Field (Name pos name) fls : fields) | name == "import" = do - names <- getList' <$> runFieldParser pos parsec v fls - names' <- for names $ \commonName -> - case Map.lookup commonName commonStanzas of - Nothing -> do - parseFailure pos $ "Undefined common stanza imported: " ++ commonName - pure Nothing - Just commonTree -> - pure (Just commonTree) - - go (acc ++ catMaybes names') fields - - -- parse actual CondTree - go acc fields = do - fields' <- catMaybes <$> traverse (warnImport v) fields - pure $ (fields', \x -> foldr (mergeCommonStanza fromBuildInfo) x acc) - --- | Warn on "import" fields, also map to Maybe, so errorneous fields can be filtered -warnImport :: CabalSpecVersion -> Field Position -> ParseResult (Maybe (Field Position)) -warnImport v (Field (Name pos name) _) | name == "import" = do - if specHasCommonStanzas v == NoCommonStanzas - then parseWarning pos PWTUnknownField "Unknown field: import. You should set cabal-version: 2.2 or larger to use common stanzas" - else parseWarning pos PWTUnknownField "Unknown field: import. Common stanza imports should be at the top of the enclosing section" - return Nothing -warnImport _ f = pure (Just f) - -mergeCommonStanza - :: L.HasBuildInfo a - => (BuildInfo -> a) - -> CondTree ConfVar [Dependency] BuildInfo - -> CondTree ConfVar [Dependency] a - -> CondTree ConfVar [Dependency] a -mergeCommonStanza fromBuildInfo (CondNode bi _ bis) (CondNode x _ cs) = - CondNode x' (x' ^. L.targetBuildDepends) cs' - where - -- new value is old value with buildInfo field _prepended_. - x' = x & L.buildInfo %~ (bi <>) - - -- tree components are appended together. - cs' = map (fmap fromBuildInfo) bis ++ cs - -------------------------------------------------------------------------------- --- Branches -------------------------------------------------------------------------------- - --- Check that a property holds on all branches of a condition tree -onAllBranches :: forall v c a. Monoid a => (a -> Bool) -> CondTree v c a -> Bool -onAllBranches p = go mempty - where - -- If the current level of the tree satisfies the property, then we are - -- done. If not, then one of the conditional branches below the current node - -- must satisfy it. Each node may have multiple immediate children; we only - -- one need one to satisfy the property because the configure step uses - -- 'mappend' to join together the results of flag resolution. - go :: a -> CondTree v c a -> Bool - go acc ct = let acc' = acc `mappend` condTreeData ct - in p acc' || any (goBranch acc') (condTreeComponents ct) - - -- Both the 'true' and the 'false' block must satisfy the property. - goBranch :: a -> CondBranch v c a -> Bool - goBranch _ (CondBranch _ _ Nothing) = False - goBranch acc (CondBranch _ t (Just e)) = go acc t && go acc e - -------------------------------------------------------------------------------- --- Post parsing checks -------------------------------------------------------------------------------- - --- | Check that we --- --- * don't use undefined flags (very bad) --- * define flags which are unused (just bad) --- -checkForUndefinedFlags :: GenericPackageDescription -> ParseResult () -checkForUndefinedFlags gpd = do - let definedFlags, usedFlags :: Set.Set FlagName - definedFlags = toSetOf (L.genPackageFlags . traverse . getting flagName) gpd - usedFlags = getConst $ L.allCondTrees f gpd - - -- Note: we can check for defined, but unused flags here too. - unless (usedFlags `Set.isSubsetOf` definedFlags) $ parseFailure zeroPos $ - "These flags are used without having been defined: " ++ - intercalate ", " [ unFlagName fn | fn <- Set.toList $ usedFlags `Set.difference` definedFlags ] - where - f :: CondTree ConfVar c a -> Const (Set.Set FlagName) (CondTree ConfVar c a) - f ct = Const (Set.fromList (freeVars ct)) - --- | Since @cabal-version: 1.24@ one can specify @custom-setup@. --- Let us require it. --- -checkForUndefinedCustomSetup :: GenericPackageDescription -> ParseResult () -checkForUndefinedCustomSetup gpd = do - let pd = packageDescription gpd - let csv = specVersion pd - - when (buildType pd == Custom && isNothing (setupBuildInfo pd)) $ - when (csv >= CabalSpecV1_24) $ parseFailure zeroPos $ - "Since cabal-version: 1.24 specifying custom-setup section is mandatory" - -------------------------------------------------------------------------------- --- Post processing of internal dependencies -------------------------------------------------------------------------------- - --- Note [Dependencies on sublibraries] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- This is solution to https://github.com/haskell/cabal/issues/6083 --- --- Before 'cabal-version: 3.0' we didn't have a syntax specially --- for referring to internal libraries. Internal library names --- shadowed the outside ones. --- --- Since 'cabal-version: 3.0' we have ability to write --- --- build-depends: some-package:its-sub-lib >=1.2.3 --- --- This allows us to refer also to local packages by `this-package:sublib`. --- So since 'cabal-version: 3.4' to refer to *any* --- sublibrary we must use the two part syntax. Here's small table: --- --- | pre-3.4 | 3.4 and after | --- ------------------|---------------------|-------------------------------| --- pkg-name | may refer to sublib | always refers to external pkg | --- pkg-name:sublib | refers to sublib | refers to sublib | --- pkg-name:pkg-name | may refer to sublib | always refers to external pkg | --- --- In pre-3.4 case, if a package 'this-pkg' has a sublibrary 'pkg-name', --- all dependency definitions will refer to that sublirary. --- --- In 3.4 and after case, 'pkg-name' will always refer to external package, --- and to use internal library you have to say 'this-pkg:pkg-name'. --- --- In summary, In 3.4 and after, the internal names don't shadow, --- as there is an explicit syntax to refer to them, --- i.e. what you write is what you get; --- For pre-3.4 we post-process the file. --- --- Similarly, we process mixins. --- See https://github.com/haskell/cabal/issues/6281 --- - -postProcessInternalDeps :: CabalSpecVersion -> GenericPackageDescription -> GenericPackageDescription -postProcessInternalDeps specVer gpd - | specVer >= CabalSpecV3_4 = gpd - | otherwise = transformAllBuildInfos transformBI transformSBI gpd - where - transformBI :: BuildInfo -> BuildInfo - transformBI - = over L.targetBuildDepends (concatMap transformD) - . over L.mixins (map transformM) - - transformSBI :: SetupBuildInfo -> SetupBuildInfo - transformSBI = over L.setupDepends (concatMap transformD) - - transformD :: Dependency -> [Dependency] - transformD (Dependency pn vr ln) - | uqn `Set.member` internalLibs - , LMainLibName `NES.member` ln - = case NES.delete LMainLibName ln of - Nothing -> [dep] - Just ln' -> [dep, Dependency pn vr ln'] - where - uqn = packageNameToUnqualComponentName pn - dep = Dependency thisPn vr (NES.singleton (LSubLibName uqn)) - - transformD d = [d] - - transformM :: Mixin -> Mixin - transformM (Mixin pn LMainLibName incl) - | uqn `Set.member` internalLibs - = mkMixin thisPn (LSubLibName uqn) incl - where - uqn = packageNameToUnqualComponentName pn - - transformM m = m - - thisPn :: PackageName - thisPn = pkgName (package (packageDescription gpd)) - - internalLibs :: Set UnqualComponentName - internalLibs = Set.fromList - [ n - | (n, _) <- condSubLibraries gpd - ] - -------------------------------------------------------------------------------- --- Old syntax -------------------------------------------------------------------------------- - --- TODO: move to own module - --- | "Sectionize" an old-style Cabal file. A sectionized file has: --- --- * all global fields at the beginning, followed by --- --- * all flag declarations, followed by --- --- * an optional library section, and an arbitrary number of executable --- sections (in any order). --- --- The current implementation just gathers all library-specific fields --- in a library section and wraps all executable stanzas in an executable --- section. -sectionizeFields :: [Field ann] -> (Syntax, [Field ann]) -sectionizeFields fs = case classifyFields fs of - Just fields -> (OldSyntax, convert fields) - Nothing -> (NewSyntax, fs) - where - -- return 'Just' if all fields are simple fields - classifyFields :: [Field ann] -> Maybe [(Name ann, [FieldLine ann])] - classifyFields = traverse f - where - f (Field name fieldlines) = Just (name, fieldlines) - f _ = Nothing - - trim = BS.dropWhile isSpace' . BS.reverse . BS.dropWhile isSpace' . BS.reverse - isSpace' = (== 32) - - convert :: [(Name ann, [FieldLine ann])] -> [Field ann] - convert fields = - let - toField (name, ls) = Field name ls - -- "build-depends" is a local field now. To be backwards - -- compatible, we still allow it as a global field in old-style - -- package description files and translate it to a local field by - -- adding it to every non-empty section - (hdr0, exes0) = break ((=="executable") . getName . fst) fields - (hdr, libfs0) = partition (not . (`elem` libFieldNames) . getName . fst) hdr0 - - (deps, libfs) = partition ((== "build-depends") . getName . fst) - libfs0 - - exes = unfoldr toExe exes0 - toExe [] = Nothing - toExe ((Name pos n, ls) : r) - | n == "executable" = - let (efs, r') = break ((== "executable") . getName . fst) r - in Just (Section (Name pos "executable") [SecArgName pos $ trim $ fieldlinesToBS ls] (map toField $ deps ++ efs), r') - toExe _ = error "unexpected input to 'toExe'" - - lib = case libfs of - [] -> [] - ((Name pos _, _) : _) -> - [Section (Name pos "library") [] (map toField $ deps ++ libfs)] - - in map toField hdr ++ lib ++ exes - --- | See 'sectionizeFields'. -data Syntax = OldSyntax | NewSyntax - deriving (Eq, Show) - --- TODO: -libFieldNames :: [FieldName] -libFieldNames = fieldGrammarKnownFieldList (libraryFieldGrammar LMainLibName) - -------------------------------------------------------------------------------- --- Suplementary build information -------------------------------------------------------------------------------- - -readHookedBuildInfo :: Verbosity -> FilePath -> IO HookedBuildInfo -readHookedBuildInfo = readAndParseFile parseHookedBuildInfo - -parseHookedBuildInfo :: BS.ByteString -> ParseResult HookedBuildInfo -parseHookedBuildInfo bs = case readFields' bs of - Right (fs, lexWarnings) -> do - parseHookedBuildInfo' lexWarnings fs - -- TODO: better marshalling of errors - Left perr -> parseFatalFailure zeroPos (show perr) - -parseHookedBuildInfo' - :: [LexWarning] - -> [Field Position] - -> ParseResult HookedBuildInfo -parseHookedBuildInfo' lexWarnings fs = do - parseWarnings (toPWarnings lexWarnings) - (mLibFields, exes) <- stanzas fs - mLib <- parseLib mLibFields - biExes <- traverse parseExe exes - return (mLib, biExes) - where - parseLib :: Fields Position -> ParseResult (Maybe BuildInfo) - parseLib fields - | Map.null fields = pure Nothing - | otherwise = Just <$> parseFieldGrammar cabalSpecLatest fields buildInfoFieldGrammar - - parseExe :: (UnqualComponentName, Fields Position) -> ParseResult (UnqualComponentName, BuildInfo) - parseExe (n, fields) = do - bi <- parseFieldGrammar cabalSpecLatest fields buildInfoFieldGrammar - pure (n, bi) - - stanzas :: [Field Position] -> ParseResult (Fields Position, [(UnqualComponentName, Fields Position)]) - stanzas fields = do - let (hdr0, exes0) = breakMaybe isExecutableField fields - hdr <- toFields hdr0 - exes <- unfoldrM (traverse toExe) exes0 - pure (hdr, exes) - - toFields :: [Field Position] -> ParseResult (Fields Position) - toFields fields = do - let (fields', ss) = partitionFields fields - traverse_ (traverse_ warnInvalidSubsection) ss - pure fields' - - toExe - :: ([FieldLine Position], [Field Position]) - -> ParseResult ((UnqualComponentName, Fields Position), Maybe ([FieldLine Position], [Field Position])) - toExe (fss, fields) = do - name <- runFieldParser zeroPos parsec cabalSpecLatest fss - let (hdr0, rest) = breakMaybe isExecutableField fields - hdr <- toFields hdr0 - pure ((name, hdr), rest) - - isExecutableField (Field (Name _ name) fss) - | name == "executable" = Just fss - | otherwise = Nothing - isExecutableField _ = Nothing - -------------------------------------------------------------------------------- --- Scan of spec version -------------------------------------------------------------------------------- - --- | Quickly scan new-style spec-version --- --- A new-style spec-version declaration begins the .cabal file and --- follow the following case-insensitive grammar (expressed in --- RFC5234 ABNF): --- --- @ --- newstyle-spec-version-decl = "cabal-version" *WS ":" *WS newstyle-pec-version *WS --- --- spec-version = NUM "." NUM [ "." NUM ] --- --- NUM = DIGIT0 / DIGITP 1*DIGIT0 --- DIGIT0 = %x30-39 --- DIGITP = %x31-39 --- WS = %20 --- @ --- -scanSpecVersion :: BS.ByteString -> Maybe Version -scanSpecVersion bs = do - fstline':_ <- pure (BS8.lines bs) - - -- parse - -- normalise: remove all whitespace, convert to lower-case - let fstline = BS.map toLowerW8 $ BS.filter (/= 0x20) fstline' - ["cabal-version",vers] <- pure (BS8.split ':' fstline) - - -- parse - -- - -- This is currently more tolerant regarding leading 0 digits. - -- - ver <- simpleParsecBS vers - guard $ case versionNumbers ver of - [_,_] -> True - [_,_,_] -> True - _ -> False - - pure ver - where - -- | Translate ['A'..'Z'] to ['a'..'z'] - toLowerW8 :: Word8 -> Word8 - toLowerW8 w | 0x40 < w && w < 0x5b = w+0x20 - | otherwise = w diff --git a/src/Distribution/PackageDescription/PrettyPrint.hs b/src/Distribution/PackageDescription/PrettyPrint.hs deleted file mode 100644 --- a/src/Distribution/PackageDescription/PrettyPrint.hs +++ /dev/null @@ -1,282 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.PackageDescription.PrettyPrint --- Copyright : Jürgen Nicklisch-Franken 2010 --- License : BSD3 --- --- Maintainer : cabal-devel@haskell.org --- Stability : provisional --- Portability : portable --- --- Pretty printing for cabal files --- ------------------------------------------------------------------------------ - -module Distribution.PackageDescription.PrettyPrint ( - -- * Generic package descriptions - writeGenericPackageDescription, - showGenericPackageDescription, - ppGenericPackageDescription, - - -- * Package descriptions - writePackageDescription, - showPackageDescription, - - -- ** Supplementary build information - writeHookedBuildInfo, - showHookedBuildInfo, -) where - -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.CabalSpecVersion -import Distribution.Fields.Pretty -import Distribution.Compat.Lens -import Distribution.PackageDescription -import Distribution.Pretty -import Distribution.Simple.Utils (writeFileAtomic, writeUTF8File) -import Distribution.FieldGrammar (PrettyFieldGrammar', prettyFieldGrammar) -import Distribution.PackageDescription.Configuration (transformAllBuildInfos) -import Distribution.PackageDescription.FieldGrammar - (benchmarkFieldGrammar, buildInfoFieldGrammar, executableFieldGrammar, flagFieldGrammar, foreignLibFieldGrammar, libraryFieldGrammar, - packageDescriptionFieldGrammar, setupBInfoFieldGrammar, sourceRepoFieldGrammar, testSuiteFieldGrammar) - -import qualified Distribution.PackageDescription.FieldGrammar as FG -import qualified Distribution.Types.BuildInfo.Lens as L -import qualified Distribution.Types.SetupBuildInfo.Lens as L - -import Text.PrettyPrint (Doc, char, hsep, parens, text) - -import qualified Data.ByteString.Lazy.Char8 as BS.Char8 -import qualified Distribution.Compat.NonEmptySet as NES - --- | Writes a .cabal file from a generic package description -writeGenericPackageDescription :: FilePath -> GenericPackageDescription -> IO () -writeGenericPackageDescription fpath pkg = writeUTF8File fpath (showGenericPackageDescription pkg) - --- | Writes a generic package description to a string -showGenericPackageDescription :: GenericPackageDescription -> String -showGenericPackageDescription gpd = showFields (const []) $ ppGenericPackageDescription v gpd - where - v = specVersion $ packageDescription gpd - --- | Convert a generic package description to 'PrettyField's. -ppGenericPackageDescription :: CabalSpecVersion -> GenericPackageDescription -> [PrettyField ()] -ppGenericPackageDescription v gpd0 = concat - [ ppPackageDescription v (packageDescription gpd) - , ppSetupBInfo v (setupBuildInfo (packageDescription gpd)) - , ppGenPackageFlags v (genPackageFlags gpd) - , ppCondLibrary v (condLibrary gpd) - , ppCondSubLibraries v (condSubLibraries gpd) - , ppCondForeignLibs v (condForeignLibs gpd) - , ppCondExecutables v (condExecutables gpd) - , ppCondTestSuites v (condTestSuites gpd) - , ppCondBenchmarks v (condBenchmarks gpd) - ] - where - gpd = preProcessInternalDeps (specVersion (packageDescription gpd0)) gpd0 - - -ppPackageDescription :: CabalSpecVersion -> PackageDescription -> [PrettyField ()] -ppPackageDescription v pd = - prettyFieldGrammar v packageDescriptionFieldGrammar pd - ++ ppSourceRepos v (sourceRepos pd) - -ppSourceRepos :: CabalSpecVersion -> [SourceRepo] -> [PrettyField ()] -ppSourceRepos = map . ppSourceRepo - -ppSourceRepo :: CabalSpecVersion -> SourceRepo -> PrettyField () -ppSourceRepo v repo = PrettySection () "source-repository" [pretty kind] $ - prettyFieldGrammar v (sourceRepoFieldGrammar kind) repo - where - kind = repoKind repo - -ppSetupBInfo :: CabalSpecVersion -> Maybe SetupBuildInfo -> [PrettyField ()] -ppSetupBInfo _ Nothing = mempty -ppSetupBInfo v (Just sbi) - | defaultSetupDepends sbi = mempty - | otherwise = pure $ PrettySection () "custom-setup" [] $ - prettyFieldGrammar v (setupBInfoFieldGrammar False) sbi - -ppGenPackageFlags :: CabalSpecVersion -> [PackageFlag] -> [PrettyField ()] -ppGenPackageFlags = map . ppFlag - -ppFlag :: CabalSpecVersion -> PackageFlag -> PrettyField () -ppFlag v flag@(MkPackageFlag name _ _ _) = PrettySection () "flag" [ppFlagName name] $ - prettyFieldGrammar v (flagFieldGrammar name) flag - -ppCondTree2 :: CabalSpecVersion -> PrettyFieldGrammar' s -> CondTree ConfVar [Dependency] s -> [PrettyField ()] -ppCondTree2 v grammar = go - where - -- TODO: recognise elif opportunities - go (CondNode it _ ifs) = - prettyFieldGrammar v grammar it ++ - concatMap ppIf ifs - - ppIf (CondBranch c thenTree Nothing) --- | isEmpty thenDoc = mempty - | otherwise = [ppIfCondition c thenDoc] - where - thenDoc = go thenTree - - ppIf (CondBranch c thenTree (Just elseTree)) = - -- See #6193 - [ ppIfCondition c (go thenTree) - , PrettySection () "else" [] (go elseTree) - ] - -ppCondLibrary :: CabalSpecVersion -> Maybe (CondTree ConfVar [Dependency] Library) -> [PrettyField ()] -ppCondLibrary _ Nothing = mempty -ppCondLibrary v (Just condTree) = pure $ PrettySection () "library" [] $ - ppCondTree2 v (libraryFieldGrammar LMainLibName) condTree - -ppCondSubLibraries :: CabalSpecVersion -> [(UnqualComponentName, CondTree ConfVar [Dependency] Library)] -> [PrettyField ()] -ppCondSubLibraries v libs = - [ PrettySection () "library" [pretty n] - $ ppCondTree2 v (libraryFieldGrammar $ LSubLibName n) condTree - | (n, condTree) <- libs - ] - -ppCondForeignLibs :: CabalSpecVersion -> [(UnqualComponentName, CondTree ConfVar [Dependency] ForeignLib)] -> [PrettyField ()] -ppCondForeignLibs v flibs = - [ PrettySection () "foreign-library" [pretty n] - $ ppCondTree2 v (foreignLibFieldGrammar n) condTree - | (n, condTree) <- flibs - ] - -ppCondExecutables :: CabalSpecVersion -> [(UnqualComponentName, CondTree ConfVar [Dependency] Executable)] -> [PrettyField ()] -ppCondExecutables v exes = - [ PrettySection () "executable" [pretty n] - $ ppCondTree2 v (executableFieldGrammar n) condTree - | (n, condTree) <- exes - ] - -ppCondTestSuites :: CabalSpecVersion -> [(UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)] -> [PrettyField ()] -ppCondTestSuites v suites = - [ PrettySection () "test-suite" [pretty n] - $ ppCondTree2 v testSuiteFieldGrammar (fmap FG.unvalidateTestSuite condTree) - | (n, condTree) <- suites - ] - -ppCondBenchmarks :: CabalSpecVersion -> [(UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)] -> [PrettyField ()] -ppCondBenchmarks v suites = - [ PrettySection () "benchmark" [pretty n] - $ ppCondTree2 v benchmarkFieldGrammar (fmap FG.unvalidateBenchmark condTree) - | (n, condTree) <- suites - ] - -ppCondition :: Condition ConfVar -> Doc -ppCondition (Var x) = ppConfVar x -ppCondition (Lit b) = text (show b) -ppCondition (CNot c) = char '!' <<>> (ppCondition c) -ppCondition (COr c1 c2) = parens (hsep [ppCondition c1, text "||" - <+> ppCondition c2]) -ppCondition (CAnd c1 c2) = parens (hsep [ppCondition c1, text "&&" - <+> ppCondition c2]) -ppConfVar :: ConfVar -> Doc -ppConfVar (OS os) = text "os" <<>> parens (pretty os) -ppConfVar (Arch arch) = text "arch" <<>> parens (pretty arch) -ppConfVar (PackageFlag name) = text "flag" <<>> parens (ppFlagName name) -ppConfVar (Impl c v) = text "impl" <<>> parens (pretty c <+> pretty v) - -ppFlagName :: FlagName -> Doc -ppFlagName = text . unFlagName - -ppIfCondition :: Condition ConfVar -> [PrettyField ()] -> PrettyField () -ppIfCondition c = PrettySection () "if" [ppCondition c] - --- | @since 2.0.0.2 -writePackageDescription :: FilePath -> PackageDescription -> IO () -writePackageDescription fpath pkg = writeUTF8File fpath (showPackageDescription pkg) - ---TODO: make this use section syntax --- add equivalent for GenericPackageDescription - --- | @since 2.0.0.2 -showPackageDescription :: PackageDescription -> String -showPackageDescription = showGenericPackageDescription . pdToGpd - -pdToGpd :: PackageDescription -> GenericPackageDescription -pdToGpd pd = GenericPackageDescription - { packageDescription = pd - , gpdScannedVersion = Nothing - , genPackageFlags = [] - , condLibrary = mkCondTree <$> library pd - , condSubLibraries = mkCondTreeL <$> subLibraries pd - , condForeignLibs = mkCondTree' foreignLibName <$> foreignLibs pd - , condExecutables = mkCondTree' exeName <$> executables pd - , condTestSuites = mkCondTree' testName <$> testSuites pd - , condBenchmarks = mkCondTree' benchmarkName <$> benchmarks pd - } - where - -- We set CondTree's [Dependency] to an empty list, as it - -- is not pretty printed anyway. - mkCondTree x = CondNode x [] [] - mkCondTreeL l = (fromMaybe (mkUnqualComponentName "") (libraryNameString (libName l)), CondNode l [] []) - - mkCondTree' - :: (a -> UnqualComponentName) - -> a -> (UnqualComponentName, CondTree ConfVar [Dependency] a) - mkCondTree' f x = (f x, CondNode x [] []) - -------------------------------------------------------------------------------- --- Internal libs -------------------------------------------------------------------------------- - --- See Note [Dependencies on sublibraries] in Distribution.PackageDescription.Parsec --- -preProcessInternalDeps :: CabalSpecVersion -> GenericPackageDescription -> GenericPackageDescription -preProcessInternalDeps specVer gpd - | specVer >= CabalSpecV3_4 = gpd - | otherwise = transformAllBuildInfos transformBI transformSBI gpd - where - transformBI :: BuildInfo -> BuildInfo - transformBI - = over L.targetBuildDepends (concatMap transformD) - . over L.mixins (map transformM) - - transformSBI :: SetupBuildInfo -> SetupBuildInfo - transformSBI = over L.setupDepends (concatMap transformD) - - transformD :: Dependency -> [Dependency] - transformD (Dependency pn vr ln) - | pn == thisPn - = if LMainLibName `NES.member` ln - then Dependency thisPn vr mainLibSet : sublibs - else sublibs - where - sublibs = - [ Dependency (unqualComponentNameToPackageName uqn) vr mainLibSet - | LSubLibName uqn <- NES.toList ln - ] - - transformD d = [d] - - transformM :: Mixin -> Mixin - transformM (Mixin pn (LSubLibName uqn) inc) - | pn == thisPn - = mkMixin (unqualComponentNameToPackageName uqn) LMainLibName inc - transformM m = m - - thisPn :: PackageName - thisPn = pkgName (package (packageDescription gpd)) - -------------------------------------------------------------------------------- --- HookedBuildInfo -------------------------------------------------------------------------------- - --- | @since 2.0.0.2 -writeHookedBuildInfo :: FilePath -> HookedBuildInfo -> IO () -writeHookedBuildInfo fpath = writeFileAtomic fpath . BS.Char8.pack - . showHookedBuildInfo - --- | @since 2.0.0.2 -showHookedBuildInfo :: HookedBuildInfo -> String -showHookedBuildInfo (mb_lib_bi, ex_bis) = showFields (const []) $ - maybe mempty (prettyFieldGrammar cabalSpecLatest buildInfoFieldGrammar) mb_lib_bi ++ - [ PrettySection () "executable:" [pretty name] - $ prettyFieldGrammar cabalSpecLatest buildInfoFieldGrammar bi - | (name, bi) <- ex_bis - ] diff --git a/src/Distribution/PackageDescription/Quirks.hs b/src/Distribution/PackageDescription/Quirks.hs deleted file mode 100644 --- a/src/Distribution/PackageDescription/Quirks.hs +++ /dev/null @@ -1,340 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} --- | --- --- @since 2.2.0.0 -module Distribution.PackageDescription.Quirks (patchQuirks) where - -import Distribution.Compat.Prelude -import Distribution.Utils.MD5 -import GHC.Fingerprint (Fingerprint (..)) -import Prelude () - -import qualified Data.ByteString as BS -import qualified Data.Map as Map - --- | Patch legacy @.cabal@ file contents to allow parsec parser to accept --- all of Hackage. --- --- Bool part of the result tells whether the output is modified. --- --- @since 2.2.0.0 -patchQuirks :: BS.ByteString -> (Bool, BS.ByteString) -patchQuirks bs = case Map.lookup (BS.take 256 bs, md5 bs) patches of - Nothing -> (False, bs) - Just (post, f) - | post /= md5 output -> (False, bs) - | otherwise -> (True, output) - where - output = f bs - --- | 'patches' contains first 256 bytes, pre- and post-fingerprints and a patch function. -patches :: Map.Map (BS.ByteString, Fingerprint) (Fingerprint, BS.ByteString -> BS.ByteString) -patches = Map.fromList - -- http://hackage.haskell.org/package/unicode-transforms-0.3.3 - -- other-modules: . - -- ReadP assumed dot is empty line - [ mk "-- This file has been generated from package.yaml by hpack version 0.17.0.\n--\n-- see: https://github.com/sol/hpack\n\nname: unicode-transforms\nversion: 0.3.3\nsynopsis: Unicode normalization\ndescription: Fast Unic" - (Fingerprint 15958160436627155571 10318709190730872881) - (Fingerprint 11008465475756725834 13815629925116264363) - (bsRemove " other-modules:\n .\n") -- TODO: remove traling \n to test structural-diff - -- http://hackage.haskell.org/package/DSTM-0.1.2 - -- http://hackage.haskell.org/package/DSTM-0.1.1 - -- http://hackage.haskell.org/package/DSTM-0.1 - -- Other Modules: no dash - -- ReadP parsed as section - , mk "Name: DSTM\nVersion: 0.1.2\nCopyright: (c) 2010, Frank Kupke\nLicense: LGPL\nLicense-File: LICENSE\nAuthor: Frank Kupke\nMaintainer: frk@informatik.uni-kiel.de\nCabal-Version: >= 1.2.3\nStability: provisional\nSynopsis: A framework for using STM within distributed " - (Fingerprint 6919263071548559054 9050746360708965827) - (Fingerprint 17015177514298962556 11943164891661867280) - (bsReplace "Other modules:" "-- ") - , mk "Name: DSTM\nVersion: 0.1.1\nCopyright: (c) 2010, Frank Kupke\nLicense: LGPL\nLicense-File: LICENSE\nAuthor: Frank Kupke\nMaintainer: frk@informatik.uni-kiel.de\nCabal-Version: >= 1.2.3\nStability: provisional\nSynopsis: A framework for using STM within distributed " - (Fingerprint 17313105789069667153 9610429408495338584) - (Fingerprint 17250946493484671738 17629939328766863497) - (bsReplace "Other modules:" "-- ") - , mk "Name: DSTM\nVersion: 0.1\nCopyright: (c) 2010, Frank Kupke\nLicense: LGPL\nLicense-File: LICENSE\nAuthor: Frank Kupke\nMaintainer: frk@informatik.uni-kiel.de\nCabal-Version: >= 1.2.3\nStability: provisional\nSynopsis: A framework for using STM within distributed sy" - (Fingerprint 10502599650530614586 16424112934471063115) - (Fingerprint 13562014713536696107 17899511905611879358) - (bsReplace "Other modules:" "-- ") - -- http://hackage.haskell.org/package/control-monad-exception-mtl-0.10.3 - , mk "name: control-monad-exception-mtl\nversion: 0.10.3\nCabal-Version: >= 1.10\nbuild-type: Simple\nlicense: PublicDomain\nauthor: Pepe Iborra\nmaintainer: pepeiborra@gmail.com\nhomepage: http://pepeiborra.github.com/control-monad-exception\nsynopsis: MTL instances f" - (Fingerprint 18274748422558568404 4043538769550834851) - (Fingerprint 11395257416101232635 4303318131190196308) - (bsReplace " default- extensions:" "unknown-section") - -- http://hackage.haskell.org/package/vacuum-opengl-0.0 - -- \DEL character - , mk "Name: vacuum-opengl\nVersion: 0.0\nSynopsis: Visualize live Haskell data structures using vacuum, graphviz and OpenGL.\nDescription: \DELVisualize live Haskell data structures using vacuum, graphviz and OpenGL.\n " - (Fingerprint 5946760521961682577 16933361639326309422) - (Fingerprint 14034745101467101555 14024175957788447824) - (bsRemove "\DEL") - , mk "Name: vacuum-opengl\nVersion: 0.0.1\nSynopsis: Visualize live Haskell data structures using vacuum, graphviz and OpenGL.\nDescription: \DELVisualize live Haskell data structures using vacuum, graphviz and OpenGL.\n " - (Fingerprint 10790950110330119503 1309560249972452700) - (Fingerprint 1565743557025952928 13645502325715033593) - (bsRemove "\DEL") - -- http://hackage.haskell.org/package/ixset-1.0.4 - -- {- comments -} - , mk "Name: ixset\nVersion: 1.0.4\nSynopsis: Efficient relational queries on Haskell sets.\nDescription:\n Create and query sets that are indexed by multiple indices.\nLicense: BSD3\nLicense-file: COPYING\nAut" - (Fingerprint 11886092342440414185 4150518943472101551) - (Fingerprint 5731367240051983879 17473925006273577821) - (bsRemoveStarting "{-") - -- : after section - -- http://hackage.haskell.org/package/ds-kanren - , mk "name: ds-kanren\nversion: 0.2.0.0\nsynopsis: A subset of the miniKanren language\ndescription:\n ds-kanren is an implementation of the language.\n .\n == What's in ds-kanren?\n .\n ['dis" - (Fingerprint 2804006762382336875 9677726932108735838) - (Fingerprint 9830506174094917897 12812107316777006473) - (bsReplace "Test-Suite test-unify:" "Test-Suite \"test-unify:\"" . bsReplace "Test-Suite test-list-ops:" "Test-Suite \"test-list-ops:\"") - , mk "name: ds-kanren\nversion: 0.2.0.1\nsynopsis: A subset of the miniKanren language\ndescription:\n ds-kanren is an implementation of the language.\n\nlicense: MIT\nlicense-file: " - (Fingerprint 9130259649220396193 2155671144384738932) - (Fingerprint 1847988234352024240 4597789823227580457) - (bsReplace "Test-Suite test-unify:" "Test-Suite \"test-unify:\"" . bsReplace "Test-Suite test-list-ops:" "Test-Suite \"test-list-ops:\"") - , mk "name: metric\nversion: 0.1.4\nsynopsis: Metric spaces.\nlicense: MIT\nlicense-file: LICENSE\nauthor: Vikram Verma\nmaintainer: me@vikramverma.com\ncategory: Data\nbuild-type:" - (Fingerprint 6150019278861565482 3066802658031228162) - (Fingerprint 9124826020564520548 15629704249829132420) - (bsReplace "test-suite metric-tests:" "test-suite \"metric-tests:\"") - , mk "name: metric\nversion: 0.2.0\nsynopsis: Metric spaces.\nlicense: MIT\nlicense-file: LICENSE\nauthor: Vikram Verma\nmaintainer: me@vikramverma.com\ncategory: Data\nbuild-type:" - (Fingerprint 4639805967994715694 7859317050376284551) - (Fingerprint 5566222290622325231 873197212916959151) - (bsReplace "test-suite metric-tests:" "test-suite \"metric-tests:\"") - , mk "name: phasechange\ncategory: Data\nversion: 0.1\nauthor: G\195\161bor Lehel\nmaintainer: G\195\161bor Lehel \nhomepage: http://github.com/glehel/phasechange\ncopyright: Copyright (C) 2012 G\195\161bor Lehel\nlicense: " - (Fingerprint 10546509771395401582 245508422312751943) - (Fingerprint 5169853482576003304 7247091607933993833) - (bsReplace "impl(ghc >= 7.4):" "erroneous-section" . bsReplace "impl(ghc >= 7.6):" "erroneous-section") - , mk "Name: smartword\nSynopsis: Web based flash card for Word Smart I and II vocabularies\nVersion: 0.0.0.5\nHomepage: http://kyagrd.dyndns.org/~kyagrd/project/smartword/\nCategory: Web,Education\nLicense: " - (Fingerprint 7803544783533485151 10807347873998191750) - (Fingerprint 1665635316718752601 16212378357991151549) - (bsReplace "build depends:" "--") - , mk "name: shelltestrunner\n-- sync with README.md, ANNOUNCE:\nversion: 1.3\ncategory: Testing\nsynopsis: A tool for testing command-line programs.\ndescription:\n shelltestrunner is a cross-platform tool for testing command-line\n program" - (Fingerprint 4403237110790078829 15392625961066653722) - (Fingerprint 10218887328390239431 4644205837817510221) - (bsReplace "other modules:" "--") - -- &&! - -- http://hackage.haskell.org/package/hblas-0.3.0.0 - , mk "-- Initial hblas.cabal generated by cabal init. For further \n-- documentation, see http://haskell.org/cabal/users-guide/\n\n-- The name of the package.\nname: hblas\n\n-- The package version. See the Haskell package versioning policy (PVP) \n-- " - (Fingerprint 8570120150072467041 18315524331351505945) - (Fingerprint 10838007242302656005 16026440017674974175) - (bsReplace "&&!" "&& !") - , mk "-- Initial hblas.cabal generated by cabal init. For further \n-- documentation, see http://haskell.org/cabal/users-guide/\n\n-- The name of the package.\nname: hblas\n\n-- The package version. See the Haskell package versioning policy (PVP) \n-- " - (Fingerprint 5262875856214215155 10846626274067555320) - (Fingerprint 3022954285783401045 13395975869915955260) - (bsReplace "&&!" "&& !") - , mk "-- Initial hblas.cabal generated by cabal init. For further \n-- documentation, see http://haskell.org/cabal/users-guide/\n\n-- The name of the package.\nname: hblas\n\n-- The package version. See the Haskell package versioning policy (PVP) \n-- " - (Fingerprint 54222628930951453 5526514916844166577) - (Fingerprint 1749630806887010665 8607076506606977549) - (bsReplace "&&!" "&& !") - , mk "-- Initial hblas.cabal generated by cabal init. For further\n-- documentation, see http://haskell.org/cabal/users-guide/\n\n-- The name of the package.\nname: hblas\n\n-- The package version. See the Haskell package versioning policy (PVP)\n-- fo" - (Fingerprint 6817250511240350300 15278852712000783849) - (Fingerprint 15757717081429529536 15542551865099640223) - (bsReplace "&&!" "&& !") - , mk "-- Initial hblas.cabal generated by cabal init. For further\n-- documentation, see http://haskell.org/cabal/users-guide/\n\n-- The name of the package.\nname: hblas\n\n-- The package version. See the Haskell package versioning policy (PVP)\n-- fo" - (Fingerprint 8310050400349211976 201317952074418615) - (Fingerprint 10283381191257209624 4231947623042413334) - (bsReplace "&&!" "&& !") - , mk "-- Initial hblas.cabal generated by cabal init. For further\n-- documentation, see http://haskell.org/cabal/users-guide/\n\n-- The name of the package.\nname: hblas\n\n-- The package version. See the Haskell package versioning policy (PVP)\n-- fo" - (Fingerprint 7010988292906098371 11591884496857936132) - (Fingerprint 6158672440010710301 6419743768695725095) - (bsReplace "&&!" "&& !") - , mk "-- Initial hblas.cabal generated by cabal init. For further\r\n-- documentation, see http://haskell.org/cabal/users-guide/\r\n\r\n-- The name of the package.\r\nname: hblas\r\n\r\n-- The package version. See the Haskell package versioning policy (PVP)" - (Fingerprint 2076850805659055833 16615160726215879467) - (Fingerprint 10634706281258477722 5285812379517916984) - (bsReplace "&&!" "&& !") - , mk "-- Initial hblas.cabal generated by cabal init. For further\r\n-- documentation, see http://haskell.org/cabal/users-guide/\r\n\r\n-- The name of the package.\r\nname: hblas\r\n\r\n-- The package version. See the Haskell package versioning policy (PVP)" - (Fingerprint 11850020631622781099 11956481969231030830) - (Fingerprint 13702868780337762025 13383526367149067158) - (bsReplace "&&!" "&& !") - , mk "-- Initial hblas.cabal generated by cabal init. For further\n-- documentation, see http://haskell.org/cabal/users-guide/\n\n-- The name of the package.\nname: hblas\n\n-- The package version. See the Haskell package versioning policy (PVP)\n-- fo" - (Fingerprint 13690322768477779172 19704059263540994) - (Fingerprint 11189374824645442376 8363528115442591078) - (bsReplace "&&!" "&& !") - -- flag used, but not defined - , mk "name: brainheck\nversion: 0.1.0.2\nsynopsis: Brainh*ck interpreter in haskell\ndescription: Brainh*ck interpreter written in haskell and taking advantage of many prominent libraries\nhomepage: https://gi" - (Fingerprint 6910727116443152200 15401634478524888973) - (Fingerprint 16551412117098094368 16260377389127603629) - (bsReplace "flag(llvm-fast)" "False") - , mk "name: brainheck\r\nversion: 0.1.0.2\r\nx-revision: 1\r\nsynopsis: Brainh*ck interpreter in haskell\r\ndescription: Brainh*ck interpreter written in haskell and taking advantage of many prominent libraries\r\nhomepage: " - (Fingerprint 14320987921316832277 10031098243571536929) - (Fingerprint 7959395602414037224 13279941216182213050) - (bsReplace "flag(llvm-fast)" "False") - , mk "name: brainheck\r\nversion: 0.1.0.2\r\nx-revision: 2\r\nsynopsis: Brainh*ck interpreter in haskell\r\ndescription: Brainh*ck interpreter written in haskell and taking advantage of many prominent libraries\r\nhomepage: " - (Fingerprint 3809078390223299128 10796026010775813741) - (Fingerprint 1127231189459220796 12088367524333209349) - (bsReplace "flag(llvm-fast)" "False") - , mk "name: brainheck\r\nversion: 0.1.0.2\r\nx-revision: 3\r\nsynopsis: Brainh*ck interpreter in haskell\r\ndescription: Brainh*ck interpreter written in haskell and taking advantage of many prominent libraries\r\nhomepage: " - (Fingerprint 13860013038089410950 12479824176801390651) - (Fingerprint 4687484721703340391 8013395164515771785) - (bsReplace "flag(llvm-fast)" "False") - , mk "name: wordchoice\nversion: 0.1.0.1\nsynopsis: Get word counts and distributions\ndescription: A command line tool to compute the word distribution from various types of document, converting to text with pandoc.\nho" - (Fingerprint 16215911397419608203 15594928482155652475) - (Fingerprint 15120681510314491047 2666192399775157359) - (bsReplace "flag(llvm-fast)" "False") - , mk "name: wordchoice\r\nversion: 0.1.0.1\r\nx-revision: 1\r\nsynopsis: Get word counts and distributions\r\ndescription: A command line tool to compute the word distribution from various types of document, converting to te" - (Fingerprint 16593139224723441188 4052919014346212001) - (Fingerprint 3577381082410411593 11481899387780544641) - (bsReplace "flag(llvm-fast)" "False") - , mk "name: wordchoice\nversion: 0.1.0.2\nsynopsis: Get word counts and distributions\ndescription: A command line tool to compute the word distribution from various types of document, converting to text with pandoc.\nho" - (Fingerprint 9321301260802539374 1316392715016096607) - (Fingerprint 3784628652257760949 12662640594755291035) - (bsReplace "flag(llvm-fast)" "False") - , mk "name: wordchoice\r\nversion: 0.1.0.2\r\nx-revision: 1\r\nsynopsis: Get word counts and distributions\r\ndescription: A command line tool to compute the word distribution from various types of document, converting to te" - (Fingerprint 2546901804824433337 2059732715322561176) - (Fingerprint 8082068680348326500 615008613291421947) - (bsReplace "flag(llvm-fast)" "False") - , mk "name: wordchoice\nversion: 0.1.0.3\nsynopsis: Get word counts and distributions\ndescription: A command line tool to compute the word distribution from various types of document, converting to text with pandoc.\nho" - (Fingerprint 2282380737467965407 12457554753171662424) - (Fingerprint 17324757216926991616 17172911843227482125) - (bsReplace "flag(llvm-fast)" "False") - , mk "name: wordchoice\r\nversion: 0.1.0.3\r\nx-revision: 1\r\nsynopsis: Get word counts and distributions\r\ndescription: A command line tool to compute the word distribution from various types of document, converting to te" - (Fingerprint 12907988890480595481 11078473638628359710) - (Fingerprint 13246185333368731848 4663060731847518614) - (bsReplace "flag(llvm-fast)" "False") - , mk "name: hw-prim-bits\nversion: 0.1.0.0\nsynopsis: Primitive support for bit manipulation\ndescription: Please see README.md\nhomepage: https://github.com/githubuser/hw-prim-bits#readme\nlicense: " - (Fingerprint 12386777729082870356 17414156731912743711) - (Fingerprint 3452290353395041602 14102887112483033720) - (bsReplace "flag(sse42)" "False") - , mk "name: hw-prim-bits\nversion: 0.1.0.1\nsynopsis: Primitive support for bit manipulation\ndescription: Please see README.md\nhomepage: https://github.com/githubuser/hw-prim-bits#readme\nlicen" - (Fingerprint 6870520675313101180 14553457351296240636) - (Fingerprint 12481021059537696455 14711088786769892762) - (bsReplace "flag(sse42)" "False") - -- leading zeros in version digits - -- https://github.com/haskell-infra/hackage-trustees/issues/128 - -- https://github.com/haskell/cabal/issues/5092 - -- https://github.com/haskell/cabal/issues/5138 - , mk "name: Sit\nversion: 0.2017.02.26\nbuild-type: Simple\ncabal-version: >= 1.8\nlicense: OtherLicense\nlicense-file: LICENSE\nauthor: Anonymous\nmaintainer: Anonymous\nhomepage: NONE\ncategory: Dependent" - (Fingerprint 8458530898096910998 3228538743646501413) - (Fingerprint 14470502514907936793 17514354054641875371) - (bsReplace "0.2017.02.26" "0.2017.2.26") - , mk "name: Sit\nversion: 0.2017.05.01\nbuild-type: Simple\ncabal-version: >= 1.8\nlicense: OtherLicense\nlicense-file: LICENSE\nauthor: Andreas Abel \nmaintainer: Andreas Abel \n" - (Fingerprint 1450130849535097473 11742099607098860444) - (Fingerprint 16679762943850814021 4253724355613883542) - (bsReplace "0.2017.05.01" "0.2017.5.1") - , mk "name: Sit\nversion: 0.2017.05.02\nbuild-type: Simple\ncabal-version: >= 1.8\nlicense: OtherLicense\nlicense-file: LICENSE\nauthor: Andreas Abel \nmaintainer: Andreas Abel \n" - (Fingerprint 297248532398492441 17322625167861324800) - (Fingerprint 634812045126693280 1755581866539318862) - (bsReplace "0.2017.05.02" "0.2017.5.2") - , mk "name: Sit\nversion: 0.2017.5.02\nx-revision: 1\n-- x-revision:1 see https://github.com/haskell-infra/hackage-trustees/issues/128\nbuild-type: Simple\ncabal-version: >= 1.8\nlicense: OtherLicense\nlicense-file: LICENSE\nauthor: " - (Fingerprint 3697869560530373941 3942982281026987312) - (Fingerprint 14344526114710295386 16386400353475114712) - (bsReplace "0.2017.5.02" "0.2017.5.2") - , mk "name: MiniAgda\nversion: 0.2017.02.18\nbuild-type: Simple\ncabal-version: >= 1.22\nlicense: OtherLicense\nlicense-file: LICENSE\nauthor: Andreas Abel and Karl Mehltretter\nmaintainer: Andreas Abel =1.8\nbuild-type: Simple\nlicense: GPL\nlicense-file: /home/palo/dev/haskell-workspace/playground/reheat/gpl-3.0.txt\ncopyright: GPL\nmaintainer: Ingolf Wagner \nstability: experimental\nhomepage: h" - (Fingerprint 9155400339287317061 14812953666990892802) - (Fingerprint 7687053346032173923 15384472501136606592) - (bsReplace "/home/palo/dev/haskell-workspace/playground/reheat/gpl-3.0.txt" "") - , mk "name: reheat\nversion: 0.1.5\ncabal-version: >=1.8\nbuild-type: Simple\nlicense: GPL\nlicense-file: /home/palo/dev/haskell-workspace/playground/reheat/gpl-3.0.txt\ncopyright: GPL\nmaintainer: Ingolf Wagner \nstability: experimental\nhomepage: h" - (Fingerprint 2984391146441073709 11728234882049907993) - (Fingerprint 12058479081855347701 14017937756688869826) - (bsReplace "/home/palo/dev/haskell-workspace/playground/reheat/gpl-3.0.txt" "") - ] - where - mk a b c d = ((a, b), (c, d)) - --- | Helper to create entries in patches -_makePatchKey :: FilePath -> (BS.ByteString -> BS.ByteString) -> IO () -_makePatchKey fp transform = do - contents <- BS.readFile fp - let output = transform contents - let Fingerprint hi lo = md5 contents - let Fingerprint hi' lo' = md5 output - putStrLn - $ showString " , mk " - . shows (BS.take 256 contents) - . showString "\n (Fingerprint " - . shows hi - . showString " " - . shows lo - . showString ")\n (Fingerprint " - . shows hi' - . showString " " - . shows lo' - . showString ")" - $ "" - -------------------------------------------------------------------------------- --- Patch helpers -------------------------------------------------------------------------------- - -bsRemove - :: BS.ByteString -- ^ needle - -> BS.ByteString -> BS.ByteString -bsRemove needle haystack = case BS.breakSubstring needle haystack of - (h, t) -> BS.append h (BS.drop (BS.length needle) t) - -bsReplace - :: BS.ByteString -- ^ needle - -> BS.ByteString -- ^ replacement - -> BS.ByteString -> BS.ByteString -bsReplace needle repl haystack = case BS.breakSubstring needle haystack of - (h, t) - | not (BS.null t) -> BS.append h (BS.append repl (BS.drop (BS.length needle) t)) - | otherwise -> haystack - -bsRemoveStarting - :: BS.ByteString -- ^ needle - -> BS.ByteString -> BS.ByteString -bsRemoveStarting needle haystack = case BS.breakSubstring needle haystack of - (h, _) -> h diff --git a/src/Distribution/PackageDescription/Utils.hs b/src/Distribution/PackageDescription/Utils.hs deleted file mode 100644 --- a/src/Distribution/PackageDescription/Utils.hs +++ /dev/null @@ -1,23 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.PackageDescription.Utils --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- Common utils used by modules under Distribution.PackageDescription.*. - -module Distribution.PackageDescription.Utils ( - cabalBug, userBug - ) where - --- ---------------------------------------------------------------------------- --- Exception and logging utils - -userBug :: String -> a -userBug msg = error $ msg ++ ". This is a bug in your .cabal file." - -cabalBug :: String -> a -cabalBug msg = error $ msg ++ ". This is possibly a bug in Cabal.\n" - ++ "Please report it to the developers: " - ++ "https://github.com/haskell/cabal/issues/new" diff --git a/src/Distribution/Parsec.hs b/src/Distribution/Parsec.hs deleted file mode 100644 --- a/src/Distribution/Parsec.hs +++ /dev/null @@ -1,524 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -module Distribution.Parsec ( - Parsec(..), - ParsecParser (..), - runParsecParser, - runParsecParser', - simpleParsec, - simpleParsecBS, - simpleParsec', - simpleParsecW', - lexemeParsec, - eitherParsec, - explicitEitherParsec, - explicitEitherParsec', - -- * CabalParsing and diagnostics - CabalParsing (..), - -- ** Warnings - PWarnType (..), - PWarning (..), - showPWarning, - -- ** Errors - PError (..), - showPError, - -- * Position - Position (..), - incPos, - retPos, - showPos, - zeroPos, - -- * Utilities - parsecToken, - parsecToken', - parsecFilePath, - parsecQuoted, - parsecMaybeQuoted, - parsecCommaList, - parsecCommaNonEmpty, - parsecLeadingCommaList, - parsecLeadingCommaNonEmpty, - parsecOptCommaList, - parsecLeadingOptCommaList, - parsecStandard, - parsecUnqualComponentName, - ) where - -import Data.ByteString (ByteString) -import Data.Char (digitToInt, intToDigit) -import Data.List (transpose) -import Distribution.CabalSpecVersion -import Distribution.Compat.Prelude -import Distribution.Parsec.Error (PError (..), showPError) -import Distribution.Parsec.FieldLineStream (FieldLineStream, fieldLineStreamFromBS, fieldLineStreamFromString) -import Distribution.Parsec.Position (Position (..), incPos, retPos, showPos, zeroPos) -import Distribution.Parsec.Warning (PWarnType (..), PWarning (..), showPWarning) -import Numeric (showIntAtBase) -import Prelude () - -import qualified Distribution.Compat.CharParsing as P -import qualified Distribution.Compat.DList as DList -import qualified Distribution.Compat.MonadFail as Fail -import qualified Text.Parsec as Parsec - -------------------------------------------------------------------------------- --- Class -------------------------------------------------------------------------------- - --- | Class for parsing with @parsec@. Mainly used for @.cabal@ file fields. --- --- For parsing @.cabal@ like file structure, see "Distribution.Fields". --- -class Parsec a where - parsec :: CabalParsing m => m a - --- | Parsing class which --- --- * can report Cabal parser warnings. --- --- * knows @cabal-version@ we work with --- -class (P.CharParsing m, MonadPlus m, Fail.MonadFail m) => CabalParsing m where - parsecWarning :: PWarnType -> String -> m () - - parsecHaskellString :: m String - parsecHaskellString = stringLiteral - - askCabalSpecVersion :: m CabalSpecVersion - --- | 'parsec' /could/ consume trailing spaces, this function /will/ consume. -lexemeParsec :: (CabalParsing m, Parsec a) => m a -lexemeParsec = parsec <* P.spaces - -newtype ParsecParser a = PP { unPP - :: CabalSpecVersion -> Parsec.Parsec FieldLineStream [PWarning] a - } - -liftParsec :: Parsec.Parsec FieldLineStream [PWarning] a -> ParsecParser a -liftParsec p = PP $ \_ -> p - -instance Functor ParsecParser where - fmap f p = PP $ \v -> fmap f (unPP p v) - {-# INLINE fmap #-} - - x <$ p = PP $ \v -> x <$ unPP p v - {-# INLINE (<$) #-} - -instance Applicative ParsecParser where - pure = liftParsec . pure - {-# INLINE pure #-} - - f <*> x = PP $ \v -> unPP f v <*> unPP x v - {-# INLINE (<*>) #-} - f *> x = PP $ \v -> unPP f v *> unPP x v - {-# INLINE (*>) #-} - f <* x = PP $ \v -> unPP f v <* unPP x v - {-# INLINE (<*) #-} - -instance Alternative ParsecParser where - empty = liftParsec empty - - a <|> b = PP $ \v -> unPP a v <|> unPP b v - {-# INLINE (<|>) #-} - - many p = PP $ \v -> many (unPP p v) - {-# INLINE many #-} - - some p = PP $ \v -> some (unPP p v) - {-# INLINE some #-} - -instance Monad ParsecParser where - return = pure - - m >>= k = PP $ \v -> unPP m v >>= \x -> unPP (k x) v - {-# INLINE (>>=) #-} - (>>) = (*>) - {-# INLINE (>>) #-} - -#if !(MIN_VERSION_base(4,13,0)) - fail = Fail.fail -#endif - -instance MonadPlus ParsecParser where - mzero = empty - mplus = (<|>) - -instance Fail.MonadFail ParsecParser where - fail = P.unexpected - -instance P.Parsing ParsecParser where - try p = PP $ \v -> P.try (unPP p v) - p d = PP $ \v -> unPP p v P. d - skipMany p = PP $ \v -> P.skipMany (unPP p v) - skipSome p = PP $ \v -> P.skipSome (unPP p v) - unexpected = liftParsec . P.unexpected - eof = liftParsec P.eof - notFollowedBy p = PP $ \v -> P.notFollowedBy (unPP p v) - -instance P.CharParsing ParsecParser where - satisfy = liftParsec . P.satisfy - char = liftParsec . P.char - notChar = liftParsec . P.notChar - anyChar = liftParsec P.anyChar - string = liftParsec . P.string - -instance CabalParsing ParsecParser where - parsecWarning t w = liftParsec $ do - spos <- Parsec.getPosition - Parsec.modifyState - (PWarning t (Position (Parsec.sourceLine spos) (Parsec.sourceColumn spos)) w :) - askCabalSpecVersion = PP pure - --- | Parse a 'String' with 'lexemeParsec'. -simpleParsec :: Parsec a => String -> Maybe a -simpleParsec - = either (const Nothing) Just - . runParsecParser lexemeParsec "" - . fieldLineStreamFromString - --- | Like 'simpleParsec' but for 'ByteString' -simpleParsecBS :: Parsec a => ByteString -> Maybe a -simpleParsecBS - = either (const Nothing) Just - . runParsecParser lexemeParsec "" - . fieldLineStreamFromBS - --- | Parse a 'String' with 'lexemeParsec' using specific 'CabalSpecVersion'. --- --- @since 3.4.0.0 -simpleParsec' :: Parsec a => CabalSpecVersion -> String -> Maybe a -simpleParsec' spec - = either (const Nothing) Just - . runParsecParser' spec lexemeParsec "" - . fieldLineStreamFromString - --- | Parse a 'String' with 'lexemeParsec' using specific 'CabalSpecVersion'. --- Fail if there are any warnings. --- --- @since 3.4.0.0 -simpleParsecW' :: Parsec a => CabalSpecVersion -> String -> Maybe a -simpleParsecW' spec - = either (const Nothing) (\(x, ws) -> if null ws then Just x else Nothing) - . runParsecParser' spec ((,) <$> lexemeParsec <*> liftParsec Parsec.getState) "" - . fieldLineStreamFromString - --- | Parse a 'String' with 'lexemeParsec'. -eitherParsec :: Parsec a => String -> Either String a -eitherParsec = explicitEitherParsec parsec - --- | Parse a 'String' with given 'ParsecParser'. Trailing whitespace is accepted. -explicitEitherParsec :: ParsecParser a -> String -> Either String a -explicitEitherParsec parser - = either (Left . show) Right - . runParsecParser (parser <* P.spaces) "" - . fieldLineStreamFromString - --- | Parse a 'String' with given 'ParsecParser' and 'CabalSpecVersion'. Trailing whitespace is accepted. --- See 'explicitEitherParsec'. --- --- @since 3.4.0.0 --- -explicitEitherParsec' :: CabalSpecVersion -> ParsecParser a -> String -> Either String a -explicitEitherParsec' spec parser - = either (Left . show) Right - . runParsecParser' spec (parser <* P.spaces) "" - . fieldLineStreamFromString - --- | Run 'ParsecParser' with 'cabalSpecLatest'. -runParsecParser :: ParsecParser a -> FilePath -> FieldLineStream -> Either Parsec.ParseError a -runParsecParser = runParsecParser' cabalSpecLatest - --- | Like 'runParsecParser' but lets specify 'CabalSpecVersion' used. --- --- @since 3.0.0.0 --- -runParsecParser' :: CabalSpecVersion -> ParsecParser a -> FilePath -> FieldLineStream -> Either Parsec.ParseError a -runParsecParser' v p n = Parsec.runParser (unPP p v <* P.eof) [] n - -instance Parsec a => Parsec (Identity a) where - parsec = Identity <$> parsec - -instance Parsec Bool where - parsec = P.munch1 isAlpha >>= postprocess - where - postprocess str - | str == "True" = pure True - | str == "False" = pure False - | lstr == "true" = parsecWarning PWTBoolCase caseWarning *> pure True - | lstr == "false" = parsecWarning PWTBoolCase caseWarning *> pure False - | otherwise = fail $ "Not a boolean: " ++ str - where - lstr = map toLower str - caseWarning = - "Boolean values are case sensitive, use 'True' or 'False'." - --- | @[^ ,]@ -parsecToken :: CabalParsing m => m String -parsecToken = parsecHaskellString <|> ((P.munch1 (\x -> not (isSpace x) && x /= ',') P. "identifier" ) >>= checkNotDoubleDash) - --- | @[^ ]@ -parsecToken' :: CabalParsing m => m String -parsecToken' = parsecHaskellString <|> ((P.munch1 (not . isSpace) P. "token") >>= checkNotDoubleDash) - -checkNotDoubleDash :: CabalParsing m => String -> m String -checkNotDoubleDash s = do - when (s == "--") $ parsecWarning PWTDoubleDash $ unwords - [ "Double-dash token found." - , "Note: there are no end-of-line comments in .cabal files, only whole line comments." - , "Use \"--\" (quoted double dash) to silence this warning, if you actually want -- token" - ] - - return s - -parsecFilePath :: CabalParsing m => m FilePath -parsecFilePath = parsecToken - --- | Parse a benchmark/test-suite types. -parsecStandard :: (CabalParsing m, Parsec ver) => (ver -> String -> a) -> m a -parsecStandard f = do - cs <- some $ P.try (component <* P.char '-') - ver <- parsec - let name = map toLower (intercalate "-" cs) - return $! f ver name - where - component = do - cs <- P.munch1 isAlphaNum - if all isDigit cs then fail "all digit component" else return cs - -- each component must contain an alphabetic character, to avoid - -- ambiguity in identifiers like foo-1 (the 1 is the version number). - -parsecCommaList :: CabalParsing m => m a -> m [a] -parsecCommaList p = P.sepBy (p <* P.spaces) (P.char ',' *> P.spaces P. "comma") - -parsecCommaNonEmpty :: CabalParsing m => m a -> m (NonEmpty a) -parsecCommaNonEmpty p = P.sepByNonEmpty (p <* P.spaces) (P.char ',' *> P.spaces P. "comma") - --- | Like 'parsecCommaList' but accept leading or trailing comma. --- --- @ --- p (comma p)* -- p `sepBy` comma --- (comma p)* -- leading comma --- (p comma)* -- trailing comma --- @ -parsecLeadingCommaList :: CabalParsing m => m a -> m [a] -parsecLeadingCommaList p = do - c <- P.optional comma - case c of - Nothing -> toList <$> P.sepEndByNonEmpty lp comma <|> pure [] - Just _ -> toList <$> P.sepByNonEmpty lp comma - where - lp = p <* P.spaces - comma = P.char ',' *> P.spaces P. "comma" - --- | --- --- @since 3.4.0.0 -parsecLeadingCommaNonEmpty :: CabalParsing m => m a -> m (NonEmpty a) -parsecLeadingCommaNonEmpty p = do - c <- P.optional comma - case c of - Nothing -> P.sepEndByNonEmpty lp comma - Just _ -> P.sepByNonEmpty lp comma - where - lp = p <* P.spaces - comma = P.char ',' *> P.spaces P. "comma" - -parsecOptCommaList :: CabalParsing m => m a -> m [a] -parsecOptCommaList p = P.sepBy (p <* P.spaces) (P.optional comma) - where - comma = P.char ',' *> P.spaces - --- | Like 'parsecOptCommaList' but --- --- * require all or none commas --- * accept leading or trailing comma. --- --- @ --- p (comma p)* -- p `sepBy` comma --- (comma p)* -- leading comma --- (p comma)* -- trailing comma --- p* -- no commas: many p --- @ --- --- @since 3.0.0.0 --- -parsecLeadingOptCommaList :: CabalParsing m => m a -> m [a] -parsecLeadingOptCommaList p = do - c <- P.optional comma - case c of - Nothing -> sepEndBy1Start <|> pure [] - Just _ -> toList <$> P.sepByNonEmpty lp comma - where - lp = p <* P.spaces - comma = P.char ',' *> P.spaces P. "comma" - - sepEndBy1Start = do - x <- lp - c <- P.optional comma - case c of - Nothing -> (x :) <$> many lp - Just _ -> (x :) <$> P.sepEndBy lp comma - --- | Content isn't unquoted -parsecQuoted :: CabalParsing m => m a -> m a -parsecQuoted = P.between (P.char '"') (P.char '"') - --- | @parsecMaybeQuoted p = 'parsecQuoted' p <|> p@. -parsecMaybeQuoted :: CabalParsing m => m a -> m a -parsecMaybeQuoted p = parsecQuoted p <|> p - -parsecUnqualComponentName :: forall m. CabalParsing m => m String -parsecUnqualComponentName = state0 DList.empty where - -- - -- using @kleene@ package we can easily see that - -- we need only two states to recognize - -- unqual-component-name - -- - -- Compare with declarative - -- 'Distribution.FieldGrammar.Described.reUnqualComponent'. - -- - -- @ - -- import Kleene - -- import Kleene.Internal.Pretty - -- import Algebra.Lattice - -- import Data.Char - -- - -- import qualified Data.RangeSet.Map as RSet - -- - -- main = do - -- -- this is an approximation, to get an idea. - -- let component :: RE Char - -- component = star alphaNum <> alpha <> star alphaNum - -- - -- alphaNum = alpha \/ num - -- alpha = unions $ map char ['a'..'z'] - -- num = unions $ map char ['0'..'9'] - -- - -- re :: RE Char - -- re = component <> star (char '-' <> component) - -- - -- putPretty re - -- putPretty $ fromTM re - -- @ - - state0 :: DList.DList Char -> m String - state0 acc = do - c <- ch -- <|> fail ("Invalid component, after " ++ DList.toList acc) - case () of - _ | isDigit c -> state0 (DList.snoc acc c) - | isAlphaNum c -> state1 (DList.snoc acc c) - | c == '-' -> fail ("Empty component, after " ++ DList.toList acc) - | otherwise -> fail ("Internal error, after " ++ DList.toList acc) - - state1 :: DList.DList Char -> m String - state1 acc = state1' acc `alt` return (DList.toList acc) - - state1' :: DList.DList Char -> m String - state1' acc = do - c <- ch - case () of - _ | isAlphaNum c -> state1 (DList.snoc acc c) - | c == '-' -> state0 (DList.snoc acc c) - | otherwise -> fail ("Internal error, after " ++ DList.toList acc) - - ch :: m Char - !ch = P.satisfy (\c -> isAlphaNum c || c == '-') - - alt :: m String -> m String -> m String - !alt = (<|>) - -stringLiteral :: forall m. P.CharParsing m => m String -stringLiteral = lit where - lit :: m String - lit = foldr (maybe id (:)) "" - <$> P.between (P.char '"') (P.char '"' P. "end of string") (many stringChar) - P. "string" - - stringChar :: m (Maybe Char) - stringChar = Just <$> stringLetter - <|> stringEscape - P. "string character" - - stringLetter :: m Char - stringLetter = P.satisfy (\c -> (c /= '"') && (c /= '\\') && (c > '\026')) - - stringEscape :: m (Maybe Char) - stringEscape = P.char '\\' *> esc where - esc :: m (Maybe Char) - esc = Nothing <$ escapeGap - <|> Nothing <$ escapeEmpty - <|> Just <$> escapeCode - - escapeEmpty, escapeGap :: m Char - escapeEmpty = P.char '&' - escapeGap = P.skipSpaces1 *> (P.char '\\' P. "end of string gap") - -escapeCode :: forall m. P.CharParsing m => m Char -escapeCode = (charEsc <|> charNum <|> charAscii <|> charControl) P. "escape code" - where - charControl, charNum :: m Char - charControl = (\c -> toEnum (fromEnum c - fromEnum '@')) <$> (P.char '^' *> (P.upper <|> P.char '@')) - charNum = toEnum <$> num - where - num :: m Int - num = bounded 10 maxchar - <|> (P.char 'o' *> bounded 8 maxchar) - <|> (P.char 'x' *> bounded 16 maxchar) - maxchar = fromEnum (maxBound :: Char) - - bounded :: Int -> Int -> m Int - bounded base bnd = foldl' (\x d -> base * x + digitToInt d) 0 - <$> bounded' (take base thedigits) (map digitToInt $ showIntAtBase base intToDigit bnd "") - where - thedigits :: [m Char] - thedigits = map P.char ['0'..'9'] ++ map P.oneOf (transpose [['A'..'F'],['a'..'f']]) - - toomuch :: m a - toomuch = P.unexpected "out-of-range numeric escape sequence" - - bounded', bounded'' :: [m Char] -> [Int] -> m [Char] - bounded' dps@(zero:_) bds = P.skipSome zero *> ([] <$ P.notFollowedBy (P.choice dps) <|> bounded'' dps bds) - <|> bounded'' dps bds - bounded' [] _ = error "bounded called with base 0" - bounded'' dps [] = [] <$ P.notFollowedBy (P.choice dps) <|> toomuch - bounded'' dps (bd : bds) = let anyd :: m Char - anyd = P.choice dps - - nomore :: m () - nomore = P.notFollowedBy anyd <|> toomuch - - (low, ex, high) = case splitAt bd dps of - (low', ex' : high') -> (low', ex', high') - (_, _) -> error "escapeCode: Logic error" - in ((:) <$> P.choice low <*> atMost (length bds) anyd) <* nomore - <|> ((:) <$> ex <*> ([] <$ nomore <|> bounded'' dps bds)) - <|> if not (null bds) - then (:) <$> P.choice high <*> atMost (length bds - 1) anyd <* nomore - else empty - atMost n p | n <= 0 = pure [] - | otherwise = ((:) <$> p <*> atMost (n - 1) p) <|> pure [] - - charEsc :: m Char - charEsc = P.choice $ parseEsc <$> escMap - - parseEsc (c,code) = code <$ P.char c - escMap = zip "abfnrtv\\\"\'" "\a\b\f\n\r\t\v\\\"\'" - - charAscii :: m Char - charAscii = P.choice $ parseAscii <$> asciiMap - - parseAscii (asc,code) = P.try $ code <$ P.string asc - asciiMap = zip (ascii3codes ++ ascii2codes) (ascii3 ++ ascii2) - ascii2codes, ascii3codes :: [String] - ascii2codes = [ "BS","HT","LF","VT","FF","CR","SO" - , "SI","EM","FS","GS","RS","US","SP"] - ascii3codes = ["NUL","SOH","STX","ETX","EOT","ENQ","ACK" - ,"BEL","DLE","DC1","DC2","DC3","DC4","NAK" - ,"SYN","ETB","CAN","SUB","ESC","DEL"] - ascii2, ascii3 :: String - ascii2 = "\BS\HT\LF\VT\FF\CR\SO\SI\EM\FS\GS\RS\US\SP" - ascii3 = "\NUL\SOH\STX\ETX\EOT\ENQ\ACK\BEL\DLE\DC1\DC2\DC3\DC4\NAK\SYN\ETB\CAN\SUB\ESC\DEL" diff --git a/src/Distribution/Parsec/Error.hs b/src/Distribution/Parsec/Error.hs deleted file mode 100644 --- a/src/Distribution/Parsec/Error.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Parsec.Error ( - PError (..), - showPError, - ) where - -import Distribution.Compat.Prelude -import Distribution.Parsec.Position -import Prelude () -import System.FilePath (normalise) - --- | Parser error. -data PError = PError Position String - deriving (Show, Generic) - -instance Binary PError -instance NFData PError where rnf = genericRnf - -showPError :: FilePath -> PError -> String -showPError fpath (PError pos msg) = - normalise fpath ++ ":" ++ showPos pos ++ ": " ++ msg diff --git a/src/Distribution/Parsec/FieldLineStream.hs b/src/Distribution/Parsec/FieldLineStream.hs deleted file mode 100644 --- a/src/Distribution/Parsec/FieldLineStream.hs +++ /dev/null @@ -1,91 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -Wall -Werror #-} -module Distribution.Parsec.FieldLineStream ( - FieldLineStream (..), - fieldLineStreamFromString, - fieldLineStreamFromBS, - fieldLineStreamEnd, - ) where - -import Data.Bits -import Data.ByteString (ByteString) -import Distribution.Compat.Prelude -import Distribution.Utils.Generic (toUTF8BS) -import Prelude () - -import qualified Data.ByteString as BS -import qualified Text.Parsec as Parsec - --- | This is essentially a lazy bytestring, but chunks are glued with newline @\'\\n\'@. -data FieldLineStream - = FLSLast !ByteString - | FLSCons {-# UNPACK #-} !ByteString FieldLineStream - deriving Show - -fieldLineStreamEnd :: FieldLineStream -fieldLineStreamEnd = FLSLast mempty - --- | Convert 'String' to 'FieldLineStream'. --- --- /Note:/ inefficient! -fieldLineStreamFromString :: String -> FieldLineStream -fieldLineStreamFromString = FLSLast . toUTF8BS - -fieldLineStreamFromBS :: ByteString -> FieldLineStream -fieldLineStreamFromBS = FLSLast - -instance Monad m => Parsec.Stream FieldLineStream m Char where - uncons (FLSLast bs) = return $ case BS.uncons bs of - Nothing -> Nothing - Just (c, bs') -> Just (unconsChar c bs' (\bs'' -> FLSLast bs'') fieldLineStreamEnd) - - uncons (FLSCons bs s) = return $ case BS.uncons bs of - -- as lines are glued with '\n', we return '\n' here! - Nothing -> Just ('\n', s) - Just (c, bs') -> Just (unconsChar c bs' (\bs'' -> FLSCons bs'' s) s) - --- Based on implementation 'decodeStringUtf8' -unconsChar :: forall a. Word8 -> ByteString -> (ByteString -> a) -> a -> (Char, a) -unconsChar c0 bs0 f next - | c0 <= 0x7F = (chr (fromIntegral c0), f bs0) - | c0 <= 0xBF = (replacementChar, f bs0) - | c0 <= 0xDF = twoBytes - | c0 <= 0xEF = moreBytes 3 0x800 bs0 (fromIntegral $ c0 .&. 0xF) - | c0 <= 0xF7 = moreBytes 4 0x10000 bs0 (fromIntegral $ c0 .&. 0x7) - | c0 <= 0xFB = moreBytes 5 0x200000 bs0 (fromIntegral $ c0 .&. 0x3) - | c0 <= 0xFD = moreBytes 6 0x4000000 bs0 (fromIntegral $ c0 .&. 0x1) - | otherwise = error $ "not implemented " ++ show c0 - where - twoBytes = case BS.uncons bs0 of - Nothing -> (replacementChar, next) - Just (c1, bs1) - | c1 .&. 0xC0 == 0x80 -> - if d >= 0x80 - then (chr d, f bs1) - else (replacementChar, f bs1) - | otherwise -> (replacementChar, f bs1) - where - d = (fromIntegral (c0 .&. 0x1F) `shiftL` 6) .|. fromIntegral (c1 .&. 0x3F) - - moreBytes :: Int -> Int -> ByteString -> Int -> (Char, a) - moreBytes 1 overlong bs' acc - | overlong <= acc, acc <= 0x10FFFF, acc < 0xD800 || 0xDFFF < acc - = (chr acc, f bs') - | otherwise - = (replacementChar, f bs') - - moreBytes byteCount overlong bs' acc = case BS.uncons bs' of - Nothing -> (replacementChar, f bs') - Just (cn, bs1) - | cn .&. 0xC0 == 0x80 -> moreBytes - (byteCount-1) - overlong - bs1 - ((acc `shiftL` 6) .|. fromIntegral cn .&. 0x3F) - | otherwise -> (replacementChar, f bs1) - -replacementChar :: Char -replacementChar = '\xfffd' diff --git a/src/Distribution/Parsec/Position.hs b/src/Distribution/Parsec/Position.hs deleted file mode 100644 --- a/src/Distribution/Parsec/Position.hs +++ /dev/null @@ -1,44 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Parsec.Position ( - Position (..), - incPos, - retPos, - showPos, - zeroPos, - positionCol, - positionRow, - ) where - -import Distribution.Compat.Prelude -import Prelude () - --- | 1-indexed row and column positions in a file. -data Position = Position - {-# UNPACK #-} !Int -- row - {-# UNPACK #-} !Int -- column - deriving (Eq, Ord, Show, Generic) - -instance Binary Position -instance NFData Position where rnf = genericRnf - --- | Shift position by n columns to the right. -incPos :: Int -> Position -> Position -incPos n (Position row col) = Position row (col + n) - --- | Shift position to beginning of next row. -retPos :: Position -> Position -retPos (Position row _col) = Position (row + 1) 1 - -showPos :: Position -> String -showPos (Position row col) = show row ++ ":" ++ show col - -zeroPos :: Position -zeroPos = Position 0 0 - --- | @since 3.0.0.0 -positionCol :: Position -> Int -positionCol (Position _ c) = c - --- | @since 3.0.0.0 -positionRow :: Position -> Int -positionRow (Position r _) = r diff --git a/src/Distribution/Parsec/Warning.hs b/src/Distribution/Parsec/Warning.hs deleted file mode 100644 --- a/src/Distribution/Parsec/Warning.hs +++ /dev/null @@ -1,61 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Parsec.Warning ( - PWarning (..), - PWarnType (..), - showPWarning, - ) where - -import Distribution.Compat.Prelude -import Distribution.Parsec.Position -import Prelude () -import System.FilePath (normalise) - --- | Type of parser warning. We do classify warnings. --- --- Different application may decide not to show some, or have fatal behaviour on others -data PWarnType - = PWTOther -- ^ Unclassified warning - | PWTUTF -- ^ Invalid UTF encoding - | PWTBoolCase -- ^ @true@ or @false@, not @True@ or @False@ - | PWTVersionTag -- ^ there are version with tags - | PWTNewSyntax -- ^ New syntax used, but no @cabal-version: >= 1.2@ specified - | PWTOldSyntax -- ^ Old syntax used, and @cabal-version >= 1.2@ specified - | PWTDeprecatedField - | PWTInvalidSubsection - | PWTUnknownField - | PWTUnknownSection - | PWTTrailingFields - | PWTExtraMainIs -- ^ extra main-is field - | PWTExtraTestModule -- ^ extra test-module field - | PWTExtraBenchmarkModule -- ^ extra benchmark-module field - | PWTLexNBSP - | PWTLexBOM - | PWTLexTab - | PWTQuirkyCabalFile -- ^ legacy cabal file that we know how to patch - | PWTDoubleDash -- ^ Double dash token, most likely it's a mistake - it's not a comment - | PWTMultipleSingularField -- ^ e.g. name or version should be specified only once. - | PWTBuildTypeDefault -- ^ Workaround for derive-package having build-type: Default. See . - - | PWTVersionOperator -- ^ Version operators used (without cabal-version: 1.8) - | PWTVersionWildcard -- ^ Version wildcard used (without cabal-version: 1.6) - - | PWTSpecVersion -- ^ Warnings about cabal-version format. - - | PWTEmptyFilePath -- ^ Empty filepath, i.e. literally "" - - | PWTExperimental -- ^ Experimental feature - deriving (Eq, Ord, Show, Enum, Bounded, Generic) - -instance Binary PWarnType -instance NFData PWarnType where rnf = genericRnf - --- | Parser warning. -data PWarning = PWarning !PWarnType !Position String - deriving (Show, Generic) - -instance Binary PWarning -instance NFData PWarning where rnf = genericRnf - -showPWarning :: FilePath -> PWarning -> String -showPWarning fpath (PWarning _ pos msg) = - normalise fpath ++ ":" ++ showPos pos ++ ": " ++ msg diff --git a/src/Distribution/Pretty.hs b/src/Distribution/Pretty.hs deleted file mode 100644 --- a/src/Distribution/Pretty.hs +++ /dev/null @@ -1,110 +0,0 @@ -module Distribution.Pretty ( - Pretty (..), - prettyShow, - defaultStyle, - flatStyle, - -- * Utilities - showFilePath, - showToken, - showTokenStr, - showFreeText, - showFreeTextV3, - -- * Deprecated - Separator, - ) where - -import Distribution.CabalSpecVersion -import Distribution.Compat.Prelude -import Prelude () - -import qualified Text.PrettyPrint as PP - -class Pretty a where - pretty :: a -> PP.Doc - - prettyVersioned :: CabalSpecVersion -> a -> PP.Doc - prettyVersioned _ = pretty - --- | @since 3.4.0.0 -instance Pretty PP.Doc where - pretty = id - -instance Pretty Bool where - pretty = PP.text . show - -instance Pretty Int where - pretty = PP.text . show - -instance Pretty a => Pretty (Identity a) where - pretty = pretty . runIdentity - -prettyShow :: Pretty a => a -> String -prettyShow = PP.renderStyle defaultStyle . pretty - --- | The default rendering style used in Cabal for console --- output. It has a fixed page width and adds line breaks --- automatically. -defaultStyle :: PP.Style -defaultStyle = PP.Style { PP.mode = PP.PageMode - , PP.lineLength = 79 - , PP.ribbonsPerLine = 1.0 - } - --- | A style for rendering all on one line. -flatStyle :: PP.Style -flatStyle = PP.Style { PP.mode = PP.LeftMode - , PP.lineLength = err "lineLength" - , PP.ribbonsPerLine = err "ribbonsPerLine" - } - where - err x = error ("flatStyle: tried to access " ++ x ++ " in LeftMode. " ++ - "This should never happen and indicates a bug in Cabal.") - -------------------------------------------------------------------------------- --- Utilities -------------------------------------------------------------------------------- - --- TODO: remove when ReadP parser is gone. -type Separator = [PP.Doc] -> PP.Doc - -showFilePath :: FilePath -> PP.Doc -showFilePath = showToken - -showToken :: String -> PP.Doc -showToken = PP.text . showTokenStr - -showTokenStr :: String -> String -showTokenStr str - -- if token looks like a comment (starts with --), print it in quotes - | "--" `isPrefixOf` str = show str - -- also if token ends with a colon (e.g. executable name), print it in quotes - | ":" `isSuffixOf` str = show str - | not (any dodgy str) && not (null str) = str - | otherwise = show str - where - dodgy c = isSpace c || c == ',' - - --- | Pretty-print free-format text, ensuring that it is vertically aligned, --- and with blank lines replaced by dots for correct re-parsing. -showFreeText :: String -> PP.Doc -showFreeText "" = mempty -showFreeText s = PP.vcat [ PP.text (if null l then "." else l) | l <- lines_ s ] - --- | Pretty-print free-format text. --- Since @cabal-version: 3.0@ we don't replace blank lines with dots. --- --- @since 3.0.0.0 -showFreeTextV3 :: String -> PP.Doc -showFreeTextV3 "" = mempty -showFreeTextV3 s = PP.vcat [ PP.text l | l <- lines_ s ] - --- | 'lines_' breaks a string up into a list of strings at newline --- characters. The resulting strings do not contain newlines. -lines_ :: String -> [String] -lines_ [] = [""] -lines_ s = - let (l, s') = break (== '\n') s - in l : case s' of - [] -> [] - (_:s'') -> lines_ s'' diff --git a/src/Distribution/ReadE.hs b/src/Distribution/ReadE.hs --- a/src/Distribution/ReadE.hs +++ b/src/Distribution/ReadE.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE LambdaCase #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.ReadE @@ -13,14 +14,17 @@ -- * ReadE ReadE(..), succeedReadE, failReadE, -- * Projections - readEOrFail, - parsecToReadE, + parsecToReadE, parsecToReadEErr, + -- * Parse Errors + unexpectMsgString, ) where import Distribution.Compat.Prelude import Prelude () +import qualified Data.Bifunctor as Bi (first) import Distribution.Parsec +import qualified Text.Parsec.Error as Parsec import Distribution.Parsec.FieldLineStream -- | Parser with simple error reporting @@ -38,12 +42,22 @@ failReadE :: ErrorMsg -> ReadE a failReadE = ReadE . const . Left -readEOrFail :: ReadE a -> String -> a -readEOrFail r = either error id . runReadE r +runParsecFromString :: ParsecParser a -> String -> Either Parsec.ParseError a +runParsecFromString p txt = + runParsecParser p "" (fieldLineStreamFromString txt) parsecToReadE :: (String -> ErrorMsg) -> ParsecParser a -> ReadE a parsecToReadE err p = ReadE $ \txt -> - case runParsecParser p "" (fieldLineStreamFromString txt) of - Right x -> Right x - Left _e -> Left (err txt) --- TODO: use parsec error to make 'ErrorMsg'. + (const $ err txt) `Bi.first` runParsecFromString p txt + +parsecToReadEErr :: (Parsec.ParseError -> ErrorMsg) -> ParsecParser a -> ReadE a +parsecToReadEErr err p = ReadE $ + Bi.first err . runParsecFromString p + +-- Show only unexpected error messages +unexpectMsgString :: Parsec.ParseError -> String +unexpectMsgString = unlines + . map Parsec.messageString + . filter (\case { Parsec.UnExpect _ -> True; _ -> False }) + . Parsec.errorMessages + diff --git a/src/Distribution/SPDX.hs b/src/Distribution/SPDX.hs deleted file mode 100644 --- a/src/Distribution/SPDX.hs +++ /dev/null @@ -1,40 +0,0 @@ --- | This module implements SPDX specification version 2.1 with a version 3.0 license list. --- --- Specification is available on -module Distribution.SPDX ( - -- * License - License (..), - -- * License expression - LicenseExpression (..), - SimpleLicenseExpression (..), - simpleLicenseExpression, - -- * License identifier - LicenseId (..), - licenseId, - licenseName, - licenseIsOsiApproved, - mkLicenseId, - licenseIdList, - -- * License exception - LicenseExceptionId (..), - licenseExceptionId, - licenseExceptionName, - mkLicenseExceptionId, - licenseExceptionIdList, - -- * License reference - LicenseRef, - licenseRef, - licenseDocumentRef, - mkLicenseRef, - mkLicenseRef', - -- * License list version - LicenseListVersion (..), - cabalSpecVersionToSPDXListVersion, - ) where - -import Distribution.SPDX.LicenseExceptionId -import Distribution.SPDX.License -import Distribution.SPDX.LicenseId -import Distribution.SPDX.LicenseExpression -import Distribution.SPDX.LicenseReference -import Distribution.SPDX.LicenseListVersion diff --git a/src/Distribution/SPDX/License.hs b/src/Distribution/SPDX/License.hs deleted file mode 100644 --- a/src/Distribution/SPDX/License.hs +++ /dev/null @@ -1,65 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -module Distribution.SPDX.License ( - License (..), - ) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Pretty -import Distribution.Parsec -import Distribution.SPDX.LicenseExpression - -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp - --- | Declared license. --- See [section 3.15 of SPDX Specification 2.1](https://spdx.org/spdx-specification-21-web-version#h.1hmsyys) --- --- /Note:/ the NOASSERTION case is omitted. --- --- Old 'License' can be migrated using following rules: --- --- * @AllRightsReserved@ and @UnspecifiedLicense@ to 'NONE'. --- No license specified which legally defaults to /All Rights Reserved/. --- The package may not be legally modified or redistributed by anyone but --- the rightsholder. --- --- * @OtherLicense@ can be converted to 'LicenseRef' pointing to the file --- in the package. --- --- * @UnknownLicense@ i.e. other licenses of the form @name-x.y@, should be --- covered by SPDX license list, otherwise use 'LicenseRef'. --- --- * @PublicDomain@ isn't covered. Consider using CC0. --- See --- for more information. --- -data License - = NONE - -- ^ if the package contains no license information whatsoever; or - | License LicenseExpression - -- ^ A valid SPDX License Expression as defined in Appendix IV. - deriving (Show, Read, Eq, Ord, Typeable, Data, Generic) - -instance Binary License -instance Structured License - -instance NFData License where - rnf NONE = () - rnf (License l) = rnf l - -instance Pretty License where - pretty NONE = Disp.text "NONE" - pretty (License l) = pretty l - --- | --- >>> eitherParsec "BSD-3-Clause AND MIT" :: Either String License --- Right (License (EAnd (ELicense (ELicenseId BSD_3_Clause) Nothing) (ELicense (ELicenseId MIT) Nothing))) --- --- >>> eitherParsec "NONE" :: Either String License --- Right NONE --- -instance Parsec License where - parsec = NONE <$ P.try (P.string "NONE") <|> License <$> parsec diff --git a/src/Distribution/SPDX/LicenseExceptionId.hs b/src/Distribution/SPDX/LicenseExceptionId.hs deleted file mode 100644 --- a/src/Distribution/SPDX/LicenseExceptionId.hs +++ /dev/null @@ -1,316 +0,0 @@ --- This file is generated. See Makefile's spdx rule -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -module Distribution.SPDX.LicenseExceptionId ( - LicenseExceptionId (..), - licenseExceptionId, - licenseExceptionName, - mkLicenseExceptionId, - licenseExceptionIdList, - ) where - -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Compat.Lens (set) -import Distribution.Pretty -import Distribution.Parsec -import Distribution.Utils.Generic (isAsciiAlphaNum) -import Distribution.Utils.Structured (Structured (..), nominalStructure, typeVersion) -import Distribution.SPDX.LicenseListVersion - -import qualified Data.Binary.Get as Binary -import qualified Data.Binary.Put as Binary -import qualified Data.Map.Strict as Map -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp - -------------------------------------------------------------------------------- --- LicenseExceptionId -------------------------------------------------------------------------------- - --- | SPDX License identifier -data LicenseExceptionId - = DS389_exception -- ^ @389-exception@, 389 Directory Server Exception - | Autoconf_exception_2_0 -- ^ @Autoconf-exception-2.0@, Autoconf exception 2.0 - | Autoconf_exception_3_0 -- ^ @Autoconf-exception-3.0@, Autoconf exception 3.0 - | Bison_exception_2_2 -- ^ @Bison-exception-2.2@, Bison exception 2.2 - | Bootloader_exception -- ^ @Bootloader-exception@, Bootloader Distribution Exception - | Classpath_exception_2_0 -- ^ @Classpath-exception-2.0@, Classpath exception 2.0 - | CLISP_exception_2_0 -- ^ @CLISP-exception-2.0@, CLISP exception 2.0 - | DigiRule_FOSS_exception -- ^ @DigiRule-FOSS-exception@, DigiRule FOSS License Exception - | ECos_exception_2_0 -- ^ @eCos-exception-2.0@, eCos exception 2.0 - | Fawkes_Runtime_exception -- ^ @Fawkes-Runtime-exception@, Fawkes Runtime Exception - | FLTK_exception -- ^ @FLTK-exception@, FLTK exception - | Font_exception_2_0 -- ^ @Font-exception-2.0@, Font exception 2.0 - | Freertos_exception_2_0 -- ^ @freertos-exception-2.0@, FreeRTOS Exception 2.0 - | GCC_exception_2_0 -- ^ @GCC-exception-2.0@, GCC Runtime Library exception 2.0 - | GCC_exception_3_1 -- ^ @GCC-exception-3.1@, GCC Runtime Library exception 3.1 - | Gnu_javamail_exception -- ^ @gnu-javamail-exception@, GNU JavaMail exception - | GPL_3_0_linking_exception -- ^ @GPL-3.0-linking-exception@, GPL-3.0 Linking Exception, SPDX License List 3.9, SPDX License List 3.10 - | GPL_3_0_linking_source_exception -- ^ @GPL-3.0-linking-source-exception@, GPL-3.0 Linking Exception (with Corresponding Source), SPDX License List 3.9, SPDX License List 3.10 - | GPL_CC_1_0 -- ^ @GPL-CC-1.0@, GPL Cooperation Commitment 1.0, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10 - | I2p_gpl_java_exception -- ^ @i2p-gpl-java-exception@, i2p GPL+Java Exception - | LGPL_3_0_linking_exception -- ^ @LGPL-3.0-linking-exception@, LGPL-3.0 Linking Exception, SPDX License List 3.9, SPDX License List 3.10 - | Libtool_exception -- ^ @Libtool-exception@, Libtool Exception - | Linux_syscall_note -- ^ @Linux-syscall-note@, Linux Syscall Note - | LLVM_exception -- ^ @LLVM-exception@, LLVM Exception, SPDX License List 3.2, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10 - | LZMA_exception -- ^ @LZMA-exception@, LZMA exception - | Mif_exception -- ^ @mif-exception@, Macros and Inline Functions Exception - | Nokia_Qt_exception_1_1 -- ^ @Nokia-Qt-exception-1.1@, Nokia Qt LGPL exception 1.1, SPDX License List 3.0, SPDX License List 3.2 - | OCaml_LGPL_linking_exception -- ^ @OCaml-LGPL-linking-exception@, OCaml LGPL Linking Exception, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10 - | OCCT_exception_1_0 -- ^ @OCCT-exception-1.0@, Open CASCADE Exception 1.0 - | OpenJDK_assembly_exception_1_0 -- ^ @OpenJDK-assembly-exception-1.0@, OpenJDK Assembly exception 1.0, SPDX License List 3.2, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10 - | Openvpn_openssl_exception -- ^ @openvpn-openssl-exception@, OpenVPN OpenSSL Exception - | PS_or_PDF_font_exception_20170817 -- ^ @PS-or-PDF-font-exception-20170817@, PS/PDF font exception (2017-08-17), SPDX License List 3.2, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10 - | Qt_GPL_exception_1_0 -- ^ @Qt-GPL-exception-1.0@, Qt GPL exception 1.0, SPDX License List 3.2, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10 - | Qt_LGPL_exception_1_1 -- ^ @Qt-LGPL-exception-1.1@, Qt LGPL exception 1.1, SPDX License List 3.2, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10 - | Qwt_exception_1_0 -- ^ @Qwt-exception-1.0@, Qwt exception 1.0 - | SHL_2_0 -- ^ @SHL-2.0@, Solderpad Hardware License v2.0, SPDX License List 3.9, SPDX License List 3.10 - | SHL_2_1 -- ^ @SHL-2.1@, Solderpad Hardware License v2.1, SPDX License List 3.9, SPDX License List 3.10 - | Swift_exception -- ^ @Swift-exception@, Swift Exception, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10 - | U_boot_exception_2_0 -- ^ @u-boot-exception-2.0@, U-Boot exception 2.0 - | Universal_FOSS_exception_1_0 -- ^ @Universal-FOSS-exception-1.0@, Universal FOSS Exception, Version 1.0, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10 - | WxWindows_exception_3_1 -- ^ @WxWindows-exception-3.1@, WxWindows Library Exception 3.1 - deriving (Eq, Ord, Enum, Bounded, Show, Read, Typeable, Data, Generic) - -instance Binary LicenseExceptionId where - put = Binary.putWord8 . fromIntegral . fromEnum - get = do - i <- Binary.getWord8 - if i > fromIntegral (fromEnum (maxBound :: LicenseExceptionId)) - then fail "Too large LicenseExceptionId tag" - else return (toEnum (fromIntegral i)) - --- note: remember to bump version each time the definition changes -instance Structured LicenseExceptionId where - structure p = set typeVersion 306 $ nominalStructure p - -instance Pretty LicenseExceptionId where - pretty = Disp.text . licenseExceptionId - -instance Parsec LicenseExceptionId where - parsec = do - n <- some $ P.satisfy $ \c -> isAsciiAlphaNum c || c == '-' || c == '.' - v <- askCabalSpecVersion - maybe (fail $ "Unknown SPDX license exception identifier: " ++ n) return $ - mkLicenseExceptionId (cabalSpecVersionToSPDXListVersion v) n - -instance NFData LicenseExceptionId where - rnf l = l `seq` () - -------------------------------------------------------------------------------- --- License Data -------------------------------------------------------------------------------- - --- | License SPDX identifier, e.g. @"BSD-3-Clause"@. -licenseExceptionId :: LicenseExceptionId -> String -licenseExceptionId DS389_exception = "389-exception" -licenseExceptionId Autoconf_exception_2_0 = "Autoconf-exception-2.0" -licenseExceptionId Autoconf_exception_3_0 = "Autoconf-exception-3.0" -licenseExceptionId Bison_exception_2_2 = "Bison-exception-2.2" -licenseExceptionId Bootloader_exception = "Bootloader-exception" -licenseExceptionId Classpath_exception_2_0 = "Classpath-exception-2.0" -licenseExceptionId CLISP_exception_2_0 = "CLISP-exception-2.0" -licenseExceptionId DigiRule_FOSS_exception = "DigiRule-FOSS-exception" -licenseExceptionId ECos_exception_2_0 = "eCos-exception-2.0" -licenseExceptionId Fawkes_Runtime_exception = "Fawkes-Runtime-exception" -licenseExceptionId FLTK_exception = "FLTK-exception" -licenseExceptionId Font_exception_2_0 = "Font-exception-2.0" -licenseExceptionId Freertos_exception_2_0 = "freertos-exception-2.0" -licenseExceptionId GCC_exception_2_0 = "GCC-exception-2.0" -licenseExceptionId GCC_exception_3_1 = "GCC-exception-3.1" -licenseExceptionId Gnu_javamail_exception = "gnu-javamail-exception" -licenseExceptionId GPL_3_0_linking_exception = "GPL-3.0-linking-exception" -licenseExceptionId GPL_3_0_linking_source_exception = "GPL-3.0-linking-source-exception" -licenseExceptionId GPL_CC_1_0 = "GPL-CC-1.0" -licenseExceptionId I2p_gpl_java_exception = "i2p-gpl-java-exception" -licenseExceptionId LGPL_3_0_linking_exception = "LGPL-3.0-linking-exception" -licenseExceptionId Libtool_exception = "Libtool-exception" -licenseExceptionId Linux_syscall_note = "Linux-syscall-note" -licenseExceptionId LLVM_exception = "LLVM-exception" -licenseExceptionId LZMA_exception = "LZMA-exception" -licenseExceptionId Mif_exception = "mif-exception" -licenseExceptionId Nokia_Qt_exception_1_1 = "Nokia-Qt-exception-1.1" -licenseExceptionId OCaml_LGPL_linking_exception = "OCaml-LGPL-linking-exception" -licenseExceptionId OCCT_exception_1_0 = "OCCT-exception-1.0" -licenseExceptionId OpenJDK_assembly_exception_1_0 = "OpenJDK-assembly-exception-1.0" -licenseExceptionId Openvpn_openssl_exception = "openvpn-openssl-exception" -licenseExceptionId PS_or_PDF_font_exception_20170817 = "PS-or-PDF-font-exception-20170817" -licenseExceptionId Qt_GPL_exception_1_0 = "Qt-GPL-exception-1.0" -licenseExceptionId Qt_LGPL_exception_1_1 = "Qt-LGPL-exception-1.1" -licenseExceptionId Qwt_exception_1_0 = "Qwt-exception-1.0" -licenseExceptionId SHL_2_0 = "SHL-2.0" -licenseExceptionId SHL_2_1 = "SHL-2.1" -licenseExceptionId Swift_exception = "Swift-exception" -licenseExceptionId U_boot_exception_2_0 = "u-boot-exception-2.0" -licenseExceptionId Universal_FOSS_exception_1_0 = "Universal-FOSS-exception-1.0" -licenseExceptionId WxWindows_exception_3_1 = "WxWindows-exception-3.1" - --- | License name, e.g. @"GNU General Public License v2.0 only"@ -licenseExceptionName :: LicenseExceptionId -> String -licenseExceptionName DS389_exception = "389 Directory Server Exception" -licenseExceptionName Autoconf_exception_2_0 = "Autoconf exception 2.0" -licenseExceptionName Autoconf_exception_3_0 = "Autoconf exception 3.0" -licenseExceptionName Bison_exception_2_2 = "Bison exception 2.2" -licenseExceptionName Bootloader_exception = "Bootloader Distribution Exception" -licenseExceptionName Classpath_exception_2_0 = "Classpath exception 2.0" -licenseExceptionName CLISP_exception_2_0 = "CLISP exception 2.0" -licenseExceptionName DigiRule_FOSS_exception = "DigiRule FOSS License Exception" -licenseExceptionName ECos_exception_2_0 = "eCos exception 2.0" -licenseExceptionName Fawkes_Runtime_exception = "Fawkes Runtime Exception" -licenseExceptionName FLTK_exception = "FLTK exception" -licenseExceptionName Font_exception_2_0 = "Font exception 2.0" -licenseExceptionName Freertos_exception_2_0 = "FreeRTOS Exception 2.0" -licenseExceptionName GCC_exception_2_0 = "GCC Runtime Library exception 2.0" -licenseExceptionName GCC_exception_3_1 = "GCC Runtime Library exception 3.1" -licenseExceptionName Gnu_javamail_exception = "GNU JavaMail exception" -licenseExceptionName GPL_3_0_linking_exception = "GPL-3.0 Linking Exception" -licenseExceptionName GPL_3_0_linking_source_exception = "GPL-3.0 Linking Exception (with Corresponding Source)" -licenseExceptionName GPL_CC_1_0 = "GPL Cooperation Commitment 1.0" -licenseExceptionName I2p_gpl_java_exception = "i2p GPL+Java Exception" -licenseExceptionName LGPL_3_0_linking_exception = "LGPL-3.0 Linking Exception" -licenseExceptionName Libtool_exception = "Libtool Exception" -licenseExceptionName Linux_syscall_note = "Linux Syscall Note" -licenseExceptionName LLVM_exception = "LLVM Exception" -licenseExceptionName LZMA_exception = "LZMA exception" -licenseExceptionName Mif_exception = "Macros and Inline Functions Exception" -licenseExceptionName Nokia_Qt_exception_1_1 = "Nokia Qt LGPL exception 1.1" -licenseExceptionName OCaml_LGPL_linking_exception = "OCaml LGPL Linking Exception" -licenseExceptionName OCCT_exception_1_0 = "Open CASCADE Exception 1.0" -licenseExceptionName OpenJDK_assembly_exception_1_0 = "OpenJDK Assembly exception 1.0" -licenseExceptionName Openvpn_openssl_exception = "OpenVPN OpenSSL Exception" -licenseExceptionName PS_or_PDF_font_exception_20170817 = "PS/PDF font exception (2017-08-17)" -licenseExceptionName Qt_GPL_exception_1_0 = "Qt GPL exception 1.0" -licenseExceptionName Qt_LGPL_exception_1_1 = "Qt LGPL exception 1.1" -licenseExceptionName Qwt_exception_1_0 = "Qwt exception 1.0" -licenseExceptionName SHL_2_0 = "Solderpad Hardware License v2.0" -licenseExceptionName SHL_2_1 = "Solderpad Hardware License v2.1" -licenseExceptionName Swift_exception = "Swift Exception" -licenseExceptionName U_boot_exception_2_0 = "U-Boot exception 2.0" -licenseExceptionName Universal_FOSS_exception_1_0 = "Universal FOSS Exception, Version 1.0" -licenseExceptionName WxWindows_exception_3_1 = "WxWindows Library Exception 3.1" - -------------------------------------------------------------------------------- --- Creation -------------------------------------------------------------------------------- - -licenseExceptionIdList :: LicenseListVersion -> [LicenseExceptionId] -licenseExceptionIdList LicenseListVersion_3_0 = - [ Nokia_Qt_exception_1_1 - ] - ++ bulkOfLicenses -licenseExceptionIdList LicenseListVersion_3_2 = - [ LLVM_exception - , Nokia_Qt_exception_1_1 - , OpenJDK_assembly_exception_1_0 - , PS_or_PDF_font_exception_20170817 - , Qt_GPL_exception_1_0 - , Qt_LGPL_exception_1_1 - ] - ++ bulkOfLicenses -licenseExceptionIdList LicenseListVersion_3_6 = - [ GPL_CC_1_0 - , LLVM_exception - , OCaml_LGPL_linking_exception - , OpenJDK_assembly_exception_1_0 - , PS_or_PDF_font_exception_20170817 - , Qt_GPL_exception_1_0 - , Qt_LGPL_exception_1_1 - , Swift_exception - , Universal_FOSS_exception_1_0 - ] - ++ bulkOfLicenses -licenseExceptionIdList LicenseListVersion_3_9 = - [ GPL_3_0_linking_exception - , GPL_3_0_linking_source_exception - , GPL_CC_1_0 - , LGPL_3_0_linking_exception - , LLVM_exception - , OCaml_LGPL_linking_exception - , OpenJDK_assembly_exception_1_0 - , PS_or_PDF_font_exception_20170817 - , Qt_GPL_exception_1_0 - , Qt_LGPL_exception_1_1 - , SHL_2_0 - , SHL_2_1 - , Swift_exception - , Universal_FOSS_exception_1_0 - ] - ++ bulkOfLicenses -licenseExceptionIdList LicenseListVersion_3_10 = - [ GPL_3_0_linking_exception - , GPL_3_0_linking_source_exception - , GPL_CC_1_0 - , LGPL_3_0_linking_exception - , LLVM_exception - , OCaml_LGPL_linking_exception - , OpenJDK_assembly_exception_1_0 - , PS_or_PDF_font_exception_20170817 - , Qt_GPL_exception_1_0 - , Qt_LGPL_exception_1_1 - , SHL_2_0 - , SHL_2_1 - , Swift_exception - , Universal_FOSS_exception_1_0 - ] - ++ bulkOfLicenses - --- | Create a 'LicenseExceptionId' from a 'String'. -mkLicenseExceptionId :: LicenseListVersion -> String -> Maybe LicenseExceptionId -mkLicenseExceptionId LicenseListVersion_3_0 s = Map.lookup s stringLookup_3_0 -mkLicenseExceptionId LicenseListVersion_3_2 s = Map.lookup s stringLookup_3_2 -mkLicenseExceptionId LicenseListVersion_3_6 s = Map.lookup s stringLookup_3_6 -mkLicenseExceptionId LicenseListVersion_3_9 s = Map.lookup s stringLookup_3_9 -mkLicenseExceptionId LicenseListVersion_3_10 s = Map.lookup s stringLookup_3_10 - -stringLookup_3_0 :: Map String LicenseExceptionId -stringLookup_3_0 = Map.fromList $ map (\i -> (licenseExceptionId i, i)) $ - licenseExceptionIdList LicenseListVersion_3_0 - -stringLookup_3_2 :: Map String LicenseExceptionId -stringLookup_3_2 = Map.fromList $ map (\i -> (licenseExceptionId i, i)) $ - licenseExceptionIdList LicenseListVersion_3_2 - -stringLookup_3_6 :: Map String LicenseExceptionId -stringLookup_3_6 = Map.fromList $ map (\i -> (licenseExceptionId i, i)) $ - licenseExceptionIdList LicenseListVersion_3_6 - -stringLookup_3_9 :: Map String LicenseExceptionId -stringLookup_3_9 = Map.fromList $ map (\i -> (licenseExceptionId i, i)) $ - licenseExceptionIdList LicenseListVersion_3_9 - -stringLookup_3_10 :: Map String LicenseExceptionId -stringLookup_3_10 = Map.fromList $ map (\i -> (licenseExceptionId i, i)) $ - licenseExceptionIdList LicenseListVersion_3_10 - --- | License exceptions in all SPDX License lists -bulkOfLicenses :: [LicenseExceptionId] -bulkOfLicenses = - [ DS389_exception - , Autoconf_exception_2_0 - , Autoconf_exception_3_0 - , Bison_exception_2_2 - , Bootloader_exception - , Classpath_exception_2_0 - , CLISP_exception_2_0 - , DigiRule_FOSS_exception - , ECos_exception_2_0 - , Fawkes_Runtime_exception - , FLTK_exception - , Font_exception_2_0 - , Freertos_exception_2_0 - , GCC_exception_2_0 - , GCC_exception_3_1 - , Gnu_javamail_exception - , I2p_gpl_java_exception - , Libtool_exception - , Linux_syscall_note - , LZMA_exception - , Mif_exception - , OCCT_exception_1_0 - , Openvpn_openssl_exception - , Qwt_exception_1_0 - , U_boot_exception_2_0 - , WxWindows_exception_3_1 - ] diff --git a/src/Distribution/SPDX/LicenseExpression.hs b/src/Distribution/SPDX/LicenseExpression.hs deleted file mode 100644 --- a/src/Distribution/SPDX/LicenseExpression.hs +++ /dev/null @@ -1,162 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -module Distribution.SPDX.LicenseExpression ( - LicenseExpression (..), - SimpleLicenseExpression (..), - simpleLicenseExpression, - ) where - -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Parsec -import Distribution.Pretty -import Distribution.SPDX.LicenseExceptionId -import Distribution.SPDX.LicenseId -import Distribution.SPDX.LicenseListVersion -import Distribution.SPDX.LicenseReference -import Distribution.Utils.Generic (isAsciiAlphaNum) - -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp - --- | SPDX License Expression. --- --- @ --- idstring = 1*(ALPHA \/ DIGIT \/ "-" \/ "." ) --- license id = \ --- license exception id = \ --- license ref = [\"DocumentRef-"1*(idstring)":"]\"LicenseRef-"1*(idstring) --- --- simple expression = license id \/ license id"+" \/ license ref --- --- compound expression = 1*1(simple expression \/ --- simple expression \"WITH" license exception id \/ --- compound expression \"AND" compound expression \/ --- compound expression \"OR" compound expression ) \/ --- "(" compound expression ")" ) --- --- license expression = 1*1(simple expression / compound expression) --- @ -data LicenseExpression - = ELicense !SimpleLicenseExpression !(Maybe LicenseExceptionId) - | EAnd !LicenseExpression !LicenseExpression - | EOr !LicenseExpression !LicenseExpression - deriving (Show, Read, Eq, Ord, Typeable, Data, Generic) - --- | Simple License Expressions. -data SimpleLicenseExpression - = ELicenseId LicenseId - -- ^ An SPDX License List Short Form Identifier. For example: @GPL-2.0-only@ - | ELicenseIdPlus LicenseId - -- ^ An SPDX License List Short Form Identifier with a unary"+" operator suffix to represent the current version of the license or any later version. For example: @GPL-2.0+@ - | ELicenseRef LicenseRef - -- ^ A SPDX user defined license reference: For example: @LicenseRef-23@, @LicenseRef-MIT-Style-1@, or @DocumentRef-spdx-tool-1.2:LicenseRef-MIT-Style-2@ - deriving (Show, Read, Eq, Ord, Typeable, Data, Generic) - -simpleLicenseExpression :: LicenseId -> LicenseExpression -simpleLicenseExpression i = ELicense (ELicenseId i) Nothing - -instance Binary LicenseExpression -instance Binary SimpleLicenseExpression -instance Structured SimpleLicenseExpression -instance Structured LicenseExpression - -instance Pretty LicenseExpression where - pretty = go 0 - where - go :: Int -> LicenseExpression -> Disp.Doc - go _ (ELicense lic exc) = - let doc = pretty lic - in maybe id (\e d -> d <+> Disp.text "WITH" <+> pretty e) exc doc - go d (EAnd e1 e2) = parens (d < 0) $ go 0 e1 <+> Disp.text "AND" <+> go 0 e2 - go d (EOr e1 e2) = parens (d < 1) $ go 1 e1 <+> Disp.text "OR" <+> go 1 e2 - - - parens False doc = doc - parens True doc = Disp.parens doc - -instance Pretty SimpleLicenseExpression where - pretty (ELicenseId i) = pretty i - pretty (ELicenseIdPlus i) = pretty i <<>> Disp.char '+' - pretty (ELicenseRef r) = pretty r - -instance Parsec SimpleLicenseExpression where - parsec = idstring >>= simple where - simple n - | Just l <- "LicenseRef-" `isPrefixOfMaybe` n = - maybe (fail $ "Incorrect LicenseRef format: " ++ n) (return . ELicenseRef) $ mkLicenseRef Nothing l - | Just d <- "DocumentRef-" `isPrefixOfMaybe` n = do - _ <- P.string ":LicenseRef-" - l <- idstring - maybe (fail $ "Incorrect LicenseRef format:" ++ n) (return . ELicenseRef) $ mkLicenseRef (Just d) l - | otherwise = do - v <- askCabalSpecVersion - l <- maybe (fail $ "Unknown SPDX license identifier: '" ++ n ++ "' " ++ licenseIdMigrationMessage n) return $ - mkLicenseId (cabalSpecVersionToSPDXListVersion v) n - orLater <- isJust <$> P.optional (P.char '+') - if orLater - then return (ELicenseIdPlus l) - else return (ELicenseId l) - -idstring :: P.CharParsing m => m String -idstring = P.munch1 $ \c -> isAsciiAlphaNum c || c == '-' || c == '.' - --- returns suffix part -isPrefixOfMaybe :: Eq a => [a] -> [a] -> Maybe [a] -isPrefixOfMaybe pfx s - | pfx `isPrefixOf` s = Just (drop (length pfx) s) - | otherwise = Nothing - -instance Parsec LicenseExpression where - parsec = expr - where - expr = compoundOr - - simple = do - s <- parsec - exc <- exception - return $ ELicense s exc - - exception = P.optional $ P.try (spaces1 *> P.string "WITH" *> spaces1) *> parsec - - compoundOr = do - x <- compoundAnd - l <- P.optional $ P.try (spaces1 *> P.string "OR" *> spaces1) *> compoundOr - return $ maybe id (flip EOr) l x - - compoundAnd = do - x <- compound - l <- P.optional $ P.try (spaces1 *> P.string "AND" *> spaces1) *> compoundAnd - return $ maybe id (flip EAnd) l x - - compound = braces <|> simple - - -- NOTE: we require that there's a space around AND & OR operators, - -- i.e. @(MIT)AND(MIT)@ will cause parse-error. - braces = do - _ <- P.char '(' - _ <- P.spaces - x <- expr - _ <- P.char ')' - return x - - spaces1 = P.space *> P.spaces - --- notes: --- --- There MUST NOT be whitespace between a license­id and any following "+".  This supports easy parsing and --- backwards compatibility.  There MUST be whitespace on either side of the operator "WITH".  There MUST be --- whitespace and/or parentheses on either side of the operators "AND" and "OR". --- --- We handle that by having greedy 'idstring' parser, so MITAND would parse as invalid license identifier. - -instance NFData LicenseExpression where - rnf (ELicense s e) = rnf s `seq` rnf e - rnf (EAnd x y) = rnf x `seq` rnf y - rnf (EOr x y) = rnf x `seq` rnf y - -instance NFData SimpleLicenseExpression where - rnf (ELicenseId i) = rnf i - rnf (ELicenseIdPlus i) = rnf i - rnf (ELicenseRef r) = rnf r diff --git a/src/Distribution/SPDX/LicenseId.hs b/src/Distribution/SPDX/LicenseId.hs deleted file mode 100644 --- a/src/Distribution/SPDX/LicenseId.hs +++ /dev/null @@ -1,2152 +0,0 @@ --- This file is generated. See Makefile's spdx rule -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -module Distribution.SPDX.LicenseId ( - LicenseId (..), - licenseId, - licenseName, - licenseIsOsiApproved, - licenseIsFsfLibre, - mkLicenseId, - licenseIdList, - -- * Helpers - licenseIdMigrationMessage, - ) where - -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Compat.Lens (set) -import Distribution.Pretty -import Distribution.Parsec -import Distribution.Utils.Generic (isAsciiAlphaNum) -import Distribution.Utils.Structured (Structured (..), nominalStructure, typeVersion) -import Distribution.SPDX.LicenseListVersion - -import qualified Data.Binary.Get as Binary -import qualified Data.Binary.Put as Binary -import qualified Data.Map.Strict as Map -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp - -------------------------------------------------------------------------------- --- LicenseId -------------------------------------------------------------------------------- - --- | SPDX License identifier -data LicenseId - = NullBSD -- ^ @0BSD@, BSD Zero Clause License - | AAL -- ^ @AAL@, Attribution Assurance License - | Abstyles -- ^ @Abstyles@, Abstyles License - | Adobe_2006 -- ^ @Adobe-2006@, Adobe Systems Incorporated Source Code License Agreement - | Adobe_Glyph -- ^ @Adobe-Glyph@, Adobe Glyph List License - | ADSL -- ^ @ADSL@, Amazon Digital Services License - | AFL_1_1 -- ^ @AFL-1.1@, Academic Free License v1.1 - | AFL_1_2 -- ^ @AFL-1.2@, Academic Free License v1.2 - | AFL_2_0 -- ^ @AFL-2.0@, Academic Free License v2.0 - | AFL_2_1 -- ^ @AFL-2.1@, Academic Free License v2.1 - | AFL_3_0 -- ^ @AFL-3.0@, Academic Free License v3.0 - | Afmparse -- ^ @Afmparse@, Afmparse License - | AGPL_1_0 -- ^ @AGPL-1.0@, Affero General Public License v1.0, SPDX License List 3.0 - | AGPL_1_0_only -- ^ @AGPL-1.0-only@, Affero General Public License v1.0 only, SPDX License List 3.2, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10 - | AGPL_1_0_or_later -- ^ @AGPL-1.0-or-later@, Affero General Public License v1.0 or later, SPDX License List 3.2, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10 - | AGPL_3_0_only -- ^ @AGPL-3.0-only@, GNU Affero General Public License v3.0 only - | AGPL_3_0_or_later -- ^ @AGPL-3.0-or-later@, GNU Affero General Public License v3.0 or later - | Aladdin -- ^ @Aladdin@, Aladdin Free Public License - | AMDPLPA -- ^ @AMDPLPA@, AMD's plpa_map.c License - | AML -- ^ @AML@, Apple MIT License - | AMPAS -- ^ @AMPAS@, Academy of Motion Picture Arts and Sciences BSD - | ANTLR_PD -- ^ @ANTLR-PD@, ANTLR Software Rights Notice - | Apache_1_0 -- ^ @Apache-1.0@, Apache License 1.0 - | Apache_1_1 -- ^ @Apache-1.1@, Apache License 1.1 - | Apache_2_0 -- ^ @Apache-2.0@, Apache License 2.0 - | APAFML -- ^ @APAFML@, Adobe Postscript AFM License - | APL_1_0 -- ^ @APL-1.0@, Adaptive Public License 1.0 - | APSL_1_0 -- ^ @APSL-1.0@, Apple Public Source License 1.0 - | APSL_1_1 -- ^ @APSL-1.1@, Apple Public Source License 1.1 - | APSL_1_2 -- ^ @APSL-1.2@, Apple Public Source License 1.2 - | APSL_2_0 -- ^ @APSL-2.0@, Apple Public Source License 2.0 - | Artistic_1_0_cl8 -- ^ @Artistic-1.0-cl8@, Artistic License 1.0 w/clause 8 - | Artistic_1_0_Perl -- ^ @Artistic-1.0-Perl@, Artistic License 1.0 (Perl) - | Artistic_1_0 -- ^ @Artistic-1.0@, Artistic License 1.0 - | Artistic_2_0 -- ^ @Artistic-2.0@, Artistic License 2.0 - | Bahyph -- ^ @Bahyph@, Bahyph License - | Barr -- ^ @Barr@, Barr License - | Beerware -- ^ @Beerware@, Beerware License - | BitTorrent_1_0 -- ^ @BitTorrent-1.0@, BitTorrent Open Source License v1.0 - | BitTorrent_1_1 -- ^ @BitTorrent-1.1@, BitTorrent Open Source License v1.1 - | Blessing -- ^ @blessing@, SQLite Blessing, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10 - | BlueOak_1_0_0 -- ^ @BlueOak-1.0.0@, Blue Oak Model License 1.0.0, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10 - | Borceux -- ^ @Borceux@, Borceux license - | BSD_1_Clause -- ^ @BSD-1-Clause@, BSD 1-Clause License - | BSD_2_Clause_FreeBSD -- ^ @BSD-2-Clause-FreeBSD@, BSD 2-Clause FreeBSD License, SPDX License List 3.0, SPDX License List 3.2, SPDX License List 3.6, SPDX License List 3.9 - | BSD_2_Clause_NetBSD -- ^ @BSD-2-Clause-NetBSD@, BSD 2-Clause NetBSD License, SPDX License List 3.0, SPDX License List 3.2, SPDX License List 3.6 - | BSD_2_Clause_Patent -- ^ @BSD-2-Clause-Patent@, BSD-2-Clause Plus Patent License - | BSD_2_Clause_Views -- ^ @BSD-2-Clause-Views@, BSD 2-Clause with views sentence, SPDX License List 3.10 - | BSD_2_Clause -- ^ @BSD-2-Clause@, BSD 2-Clause "Simplified" License - | BSD_3_Clause_Attribution -- ^ @BSD-3-Clause-Attribution@, BSD with attribution - | BSD_3_Clause_Clear -- ^ @BSD-3-Clause-Clear@, BSD 3-Clause Clear License - | BSD_3_Clause_LBNL -- ^ @BSD-3-Clause-LBNL@, Lawrence Berkeley National Labs BSD variant license - | BSD_3_Clause_No_Nuclear_License_2014 -- ^ @BSD-3-Clause-No-Nuclear-License-2014@, BSD 3-Clause No Nuclear License 2014 - | BSD_3_Clause_No_Nuclear_License -- ^ @BSD-3-Clause-No-Nuclear-License@, BSD 3-Clause No Nuclear License - | BSD_3_Clause_No_Nuclear_Warranty -- ^ @BSD-3-Clause-No-Nuclear-Warranty@, BSD 3-Clause No Nuclear Warranty - | BSD_3_Clause_Open_MPI -- ^ @BSD-3-Clause-Open-MPI@, BSD 3-Clause Open MPI variant, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10 - | BSD_3_Clause -- ^ @BSD-3-Clause@, BSD 3-Clause "New" or "Revised" License - | BSD_4_Clause_UC -- ^ @BSD-4-Clause-UC@, BSD-4-Clause (University of California-Specific) - | BSD_4_Clause -- ^ @BSD-4-Clause@, BSD 4-Clause "Original" or "Old" License - | BSD_Protection -- ^ @BSD-Protection@, BSD Protection License - | BSD_Source_Code -- ^ @BSD-Source-Code@, BSD Source Code Attribution - | BSL_1_0 -- ^ @BSL-1.0@, Boost Software License 1.0 - | Bzip2_1_0_5 -- ^ @bzip2-1.0.5@, bzip2 and libbzip2 License v1.0.5 - | Bzip2_1_0_6 -- ^ @bzip2-1.0.6@, bzip2 and libbzip2 License v1.0.6 - | CAL_1_0_Combined_Work_Exception -- ^ @CAL-1.0-Combined-Work-Exception@, Cryptographic Autonomy License 1.0 (Combined Work Exception), SPDX License List 3.9, SPDX License List 3.10 - | CAL_1_0 -- ^ @CAL-1.0@, Cryptographic Autonomy License 1.0, SPDX License List 3.9, SPDX License List 3.10 - | Caldera -- ^ @Caldera@, Caldera License - | CATOSL_1_1 -- ^ @CATOSL-1.1@, Computer Associates Trusted Open Source License 1.1 - | CC_BY_1_0 -- ^ @CC-BY-1.0@, Creative Commons Attribution 1.0 Generic - | CC_BY_2_0 -- ^ @CC-BY-2.0@, Creative Commons Attribution 2.0 Generic - | CC_BY_2_5 -- ^ @CC-BY-2.5@, Creative Commons Attribution 2.5 Generic - | CC_BY_3_0_AT -- ^ @CC-BY-3.0-AT@, Creative Commons Attribution 3.0 Austria, SPDX License List 3.10 - | CC_BY_3_0 -- ^ @CC-BY-3.0@, Creative Commons Attribution 3.0 Unported - | CC_BY_4_0 -- ^ @CC-BY-4.0@, Creative Commons Attribution 4.0 International - | CC_BY_NC_1_0 -- ^ @CC-BY-NC-1.0@, Creative Commons Attribution Non Commercial 1.0 Generic - | CC_BY_NC_2_0 -- ^ @CC-BY-NC-2.0@, Creative Commons Attribution Non Commercial 2.0 Generic - | CC_BY_NC_2_5 -- ^ @CC-BY-NC-2.5@, Creative Commons Attribution Non Commercial 2.5 Generic - | CC_BY_NC_3_0 -- ^ @CC-BY-NC-3.0@, Creative Commons Attribution Non Commercial 3.0 Unported - | CC_BY_NC_4_0 -- ^ @CC-BY-NC-4.0@, Creative Commons Attribution Non Commercial 4.0 International - | CC_BY_NC_ND_1_0 -- ^ @CC-BY-NC-ND-1.0@, Creative Commons Attribution Non Commercial No Derivatives 1.0 Generic - | CC_BY_NC_ND_2_0 -- ^ @CC-BY-NC-ND-2.0@, Creative Commons Attribution Non Commercial No Derivatives 2.0 Generic - | CC_BY_NC_ND_2_5 -- ^ @CC-BY-NC-ND-2.5@, Creative Commons Attribution Non Commercial No Derivatives 2.5 Generic - | CC_BY_NC_ND_3_0_IGO -- ^ @CC-BY-NC-ND-3.0-IGO@, Creative Commons Attribution Non Commercial No Derivatives 3.0 IGO, SPDX License List 3.10 - | CC_BY_NC_ND_3_0 -- ^ @CC-BY-NC-ND-3.0@, Creative Commons Attribution Non Commercial No Derivatives 3.0 Unported - | CC_BY_NC_ND_4_0 -- ^ @CC-BY-NC-ND-4.0@, Creative Commons Attribution Non Commercial No Derivatives 4.0 International - | CC_BY_NC_SA_1_0 -- ^ @CC-BY-NC-SA-1.0@, Creative Commons Attribution Non Commercial Share Alike 1.0 Generic - | CC_BY_NC_SA_2_0 -- ^ @CC-BY-NC-SA-2.0@, Creative Commons Attribution Non Commercial Share Alike 2.0 Generic - | CC_BY_NC_SA_2_5 -- ^ @CC-BY-NC-SA-2.5@, Creative Commons Attribution Non Commercial Share Alike 2.5 Generic - | CC_BY_NC_SA_3_0 -- ^ @CC-BY-NC-SA-3.0@, Creative Commons Attribution Non Commercial Share Alike 3.0 Unported - | CC_BY_NC_SA_4_0 -- ^ @CC-BY-NC-SA-4.0@, Creative Commons Attribution Non Commercial Share Alike 4.0 International - | CC_BY_ND_1_0 -- ^ @CC-BY-ND-1.0@, Creative Commons Attribution No Derivatives 1.0 Generic - | CC_BY_ND_2_0 -- ^ @CC-BY-ND-2.0@, Creative Commons Attribution No Derivatives 2.0 Generic - | CC_BY_ND_2_5 -- ^ @CC-BY-ND-2.5@, Creative Commons Attribution No Derivatives 2.5 Generic - | CC_BY_ND_3_0 -- ^ @CC-BY-ND-3.0@, Creative Commons Attribution No Derivatives 3.0 Unported - | CC_BY_ND_4_0 -- ^ @CC-BY-ND-4.0@, Creative Commons Attribution No Derivatives 4.0 International - | CC_BY_SA_1_0 -- ^ @CC-BY-SA-1.0@, Creative Commons Attribution Share Alike 1.0 Generic - | CC_BY_SA_2_0 -- ^ @CC-BY-SA-2.0@, Creative Commons Attribution Share Alike 2.0 Generic - | CC_BY_SA_2_5 -- ^ @CC-BY-SA-2.5@, Creative Commons Attribution Share Alike 2.5 Generic - | CC_BY_SA_3_0_AT -- ^ @CC-BY-SA-3.0-AT@, Creative Commons Attribution-Share Alike 3.0 Austria, SPDX License List 3.10 - | CC_BY_SA_3_0 -- ^ @CC-BY-SA-3.0@, Creative Commons Attribution Share Alike 3.0 Unported - | CC_BY_SA_4_0 -- ^ @CC-BY-SA-4.0@, Creative Commons Attribution Share Alike 4.0 International - | CC_PDDC -- ^ @CC-PDDC@, Creative Commons Public Domain Dedication and Certification, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10 - | CC0_1_0 -- ^ @CC0-1.0@, Creative Commons Zero v1.0 Universal - | CDDL_1_0 -- ^ @CDDL-1.0@, Common Development and Distribution License 1.0 - | CDDL_1_1 -- ^ @CDDL-1.1@, Common Development and Distribution License 1.1 - | CDLA_Permissive_1_0 -- ^ @CDLA-Permissive-1.0@, Community Data License Agreement Permissive 1.0 - | CDLA_Sharing_1_0 -- ^ @CDLA-Sharing-1.0@, Community Data License Agreement Sharing 1.0 - | CECILL_1_0 -- ^ @CECILL-1.0@, CeCILL Free Software License Agreement v1.0 - | CECILL_1_1 -- ^ @CECILL-1.1@, CeCILL Free Software License Agreement v1.1 - | CECILL_2_0 -- ^ @CECILL-2.0@, CeCILL Free Software License Agreement v2.0 - | CECILL_2_1 -- ^ @CECILL-2.1@, CeCILL Free Software License Agreement v2.1 - | CECILL_B -- ^ @CECILL-B@, CeCILL-B Free Software License Agreement - | CECILL_C -- ^ @CECILL-C@, CeCILL-C Free Software License Agreement - | CERN_OHL_1_1 -- ^ @CERN-OHL-1.1@, CERN Open Hardware Licence v1.1, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10 - | CERN_OHL_1_2 -- ^ @CERN-OHL-1.2@, CERN Open Hardware Licence v1.2, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10 - | CERN_OHL_P_2_0 -- ^ @CERN-OHL-P-2.0@, CERN Open Hardware Licence Version 2 - Permissive, SPDX License List 3.9, SPDX License List 3.10 - | CERN_OHL_S_2_0 -- ^ @CERN-OHL-S-2.0@, CERN Open Hardware Licence Version 2 - Strongly Reciprocal, SPDX License List 3.9, SPDX License List 3.10 - | CERN_OHL_W_2_0 -- ^ @CERN-OHL-W-2.0@, CERN Open Hardware Licence Version 2 - Weakly Reciprocal, SPDX License List 3.9, SPDX License List 3.10 - | ClArtistic -- ^ @ClArtistic@, Clarified Artistic License - | CNRI_Jython -- ^ @CNRI-Jython@, CNRI Jython License - | CNRI_Python_GPL_Compatible -- ^ @CNRI-Python-GPL-Compatible@, CNRI Python Open Source GPL Compatible License Agreement - | CNRI_Python -- ^ @CNRI-Python@, CNRI Python License - | Condor_1_1 -- ^ @Condor-1.1@, Condor Public License v1.1 - | Copyleft_next_0_3_0 -- ^ @copyleft-next-0.3.0@, copyleft-next 0.3.0, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10 - | Copyleft_next_0_3_1 -- ^ @copyleft-next-0.3.1@, copyleft-next 0.3.1, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10 - | CPAL_1_0 -- ^ @CPAL-1.0@, Common Public Attribution License 1.0 - | CPL_1_0 -- ^ @CPL-1.0@, Common Public License 1.0 - | CPOL_1_02 -- ^ @CPOL-1.02@, Code Project Open License 1.02 - | Crossword -- ^ @Crossword@, Crossword License - | CrystalStacker -- ^ @CrystalStacker@, CrystalStacker License - | CUA_OPL_1_0 -- ^ @CUA-OPL-1.0@, CUA Office Public License v1.0 - | Cube -- ^ @Cube@, Cube License - | Curl -- ^ @curl@, curl License - | D_FSL_1_0 -- ^ @D-FSL-1.0@, Deutsche Freie Software Lizenz - | Diffmark -- ^ @diffmark@, diffmark license - | DOC -- ^ @DOC@, DOC License - | Dotseqn -- ^ @Dotseqn@, Dotseqn License - | DSDP -- ^ @DSDP@, DSDP License - | Dvipdfm -- ^ @dvipdfm@, dvipdfm License - | ECL_1_0 -- ^ @ECL-1.0@, Educational Community License v1.0 - | ECL_2_0 -- ^ @ECL-2.0@, Educational Community License v2.0 - | EFL_1_0 -- ^ @EFL-1.0@, Eiffel Forum License v1.0 - | EFL_2_0 -- ^ @EFL-2.0@, Eiffel Forum License v2.0 - | EGenix -- ^ @eGenix@, eGenix.com Public License 1.1.0 - | Entessa -- ^ @Entessa@, Entessa Public License v1.0 - | EPICS -- ^ @EPICS@, EPICS Open License, SPDX License List 3.10 - | EPL_1_0 -- ^ @EPL-1.0@, Eclipse Public License 1.0 - | EPL_2_0 -- ^ @EPL-2.0@, Eclipse Public License 2.0 - | ErlPL_1_1 -- ^ @ErlPL-1.1@, Erlang Public License v1.1 - | Etalab_2_0 -- ^ @etalab-2.0@, Etalab Open License 2.0, SPDX License List 3.9, SPDX License List 3.10 - | EUDatagrid -- ^ @EUDatagrid@, EU DataGrid Software License - | EUPL_1_0 -- ^ @EUPL-1.0@, European Union Public License 1.0 - | EUPL_1_1 -- ^ @EUPL-1.1@, European Union Public License 1.1 - | EUPL_1_2 -- ^ @EUPL-1.2@, European Union Public License 1.2 - | Eurosym -- ^ @Eurosym@, Eurosym License - | Fair -- ^ @Fair@, Fair License - | Frameworx_1_0 -- ^ @Frameworx-1.0@, Frameworx Open License 1.0 - | FreeImage -- ^ @FreeImage@, FreeImage Public License v1.0 - | FSFAP -- ^ @FSFAP@, FSF All Permissive License - | FSFULLR -- ^ @FSFULLR@, FSF Unlimited License (with License Retention) - | FSFUL -- ^ @FSFUL@, FSF Unlimited License - | FTL -- ^ @FTL@, Freetype Project License - | GFDL_1_1_invariants_only -- ^ @GFDL-1.1-invariants-only@, GNU Free Documentation License v1.1 only - invariants, SPDX License List 3.10 - | GFDL_1_1_invariants_or_later -- ^ @GFDL-1.1-invariants-or-later@, GNU Free Documentation License v1.1 or later - invariants, SPDX License List 3.10 - | GFDL_1_1_no_invariants_only -- ^ @GFDL-1.1-no-invariants-only@, GNU Free Documentation License v1.1 only - no invariants, SPDX License List 3.10 - | GFDL_1_1_no_invariants_or_later -- ^ @GFDL-1.1-no-invariants-or-later@, GNU Free Documentation License v1.1 or later - no invariants, SPDX License List 3.10 - | GFDL_1_1_only -- ^ @GFDL-1.1-only@, GNU Free Documentation License v1.1 only - | GFDL_1_1_or_later -- ^ @GFDL-1.1-or-later@, GNU Free Documentation License v1.1 or later - | GFDL_1_2_invariants_only -- ^ @GFDL-1.2-invariants-only@, GNU Free Documentation License v1.2 only - invariants, SPDX License List 3.10 - | GFDL_1_2_invariants_or_later -- ^ @GFDL-1.2-invariants-or-later@, GNU Free Documentation License v1.2 or later - invariants, SPDX License List 3.10 - | GFDL_1_2_no_invariants_only -- ^ @GFDL-1.2-no-invariants-only@, GNU Free Documentation License v1.2 only - no invariants, SPDX License List 3.10 - | GFDL_1_2_no_invariants_or_later -- ^ @GFDL-1.2-no-invariants-or-later@, GNU Free Documentation License v1.2 or later - no invariants, SPDX License List 3.10 - | GFDL_1_2_only -- ^ @GFDL-1.2-only@, GNU Free Documentation License v1.2 only - | GFDL_1_2_or_later -- ^ @GFDL-1.2-or-later@, GNU Free Documentation License v1.2 or later - | GFDL_1_3_invariants_only -- ^ @GFDL-1.3-invariants-only@, GNU Free Documentation License v1.3 only - invariants, SPDX License List 3.10 - | GFDL_1_3_invariants_or_later -- ^ @GFDL-1.3-invariants-or-later@, GNU Free Documentation License v1.3 or later - invariants, SPDX License List 3.10 - | GFDL_1_3_no_invariants_only -- ^ @GFDL-1.3-no-invariants-only@, GNU Free Documentation License v1.3 only - no invariants, SPDX License List 3.10 - | GFDL_1_3_no_invariants_or_later -- ^ @GFDL-1.3-no-invariants-or-later@, GNU Free Documentation License v1.3 or later - no invariants, SPDX License List 3.10 - | GFDL_1_3_only -- ^ @GFDL-1.3-only@, GNU Free Documentation License v1.3 only - | GFDL_1_3_or_later -- ^ @GFDL-1.3-or-later@, GNU Free Documentation License v1.3 or later - | Giftware -- ^ @Giftware@, Giftware License - | GL2PS -- ^ @GL2PS@, GL2PS License - | Glide -- ^ @Glide@, 3dfx Glide License - | Glulxe -- ^ @Glulxe@, Glulxe License - | GLWTPL -- ^ @GLWTPL@, Good Luck With That Public License, SPDX License List 3.10 - | Gnuplot -- ^ @gnuplot@, gnuplot License - | GPL_1_0_only -- ^ @GPL-1.0-only@, GNU General Public License v1.0 only - | GPL_1_0_or_later -- ^ @GPL-1.0-or-later@, GNU General Public License v1.0 or later - | GPL_2_0_only -- ^ @GPL-2.0-only@, GNU General Public License v2.0 only - | GPL_2_0_or_later -- ^ @GPL-2.0-or-later@, GNU General Public License v2.0 or later - | GPL_3_0_only -- ^ @GPL-3.0-only@, GNU General Public License v3.0 only - | GPL_3_0_or_later -- ^ @GPL-3.0-or-later@, GNU General Public License v3.0 or later - | GSOAP_1_3b -- ^ @gSOAP-1.3b@, gSOAP Public License v1.3b - | HaskellReport -- ^ @HaskellReport@, Haskell Language Report License - | Hippocratic_2_1 -- ^ @Hippocratic-2.1@, Hippocratic License 2.1, SPDX License List 3.9, SPDX License List 3.10 - | HPND_sell_variant -- ^ @HPND-sell-variant@, Historical Permission Notice and Disclaimer - sell variant, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10 - | HPND -- ^ @HPND@, Historical Permission Notice and Disclaimer - | IBM_pibs -- ^ @IBM-pibs@, IBM PowerPC Initialization and Boot Software - | ICU -- ^ @ICU@, ICU License - | IJG -- ^ @IJG@, Independent JPEG Group License - | ImageMagick -- ^ @ImageMagick@, ImageMagick License - | IMatix -- ^ @iMatix@, iMatix Standard Function Library Agreement - | Imlib2 -- ^ @Imlib2@, Imlib2 License - | Info_ZIP -- ^ @Info-ZIP@, Info-ZIP License - | Intel_ACPI -- ^ @Intel-ACPI@, Intel ACPI Software License Agreement - | Intel -- ^ @Intel@, Intel Open Source License - | Interbase_1_0 -- ^ @Interbase-1.0@, Interbase Public License v1.0 - | IPA -- ^ @IPA@, IPA Font License - | IPL_1_0 -- ^ @IPL-1.0@, IBM Public License v1.0 - | ISC -- ^ @ISC@, ISC License - | JasPer_2_0 -- ^ @JasPer-2.0@, JasPer License - | JPNIC -- ^ @JPNIC@, Japan Network Information Center License, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10 - | JSON -- ^ @JSON@, JSON License - | LAL_1_2 -- ^ @LAL-1.2@, Licence Art Libre 1.2 - | LAL_1_3 -- ^ @LAL-1.3@, Licence Art Libre 1.3 - | Latex2e -- ^ @Latex2e@, Latex2e License - | Leptonica -- ^ @Leptonica@, Leptonica License - | LGPL_2_0_only -- ^ @LGPL-2.0-only@, GNU Library General Public License v2 only - | LGPL_2_0_or_later -- ^ @LGPL-2.0-or-later@, GNU Library General Public License v2 or later - | LGPL_2_1_only -- ^ @LGPL-2.1-only@, GNU Lesser General Public License v2.1 only - | LGPL_2_1_or_later -- ^ @LGPL-2.1-or-later@, GNU Lesser General Public License v2.1 or later - | LGPL_3_0_only -- ^ @LGPL-3.0-only@, GNU Lesser General Public License v3.0 only - | LGPL_3_0_or_later -- ^ @LGPL-3.0-or-later@, GNU Lesser General Public License v3.0 or later - | LGPLLR -- ^ @LGPLLR@, Lesser General Public License For Linguistic Resources - | Libpng_2_0 -- ^ @libpng-2.0@, PNG Reference Library version 2, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10 - | Libpng -- ^ @Libpng@, libpng License - | Libselinux_1_0 -- ^ @libselinux-1.0@, libselinux public domain notice, SPDX License List 3.9, SPDX License List 3.10 - | Libtiff -- ^ @libtiff@, libtiff License - | LiLiQ_P_1_1 -- ^ @LiLiQ-P-1.1@, Licence Libre du Québec – Permissive version 1.1 - | LiLiQ_R_1_1 -- ^ @LiLiQ-R-1.1@, Licence Libre du Québec – Réciprocité version 1.1 - | LiLiQ_Rplus_1_1 -- ^ @LiLiQ-Rplus-1.1@, Licence Libre du Québec – Réciprocité forte version 1.1 - | Linux_OpenIB -- ^ @Linux-OpenIB@, Linux Kernel Variant of OpenIB.org license, SPDX License List 3.2, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10 - | LPL_1_02 -- ^ @LPL-1.02@, Lucent Public License v1.02 - | LPL_1_0 -- ^ @LPL-1.0@, Lucent Public License Version 1.0 - | LPPL_1_0 -- ^ @LPPL-1.0@, LaTeX Project Public License v1.0 - | LPPL_1_1 -- ^ @LPPL-1.1@, LaTeX Project Public License v1.1 - | LPPL_1_2 -- ^ @LPPL-1.2@, LaTeX Project Public License v1.2 - | LPPL_1_3a -- ^ @LPPL-1.3a@, LaTeX Project Public License v1.3a - | LPPL_1_3c -- ^ @LPPL-1.3c@, LaTeX Project Public License v1.3c - | MakeIndex -- ^ @MakeIndex@, MakeIndex License - | MirOS -- ^ @MirOS@, The MirOS Licence - | MIT_0 -- ^ @MIT-0@, MIT No Attribution, SPDX License List 3.2, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10 - | MIT_advertising -- ^ @MIT-advertising@, Enlightenment License (e16) - | MIT_CMU -- ^ @MIT-CMU@, CMU License - | MIT_enna -- ^ @MIT-enna@, enna License - | MIT_feh -- ^ @MIT-feh@, feh License - | MITNFA -- ^ @MITNFA@, MIT +no-false-attribs license - | MIT -- ^ @MIT@, MIT License - | Motosoto -- ^ @Motosoto@, Motosoto License - | Mpich2 -- ^ @mpich2@, mpich2 License - | MPL_1_0 -- ^ @MPL-1.0@, Mozilla Public License 1.0 - | MPL_1_1 -- ^ @MPL-1.1@, Mozilla Public License 1.1 - | MPL_2_0_no_copyleft_exception -- ^ @MPL-2.0-no-copyleft-exception@, Mozilla Public License 2.0 (no copyleft exception) - | MPL_2_0 -- ^ @MPL-2.0@, Mozilla Public License 2.0 - | MS_PL -- ^ @MS-PL@, Microsoft Public License - | MS_RL -- ^ @MS-RL@, Microsoft Reciprocal License - | MTLL -- ^ @MTLL@, Matrix Template Library License - | MulanPSL_1_0 -- ^ @MulanPSL-1.0@, Mulan Permissive Software License, Version 1, SPDX License List 3.9, SPDX License List 3.10 - | MulanPSL_2_0 -- ^ @MulanPSL-2.0@, Mulan Permissive Software License, Version 2, SPDX License List 3.9, SPDX License List 3.10 - | Multics -- ^ @Multics@, Multics License - | Mup -- ^ @Mup@, Mup License - | NASA_1_3 -- ^ @NASA-1.3@, NASA Open Source Agreement 1.3 - | Naumen -- ^ @Naumen@, Naumen Public License - | NBPL_1_0 -- ^ @NBPL-1.0@, Net Boolean Public License v1 - | NCGL_UK_2_0 -- ^ @NCGL-UK-2.0@, Non-Commercial Government Licence, SPDX License List 3.9, SPDX License List 3.10 - | NCSA -- ^ @NCSA@, University of Illinois/NCSA Open Source License - | Net_SNMP -- ^ @Net-SNMP@, Net-SNMP License - | NetCDF -- ^ @NetCDF@, NetCDF license - | Newsletr -- ^ @Newsletr@, Newsletr License - | NGPL -- ^ @NGPL@, Nethack General Public License - | NIST_PD_fallback -- ^ @NIST-PD-fallback@, NIST Public Domain Notice with license fallback, SPDX License List 3.10 - | NIST_PD -- ^ @NIST-PD@, NIST Public Domain Notice, SPDX License List 3.10 - | NLOD_1_0 -- ^ @NLOD-1.0@, Norwegian Licence for Open Government Data - | NLPL -- ^ @NLPL@, No Limit Public License - | Nokia -- ^ @Nokia@, Nokia Open Source License - | NOSL -- ^ @NOSL@, Netizen Open Source License - | Noweb -- ^ @Noweb@, Noweb License - | NPL_1_0 -- ^ @NPL-1.0@, Netscape Public License v1.0 - | NPL_1_1 -- ^ @NPL-1.1@, Netscape Public License v1.1 - | NPOSL_3_0 -- ^ @NPOSL-3.0@, Non-Profit Open Software License 3.0 - | NRL -- ^ @NRL@, NRL License - | NTP_0 -- ^ @NTP-0@, NTP No Attribution, SPDX License List 3.9, SPDX License List 3.10 - | NTP -- ^ @NTP@, NTP License - | O_UDA_1_0 -- ^ @O-UDA-1.0@, Open Use of Data Agreement v1.0, SPDX License List 3.9, SPDX License List 3.10 - | OCCT_PL -- ^ @OCCT-PL@, Open CASCADE Technology Public License - | OCLC_2_0 -- ^ @OCLC-2.0@, OCLC Research Public License 2.0 - | ODbL_1_0 -- ^ @ODbL-1.0@, ODC Open Database License v1.0 - | ODC_By_1_0 -- ^ @ODC-By-1.0@, Open Data Commons Attribution License v1.0, SPDX License List 3.2, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10 - | OFL_1_0_no_RFN -- ^ @OFL-1.0-no-RFN@, SIL Open Font License 1.0 with no Reserved Font Name, SPDX License List 3.9, SPDX License List 3.10 - | OFL_1_0_RFN -- ^ @OFL-1.0-RFN@, SIL Open Font License 1.0 with Reserved Font Name, SPDX License List 3.9, SPDX License List 3.10 - | OFL_1_0 -- ^ @OFL-1.0@, SIL Open Font License 1.0 - | OFL_1_1_no_RFN -- ^ @OFL-1.1-no-RFN@, SIL Open Font License 1.1 with no Reserved Font Name, SPDX License List 3.9, SPDX License List 3.10 - | OFL_1_1_RFN -- ^ @OFL-1.1-RFN@, SIL Open Font License 1.1 with Reserved Font Name, SPDX License List 3.9, SPDX License List 3.10 - | OFL_1_1 -- ^ @OFL-1.1@, SIL Open Font License 1.1 - | OGC_1_0 -- ^ @OGC-1.0@, OGC Software License, Version 1.0, SPDX License List 3.9, SPDX License List 3.10 - | OGL_Canada_2_0 -- ^ @OGL-Canada-2.0@, Open Government Licence - Canada, SPDX License List 3.9, SPDX License List 3.10 - | OGL_UK_1_0 -- ^ @OGL-UK-1.0@, Open Government Licence v1.0, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10 - | OGL_UK_2_0 -- ^ @OGL-UK-2.0@, Open Government Licence v2.0, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10 - | OGL_UK_3_0 -- ^ @OGL-UK-3.0@, Open Government Licence v3.0, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10 - | OGTSL -- ^ @OGTSL@, Open Group Test Suite License - | OLDAP_1_1 -- ^ @OLDAP-1.1@, Open LDAP Public License v1.1 - | OLDAP_1_2 -- ^ @OLDAP-1.2@, Open LDAP Public License v1.2 - | OLDAP_1_3 -- ^ @OLDAP-1.3@, Open LDAP Public License v1.3 - | OLDAP_1_4 -- ^ @OLDAP-1.4@, Open LDAP Public License v1.4 - | OLDAP_2_0_1 -- ^ @OLDAP-2.0.1@, Open LDAP Public License v2.0.1 - | OLDAP_2_0 -- ^ @OLDAP-2.0@, Open LDAP Public License v2.0 (or possibly 2.0A and 2.0B) - | OLDAP_2_1 -- ^ @OLDAP-2.1@, Open LDAP Public License v2.1 - | OLDAP_2_2_1 -- ^ @OLDAP-2.2.1@, Open LDAP Public License v2.2.1 - | OLDAP_2_2_2 -- ^ @OLDAP-2.2.2@, Open LDAP Public License 2.2.2 - | OLDAP_2_2 -- ^ @OLDAP-2.2@, Open LDAP Public License v2.2 - | OLDAP_2_3 -- ^ @OLDAP-2.3@, Open LDAP Public License v2.3 - | OLDAP_2_4 -- ^ @OLDAP-2.4@, Open LDAP Public License v2.4 - | OLDAP_2_5 -- ^ @OLDAP-2.5@, Open LDAP Public License v2.5 - | OLDAP_2_6 -- ^ @OLDAP-2.6@, Open LDAP Public License v2.6 - | OLDAP_2_7 -- ^ @OLDAP-2.7@, Open LDAP Public License v2.7 - | OLDAP_2_8 -- ^ @OLDAP-2.8@, Open LDAP Public License v2.8 - | OML -- ^ @OML@, Open Market License - | OpenSSL -- ^ @OpenSSL@, OpenSSL License - | OPL_1_0 -- ^ @OPL-1.0@, Open Public License v1.0 - | OSET_PL_2_1 -- ^ @OSET-PL-2.1@, OSET Public License version 2.1 - | OSL_1_0 -- ^ @OSL-1.0@, Open Software License 1.0 - | OSL_1_1 -- ^ @OSL-1.1@, Open Software License 1.1 - | OSL_2_0 -- ^ @OSL-2.0@, Open Software License 2.0 - | OSL_2_1 -- ^ @OSL-2.1@, Open Software License 2.1 - | OSL_3_0 -- ^ @OSL-3.0@, Open Software License 3.0 - | Parity_6_0_0 -- ^ @Parity-6.0.0@, The Parity Public License 6.0.0, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10 - | Parity_7_0_0 -- ^ @Parity-7.0.0@, The Parity Public License 7.0.0, SPDX License List 3.9, SPDX License List 3.10 - | PDDL_1_0 -- ^ @PDDL-1.0@, ODC Public Domain Dedication & License 1.0 - | PHP_3_01 -- ^ @PHP-3.01@, PHP License v3.01 - | PHP_3_0 -- ^ @PHP-3.0@, PHP License v3.0 - | Plexus -- ^ @Plexus@, Plexus Classworlds License - | PolyForm_Noncommercial_1_0_0 -- ^ @PolyForm-Noncommercial-1.0.0@, PolyForm Noncommercial License 1.0.0, SPDX License List 3.9, SPDX License List 3.10 - | PolyForm_Small_Business_1_0_0 -- ^ @PolyForm-Small-Business-1.0.0@, PolyForm Small Business License 1.0.0, SPDX License List 3.9, SPDX License List 3.10 - | PostgreSQL -- ^ @PostgreSQL@, PostgreSQL License - | PSF_2_0 -- ^ @PSF-2.0@, Python Software Foundation License 2.0, SPDX License List 3.9, SPDX License List 3.10 - | Psfrag -- ^ @psfrag@, psfrag License - | Psutils -- ^ @psutils@, psutils License - | Python_2_0 -- ^ @Python-2.0@, Python License 2.0 - | Qhull -- ^ @Qhull@, Qhull License - | QPL_1_0 -- ^ @QPL-1.0@, Q Public License 1.0 - | Rdisc -- ^ @Rdisc@, Rdisc License - | RHeCos_1_1 -- ^ @RHeCos-1.1@, Red Hat eCos Public License v1.1 - | RPL_1_1 -- ^ @RPL-1.1@, Reciprocal Public License 1.1 - | RPL_1_5 -- ^ @RPL-1.5@, Reciprocal Public License 1.5 - | RPSL_1_0 -- ^ @RPSL-1.0@, RealNetworks Public Source License v1.0 - | RSA_MD -- ^ @RSA-MD@, RSA Message-Digest License - | RSCPL -- ^ @RSCPL@, Ricoh Source Code Public License - | Ruby -- ^ @Ruby@, Ruby License - | SAX_PD -- ^ @SAX-PD@, Sax Public Domain Notice - | Saxpath -- ^ @Saxpath@, Saxpath License - | SCEA -- ^ @SCEA@, SCEA Shared Source License - | Sendmail_8_23 -- ^ @Sendmail-8.23@, Sendmail License 8.23, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10 - | Sendmail -- ^ @Sendmail@, Sendmail License - | SGI_B_1_0 -- ^ @SGI-B-1.0@, SGI Free Software License B v1.0 - | SGI_B_1_1 -- ^ @SGI-B-1.1@, SGI Free Software License B v1.1 - | SGI_B_2_0 -- ^ @SGI-B-2.0@, SGI Free Software License B v2.0 - | SHL_0_51 -- ^ @SHL-0.51@, Solderpad Hardware License, Version 0.51, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10 - | SHL_0_5 -- ^ @SHL-0.5@, Solderpad Hardware License v0.5, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10 - | SimPL_2_0 -- ^ @SimPL-2.0@, Simple Public License 2.0 - | SISSL_1_2 -- ^ @SISSL-1.2@, Sun Industry Standards Source License v1.2 - | SISSL -- ^ @SISSL@, Sun Industry Standards Source License v1.1 - | Sleepycat -- ^ @Sleepycat@, Sleepycat License - | SMLNJ -- ^ @SMLNJ@, Standard ML of New Jersey License - | SMPPL -- ^ @SMPPL@, Secure Messaging Protocol Public License - | SNIA -- ^ @SNIA@, SNIA Public License 1.1 - | Spencer_86 -- ^ @Spencer-86@, Spencer License 86 - | Spencer_94 -- ^ @Spencer-94@, Spencer License 94 - | Spencer_99 -- ^ @Spencer-99@, Spencer License 99 - | SPL_1_0 -- ^ @SPL-1.0@, Sun Public License v1.0 - | SSH_OpenSSH -- ^ @SSH-OpenSSH@, SSH OpenSSH license, SPDX License List 3.9, SPDX License List 3.10 - | SSH_short -- ^ @SSH-short@, SSH short notice, SPDX License List 3.9, SPDX License List 3.10 - | SSPL_1_0 -- ^ @SSPL-1.0@, Server Side Public License, v 1, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10 - | SugarCRM_1_1_3 -- ^ @SugarCRM-1.1.3@, SugarCRM Public License v1.1.3 - | SWL -- ^ @SWL@, Scheme Widget Library (SWL) Software License Agreement - | TAPR_OHL_1_0 -- ^ @TAPR-OHL-1.0@, TAPR Open Hardware License v1.0, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10 - | TCL -- ^ @TCL@, TCL/TK License - | TCP_wrappers -- ^ @TCP-wrappers@, TCP Wrappers License - | TMate -- ^ @TMate@, TMate Open Source License - | TORQUE_1_1 -- ^ @TORQUE-1.1@, TORQUE v2.5+ Software License v1.1 - | TOSL -- ^ @TOSL@, Trusster Open Source License - | TU_Berlin_1_0 -- ^ @TU-Berlin-1.0@, Technische Universitaet Berlin License 1.0, SPDX License List 3.2, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10 - | TU_Berlin_2_0 -- ^ @TU-Berlin-2.0@, Technische Universitaet Berlin License 2.0, SPDX License List 3.2, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10 - | UCL_1_0 -- ^ @UCL-1.0@, Upstream Compatibility License v1.0, SPDX License List 3.9, SPDX License List 3.10 - | Unicode_DFS_2015 -- ^ @Unicode-DFS-2015@, Unicode License Agreement - Data Files and Software (2015) - | Unicode_DFS_2016 -- ^ @Unicode-DFS-2016@, Unicode License Agreement - Data Files and Software (2016) - | Unicode_TOU -- ^ @Unicode-TOU@, Unicode Terms of Use - | Unlicense -- ^ @Unlicense@, The Unlicense - | UPL_1_0 -- ^ @UPL-1.0@, Universal Permissive License v1.0 - | Vim -- ^ @Vim@, Vim License - | VOSTROM -- ^ @VOSTROM@, VOSTROM Public License for Open Source - | VSL_1_0 -- ^ @VSL-1.0@, Vovida Software License v1.0 - | W3C_19980720 -- ^ @W3C-19980720@, W3C Software Notice and License (1998-07-20) - | W3C_20150513 -- ^ @W3C-20150513@, W3C Software Notice and Document License (2015-05-13) - | W3C -- ^ @W3C@, W3C Software Notice and License (2002-12-31) - | Watcom_1_0 -- ^ @Watcom-1.0@, Sybase Open Watcom Public License 1.0 - | Wsuipa -- ^ @Wsuipa@, Wsuipa License - | WTFPL -- ^ @WTFPL@, Do What The F*ck You Want To Public License - | X11 -- ^ @X11@, X11 License - | Xerox -- ^ @Xerox@, Xerox License - | XFree86_1_1 -- ^ @XFree86-1.1@, XFree86 License 1.1 - | Xinetd -- ^ @xinetd@, xinetd License - | Xnet -- ^ @Xnet@, X.Net License - | Xpp -- ^ @xpp@, XPP License - | XSkat -- ^ @XSkat@, XSkat License - | YPL_1_0 -- ^ @YPL-1.0@, Yahoo! Public License v1.0 - | YPL_1_1 -- ^ @YPL-1.1@, Yahoo! Public License v1.1 - | Zed -- ^ @Zed@, Zed License - | Zend_2_0 -- ^ @Zend-2.0@, Zend License v2.0 - | Zimbra_1_3 -- ^ @Zimbra-1.3@, Zimbra Public License v1.3 - | Zimbra_1_4 -- ^ @Zimbra-1.4@, Zimbra Public License v1.4 - | Zlib_acknowledgement -- ^ @zlib-acknowledgement@, zlib/libpng License with Acknowledgement - | Zlib -- ^ @Zlib@, zlib License - | ZPL_1_1 -- ^ @ZPL-1.1@, Zope Public License 1.1 - | ZPL_2_0 -- ^ @ZPL-2.0@, Zope Public License 2.0 - | ZPL_2_1 -- ^ @ZPL-2.1@, Zope Public License 2.1 - deriving (Eq, Ord, Enum, Bounded, Show, Read, Typeable, Data, Generic) - -instance Binary LicenseId where - -- Word16 is encoded in big endianess - -- https://github.com/kolmodin/binary/blob/master/src/Data/Binary/Class.hs#L220-LL227 - put = Binary.putWord16be . fromIntegral . fromEnum - get = do - i <- Binary.getWord16be - if i > fromIntegral (fromEnum (maxBound :: LicenseId)) - then fail "Too large LicenseId tag" - else return (toEnum (fromIntegral i)) - --- note: remember to bump version each time the definition changes -instance Structured LicenseId where - structure p = set typeVersion 306 $ nominalStructure p - -instance Pretty LicenseId where - pretty = Disp.text . licenseId - --- | --- >>> eitherParsec "BSD-3-Clause" :: Either String LicenseId --- Right BSD_3_Clause --- --- >>> eitherParsec "BSD3" :: Either String LicenseId --- Left "...Unknown SPDX license identifier: 'BSD3' Do you mean BSD-3-Clause?" --- -instance Parsec LicenseId where - parsec = do - n <- some $ P.satisfy $ \c -> isAsciiAlphaNum c || c == '-' || c == '.' - v <- askCabalSpecVersion - maybe (fail $ "Unknown SPDX license identifier: '" ++ n ++ "' " ++ licenseIdMigrationMessage n) return $ - mkLicenseId (cabalSpecVersionToSPDXListVersion v) n - -instance NFData LicenseId where - rnf l = l `seq` () - --- | Help message for migrating from non-SPDX license identifiers. --- --- Old 'License' is almost SPDX, except for 'BSD2', 'BSD3'. This function --- suggests SPDX variant: --- --- >>> licenseIdMigrationMessage "BSD3" --- "Do you mean BSD-3-Clause?" --- --- Also 'OtherLicense', 'AllRightsReserved', and 'PublicDomain' aren't --- valid SPDX identifiers --- --- >>> traverse_ (print . licenseIdMigrationMessage) [ "OtherLicense", "AllRightsReserved", "PublicDomain" ] --- "SPDX license list contains plenty of licenses. See https://spdx.org/licenses/. Also they can be combined into complex expressions with AND and OR." --- "You can use NONE as a value of license field." --- "Public Domain is a complex matter. See https://wiki.spdx.org/view/Legal_Team/Decisions/Dealing_with_Public_Domain_within_SPDX_Files. Consider using a proper license." --- --- SPDX License list version 3.0 introduced "-only" and "-or-later" variants for GNU family of licenses. --- See --- >>> licenseIdMigrationMessage "GPL-2.0" --- "SPDX license list 3.0 deprecated suffixless variants of GNU family of licenses. Use GPL-2.0-only or GPL-2.0-or-later." --- --- For other common licenses their old license format coincides with the SPDX identifiers: --- --- >>> traverse eitherParsec ["GPL-2.0-only", "GPL-3.0-only", "LGPL-2.1-only", "MIT", "ISC", "MPL-2.0", "Apache-2.0"] :: Either String [LicenseId] --- Right [GPL_2_0_only,GPL_3_0_only,LGPL_2_1_only,MIT,ISC,MPL_2_0,Apache_2_0] --- -licenseIdMigrationMessage :: String -> String -licenseIdMigrationMessage = go where - go l | gnuVariant l = "SPDX license list 3.0 deprecated suffixless variants of GNU family of licenses. Use " ++ l ++ "-only or " ++ l ++ "-or-later." - go "BSD3" = "Do you mean BSD-3-Clause?" - go "BSD2" = "Do you mean BSD-2-Clause?" - go "AllRightsReserved" = "You can use NONE as a value of license field." - go "OtherLicense" = "SPDX license list contains plenty of licenses. See https://spdx.org/licenses/. Also they can be combined into complex expressions with AND and OR." - go "PublicDomain" = "Public Domain is a complex matter. See https://wiki.spdx.org/view/Legal_Team/Decisions/Dealing_with_Public_Domain_within_SPDX_Files. Consider using a proper license." - - -- otherwise, we don't know - go _ = "" - - gnuVariant = flip elem ["GPL-2.0", "GPL-3.0", "LGPL-2.1", "LGPL-3.0", "AGPL-3.0" ] - -------------------------------------------------------------------------------- --- License Data -------------------------------------------------------------------------------- - --- | License SPDX identifier, e.g. @"BSD-3-Clause"@. -licenseId :: LicenseId -> String -licenseId NullBSD = "0BSD" -licenseId AAL = "AAL" -licenseId Abstyles = "Abstyles" -licenseId Adobe_2006 = "Adobe-2006" -licenseId Adobe_Glyph = "Adobe-Glyph" -licenseId ADSL = "ADSL" -licenseId AFL_1_1 = "AFL-1.1" -licenseId AFL_1_2 = "AFL-1.2" -licenseId AFL_2_0 = "AFL-2.0" -licenseId AFL_2_1 = "AFL-2.1" -licenseId AFL_3_0 = "AFL-3.0" -licenseId Afmparse = "Afmparse" -licenseId AGPL_1_0 = "AGPL-1.0" -licenseId AGPL_1_0_only = "AGPL-1.0-only" -licenseId AGPL_1_0_or_later = "AGPL-1.0-or-later" -licenseId AGPL_3_0_only = "AGPL-3.0-only" -licenseId AGPL_3_0_or_later = "AGPL-3.0-or-later" -licenseId Aladdin = "Aladdin" -licenseId AMDPLPA = "AMDPLPA" -licenseId AML = "AML" -licenseId AMPAS = "AMPAS" -licenseId ANTLR_PD = "ANTLR-PD" -licenseId Apache_1_0 = "Apache-1.0" -licenseId Apache_1_1 = "Apache-1.1" -licenseId Apache_2_0 = "Apache-2.0" -licenseId APAFML = "APAFML" -licenseId APL_1_0 = "APL-1.0" -licenseId APSL_1_0 = "APSL-1.0" -licenseId APSL_1_1 = "APSL-1.1" -licenseId APSL_1_2 = "APSL-1.2" -licenseId APSL_2_0 = "APSL-2.0" -licenseId Artistic_1_0_cl8 = "Artistic-1.0-cl8" -licenseId Artistic_1_0_Perl = "Artistic-1.0-Perl" -licenseId Artistic_1_0 = "Artistic-1.0" -licenseId Artistic_2_0 = "Artistic-2.0" -licenseId Bahyph = "Bahyph" -licenseId Barr = "Barr" -licenseId Beerware = "Beerware" -licenseId BitTorrent_1_0 = "BitTorrent-1.0" -licenseId BitTorrent_1_1 = "BitTorrent-1.1" -licenseId Blessing = "blessing" -licenseId BlueOak_1_0_0 = "BlueOak-1.0.0" -licenseId Borceux = "Borceux" -licenseId BSD_1_Clause = "BSD-1-Clause" -licenseId BSD_2_Clause_FreeBSD = "BSD-2-Clause-FreeBSD" -licenseId BSD_2_Clause_NetBSD = "BSD-2-Clause-NetBSD" -licenseId BSD_2_Clause_Patent = "BSD-2-Clause-Patent" -licenseId BSD_2_Clause_Views = "BSD-2-Clause-Views" -licenseId BSD_2_Clause = "BSD-2-Clause" -licenseId BSD_3_Clause_Attribution = "BSD-3-Clause-Attribution" -licenseId BSD_3_Clause_Clear = "BSD-3-Clause-Clear" -licenseId BSD_3_Clause_LBNL = "BSD-3-Clause-LBNL" -licenseId BSD_3_Clause_No_Nuclear_License_2014 = "BSD-3-Clause-No-Nuclear-License-2014" -licenseId BSD_3_Clause_No_Nuclear_License = "BSD-3-Clause-No-Nuclear-License" -licenseId BSD_3_Clause_No_Nuclear_Warranty = "BSD-3-Clause-No-Nuclear-Warranty" -licenseId BSD_3_Clause_Open_MPI = "BSD-3-Clause-Open-MPI" -licenseId BSD_3_Clause = "BSD-3-Clause" -licenseId BSD_4_Clause_UC = "BSD-4-Clause-UC" -licenseId BSD_4_Clause = "BSD-4-Clause" -licenseId BSD_Protection = "BSD-Protection" -licenseId BSD_Source_Code = "BSD-Source-Code" -licenseId BSL_1_0 = "BSL-1.0" -licenseId Bzip2_1_0_5 = "bzip2-1.0.5" -licenseId Bzip2_1_0_6 = "bzip2-1.0.6" -licenseId CAL_1_0_Combined_Work_Exception = "CAL-1.0-Combined-Work-Exception" -licenseId CAL_1_0 = "CAL-1.0" -licenseId Caldera = "Caldera" -licenseId CATOSL_1_1 = "CATOSL-1.1" -licenseId CC_BY_1_0 = "CC-BY-1.0" -licenseId CC_BY_2_0 = "CC-BY-2.0" -licenseId CC_BY_2_5 = "CC-BY-2.5" -licenseId CC_BY_3_0_AT = "CC-BY-3.0-AT" -licenseId CC_BY_3_0 = "CC-BY-3.0" -licenseId CC_BY_4_0 = "CC-BY-4.0" -licenseId CC_BY_NC_1_0 = "CC-BY-NC-1.0" -licenseId CC_BY_NC_2_0 = "CC-BY-NC-2.0" -licenseId CC_BY_NC_2_5 = "CC-BY-NC-2.5" -licenseId CC_BY_NC_3_0 = "CC-BY-NC-3.0" -licenseId CC_BY_NC_4_0 = "CC-BY-NC-4.0" -licenseId CC_BY_NC_ND_1_0 = "CC-BY-NC-ND-1.0" -licenseId CC_BY_NC_ND_2_0 = "CC-BY-NC-ND-2.0" -licenseId CC_BY_NC_ND_2_5 = "CC-BY-NC-ND-2.5" -licenseId CC_BY_NC_ND_3_0_IGO = "CC-BY-NC-ND-3.0-IGO" -licenseId CC_BY_NC_ND_3_0 = "CC-BY-NC-ND-3.0" -licenseId CC_BY_NC_ND_4_0 = "CC-BY-NC-ND-4.0" -licenseId CC_BY_NC_SA_1_0 = "CC-BY-NC-SA-1.0" -licenseId CC_BY_NC_SA_2_0 = "CC-BY-NC-SA-2.0" -licenseId CC_BY_NC_SA_2_5 = "CC-BY-NC-SA-2.5" -licenseId CC_BY_NC_SA_3_0 = "CC-BY-NC-SA-3.0" -licenseId CC_BY_NC_SA_4_0 = "CC-BY-NC-SA-4.0" -licenseId CC_BY_ND_1_0 = "CC-BY-ND-1.0" -licenseId CC_BY_ND_2_0 = "CC-BY-ND-2.0" -licenseId CC_BY_ND_2_5 = "CC-BY-ND-2.5" -licenseId CC_BY_ND_3_0 = "CC-BY-ND-3.0" -licenseId CC_BY_ND_4_0 = "CC-BY-ND-4.0" -licenseId CC_BY_SA_1_0 = "CC-BY-SA-1.0" -licenseId CC_BY_SA_2_0 = "CC-BY-SA-2.0" -licenseId CC_BY_SA_2_5 = "CC-BY-SA-2.5" -licenseId CC_BY_SA_3_0_AT = "CC-BY-SA-3.0-AT" -licenseId CC_BY_SA_3_0 = "CC-BY-SA-3.0" -licenseId CC_BY_SA_4_0 = "CC-BY-SA-4.0" -licenseId CC_PDDC = "CC-PDDC" -licenseId CC0_1_0 = "CC0-1.0" -licenseId CDDL_1_0 = "CDDL-1.0" -licenseId CDDL_1_1 = "CDDL-1.1" -licenseId CDLA_Permissive_1_0 = "CDLA-Permissive-1.0" -licenseId CDLA_Sharing_1_0 = "CDLA-Sharing-1.0" -licenseId CECILL_1_0 = "CECILL-1.0" -licenseId CECILL_1_1 = "CECILL-1.1" -licenseId CECILL_2_0 = "CECILL-2.0" -licenseId CECILL_2_1 = "CECILL-2.1" -licenseId CECILL_B = "CECILL-B" -licenseId CECILL_C = "CECILL-C" -licenseId CERN_OHL_1_1 = "CERN-OHL-1.1" -licenseId CERN_OHL_1_2 = "CERN-OHL-1.2" -licenseId CERN_OHL_P_2_0 = "CERN-OHL-P-2.0" -licenseId CERN_OHL_S_2_0 = "CERN-OHL-S-2.0" -licenseId CERN_OHL_W_2_0 = "CERN-OHL-W-2.0" -licenseId ClArtistic = "ClArtistic" -licenseId CNRI_Jython = "CNRI-Jython" -licenseId CNRI_Python_GPL_Compatible = "CNRI-Python-GPL-Compatible" -licenseId CNRI_Python = "CNRI-Python" -licenseId Condor_1_1 = "Condor-1.1" -licenseId Copyleft_next_0_3_0 = "copyleft-next-0.3.0" -licenseId Copyleft_next_0_3_1 = "copyleft-next-0.3.1" -licenseId CPAL_1_0 = "CPAL-1.0" -licenseId CPL_1_0 = "CPL-1.0" -licenseId CPOL_1_02 = "CPOL-1.02" -licenseId Crossword = "Crossword" -licenseId CrystalStacker = "CrystalStacker" -licenseId CUA_OPL_1_0 = "CUA-OPL-1.0" -licenseId Cube = "Cube" -licenseId Curl = "curl" -licenseId D_FSL_1_0 = "D-FSL-1.0" -licenseId Diffmark = "diffmark" -licenseId DOC = "DOC" -licenseId Dotseqn = "Dotseqn" -licenseId DSDP = "DSDP" -licenseId Dvipdfm = "dvipdfm" -licenseId ECL_1_0 = "ECL-1.0" -licenseId ECL_2_0 = "ECL-2.0" -licenseId EFL_1_0 = "EFL-1.0" -licenseId EFL_2_0 = "EFL-2.0" -licenseId EGenix = "eGenix" -licenseId Entessa = "Entessa" -licenseId EPICS = "EPICS" -licenseId EPL_1_0 = "EPL-1.0" -licenseId EPL_2_0 = "EPL-2.0" -licenseId ErlPL_1_1 = "ErlPL-1.1" -licenseId Etalab_2_0 = "etalab-2.0" -licenseId EUDatagrid = "EUDatagrid" -licenseId EUPL_1_0 = "EUPL-1.0" -licenseId EUPL_1_1 = "EUPL-1.1" -licenseId EUPL_1_2 = "EUPL-1.2" -licenseId Eurosym = "Eurosym" -licenseId Fair = "Fair" -licenseId Frameworx_1_0 = "Frameworx-1.0" -licenseId FreeImage = "FreeImage" -licenseId FSFAP = "FSFAP" -licenseId FSFULLR = "FSFULLR" -licenseId FSFUL = "FSFUL" -licenseId FTL = "FTL" -licenseId GFDL_1_1_invariants_only = "GFDL-1.1-invariants-only" -licenseId GFDL_1_1_invariants_or_later = "GFDL-1.1-invariants-or-later" -licenseId GFDL_1_1_no_invariants_only = "GFDL-1.1-no-invariants-only" -licenseId GFDL_1_1_no_invariants_or_later = "GFDL-1.1-no-invariants-or-later" -licenseId GFDL_1_1_only = "GFDL-1.1-only" -licenseId GFDL_1_1_or_later = "GFDL-1.1-or-later" -licenseId GFDL_1_2_invariants_only = "GFDL-1.2-invariants-only" -licenseId GFDL_1_2_invariants_or_later = "GFDL-1.2-invariants-or-later" -licenseId GFDL_1_2_no_invariants_only = "GFDL-1.2-no-invariants-only" -licenseId GFDL_1_2_no_invariants_or_later = "GFDL-1.2-no-invariants-or-later" -licenseId GFDL_1_2_only = "GFDL-1.2-only" -licenseId GFDL_1_2_or_later = "GFDL-1.2-or-later" -licenseId GFDL_1_3_invariants_only = "GFDL-1.3-invariants-only" -licenseId GFDL_1_3_invariants_or_later = "GFDL-1.3-invariants-or-later" -licenseId GFDL_1_3_no_invariants_only = "GFDL-1.3-no-invariants-only" -licenseId GFDL_1_3_no_invariants_or_later = "GFDL-1.3-no-invariants-or-later" -licenseId GFDL_1_3_only = "GFDL-1.3-only" -licenseId GFDL_1_3_or_later = "GFDL-1.3-or-later" -licenseId Giftware = "Giftware" -licenseId GL2PS = "GL2PS" -licenseId Glide = "Glide" -licenseId Glulxe = "Glulxe" -licenseId GLWTPL = "GLWTPL" -licenseId Gnuplot = "gnuplot" -licenseId GPL_1_0_only = "GPL-1.0-only" -licenseId GPL_1_0_or_later = "GPL-1.0-or-later" -licenseId GPL_2_0_only = "GPL-2.0-only" -licenseId GPL_2_0_or_later = "GPL-2.0-or-later" -licenseId GPL_3_0_only = "GPL-3.0-only" -licenseId GPL_3_0_or_later = "GPL-3.0-or-later" -licenseId GSOAP_1_3b = "gSOAP-1.3b" -licenseId HaskellReport = "HaskellReport" -licenseId Hippocratic_2_1 = "Hippocratic-2.1" -licenseId HPND_sell_variant = "HPND-sell-variant" -licenseId HPND = "HPND" -licenseId IBM_pibs = "IBM-pibs" -licenseId ICU = "ICU" -licenseId IJG = "IJG" -licenseId ImageMagick = "ImageMagick" -licenseId IMatix = "iMatix" -licenseId Imlib2 = "Imlib2" -licenseId Info_ZIP = "Info-ZIP" -licenseId Intel_ACPI = "Intel-ACPI" -licenseId Intel = "Intel" -licenseId Interbase_1_0 = "Interbase-1.0" -licenseId IPA = "IPA" -licenseId IPL_1_0 = "IPL-1.0" -licenseId ISC = "ISC" -licenseId JasPer_2_0 = "JasPer-2.0" -licenseId JPNIC = "JPNIC" -licenseId JSON = "JSON" -licenseId LAL_1_2 = "LAL-1.2" -licenseId LAL_1_3 = "LAL-1.3" -licenseId Latex2e = "Latex2e" -licenseId Leptonica = "Leptonica" -licenseId LGPL_2_0_only = "LGPL-2.0-only" -licenseId LGPL_2_0_or_later = "LGPL-2.0-or-later" -licenseId LGPL_2_1_only = "LGPL-2.1-only" -licenseId LGPL_2_1_or_later = "LGPL-2.1-or-later" -licenseId LGPL_3_0_only = "LGPL-3.0-only" -licenseId LGPL_3_0_or_later = "LGPL-3.0-or-later" -licenseId LGPLLR = "LGPLLR" -licenseId Libpng_2_0 = "libpng-2.0" -licenseId Libpng = "Libpng" -licenseId Libselinux_1_0 = "libselinux-1.0" -licenseId Libtiff = "libtiff" -licenseId LiLiQ_P_1_1 = "LiLiQ-P-1.1" -licenseId LiLiQ_R_1_1 = "LiLiQ-R-1.1" -licenseId LiLiQ_Rplus_1_1 = "LiLiQ-Rplus-1.1" -licenseId Linux_OpenIB = "Linux-OpenIB" -licenseId LPL_1_02 = "LPL-1.02" -licenseId LPL_1_0 = "LPL-1.0" -licenseId LPPL_1_0 = "LPPL-1.0" -licenseId LPPL_1_1 = "LPPL-1.1" -licenseId LPPL_1_2 = "LPPL-1.2" -licenseId LPPL_1_3a = "LPPL-1.3a" -licenseId LPPL_1_3c = "LPPL-1.3c" -licenseId MakeIndex = "MakeIndex" -licenseId MirOS = "MirOS" -licenseId MIT_0 = "MIT-0" -licenseId MIT_advertising = "MIT-advertising" -licenseId MIT_CMU = "MIT-CMU" -licenseId MIT_enna = "MIT-enna" -licenseId MIT_feh = "MIT-feh" -licenseId MITNFA = "MITNFA" -licenseId MIT = "MIT" -licenseId Motosoto = "Motosoto" -licenseId Mpich2 = "mpich2" -licenseId MPL_1_0 = "MPL-1.0" -licenseId MPL_1_1 = "MPL-1.1" -licenseId MPL_2_0_no_copyleft_exception = "MPL-2.0-no-copyleft-exception" -licenseId MPL_2_0 = "MPL-2.0" -licenseId MS_PL = "MS-PL" -licenseId MS_RL = "MS-RL" -licenseId MTLL = "MTLL" -licenseId MulanPSL_1_0 = "MulanPSL-1.0" -licenseId MulanPSL_2_0 = "MulanPSL-2.0" -licenseId Multics = "Multics" -licenseId Mup = "Mup" -licenseId NASA_1_3 = "NASA-1.3" -licenseId Naumen = "Naumen" -licenseId NBPL_1_0 = "NBPL-1.0" -licenseId NCGL_UK_2_0 = "NCGL-UK-2.0" -licenseId NCSA = "NCSA" -licenseId Net_SNMP = "Net-SNMP" -licenseId NetCDF = "NetCDF" -licenseId Newsletr = "Newsletr" -licenseId NGPL = "NGPL" -licenseId NIST_PD_fallback = "NIST-PD-fallback" -licenseId NIST_PD = "NIST-PD" -licenseId NLOD_1_0 = "NLOD-1.0" -licenseId NLPL = "NLPL" -licenseId Nokia = "Nokia" -licenseId NOSL = "NOSL" -licenseId Noweb = "Noweb" -licenseId NPL_1_0 = "NPL-1.0" -licenseId NPL_1_1 = "NPL-1.1" -licenseId NPOSL_3_0 = "NPOSL-3.0" -licenseId NRL = "NRL" -licenseId NTP_0 = "NTP-0" -licenseId NTP = "NTP" -licenseId O_UDA_1_0 = "O-UDA-1.0" -licenseId OCCT_PL = "OCCT-PL" -licenseId OCLC_2_0 = "OCLC-2.0" -licenseId ODbL_1_0 = "ODbL-1.0" -licenseId ODC_By_1_0 = "ODC-By-1.0" -licenseId OFL_1_0_no_RFN = "OFL-1.0-no-RFN" -licenseId OFL_1_0_RFN = "OFL-1.0-RFN" -licenseId OFL_1_0 = "OFL-1.0" -licenseId OFL_1_1_no_RFN = "OFL-1.1-no-RFN" -licenseId OFL_1_1_RFN = "OFL-1.1-RFN" -licenseId OFL_1_1 = "OFL-1.1" -licenseId OGC_1_0 = "OGC-1.0" -licenseId OGL_Canada_2_0 = "OGL-Canada-2.0" -licenseId OGL_UK_1_0 = "OGL-UK-1.0" -licenseId OGL_UK_2_0 = "OGL-UK-2.0" -licenseId OGL_UK_3_0 = "OGL-UK-3.0" -licenseId OGTSL = "OGTSL" -licenseId OLDAP_1_1 = "OLDAP-1.1" -licenseId OLDAP_1_2 = "OLDAP-1.2" -licenseId OLDAP_1_3 = "OLDAP-1.3" -licenseId OLDAP_1_4 = "OLDAP-1.4" -licenseId OLDAP_2_0_1 = "OLDAP-2.0.1" -licenseId OLDAP_2_0 = "OLDAP-2.0" -licenseId OLDAP_2_1 = "OLDAP-2.1" -licenseId OLDAP_2_2_1 = "OLDAP-2.2.1" -licenseId OLDAP_2_2_2 = "OLDAP-2.2.2" -licenseId OLDAP_2_2 = "OLDAP-2.2" -licenseId OLDAP_2_3 = "OLDAP-2.3" -licenseId OLDAP_2_4 = "OLDAP-2.4" -licenseId OLDAP_2_5 = "OLDAP-2.5" -licenseId OLDAP_2_6 = "OLDAP-2.6" -licenseId OLDAP_2_7 = "OLDAP-2.7" -licenseId OLDAP_2_8 = "OLDAP-2.8" -licenseId OML = "OML" -licenseId OpenSSL = "OpenSSL" -licenseId OPL_1_0 = "OPL-1.0" -licenseId OSET_PL_2_1 = "OSET-PL-2.1" -licenseId OSL_1_0 = "OSL-1.0" -licenseId OSL_1_1 = "OSL-1.1" -licenseId OSL_2_0 = "OSL-2.0" -licenseId OSL_2_1 = "OSL-2.1" -licenseId OSL_3_0 = "OSL-3.0" -licenseId Parity_6_0_0 = "Parity-6.0.0" -licenseId Parity_7_0_0 = "Parity-7.0.0" -licenseId PDDL_1_0 = "PDDL-1.0" -licenseId PHP_3_01 = "PHP-3.01" -licenseId PHP_3_0 = "PHP-3.0" -licenseId Plexus = "Plexus" -licenseId PolyForm_Noncommercial_1_0_0 = "PolyForm-Noncommercial-1.0.0" -licenseId PolyForm_Small_Business_1_0_0 = "PolyForm-Small-Business-1.0.0" -licenseId PostgreSQL = "PostgreSQL" -licenseId PSF_2_0 = "PSF-2.0" -licenseId Psfrag = "psfrag" -licenseId Psutils = "psutils" -licenseId Python_2_0 = "Python-2.0" -licenseId Qhull = "Qhull" -licenseId QPL_1_0 = "QPL-1.0" -licenseId Rdisc = "Rdisc" -licenseId RHeCos_1_1 = "RHeCos-1.1" -licenseId RPL_1_1 = "RPL-1.1" -licenseId RPL_1_5 = "RPL-1.5" -licenseId RPSL_1_0 = "RPSL-1.0" -licenseId RSA_MD = "RSA-MD" -licenseId RSCPL = "RSCPL" -licenseId Ruby = "Ruby" -licenseId SAX_PD = "SAX-PD" -licenseId Saxpath = "Saxpath" -licenseId SCEA = "SCEA" -licenseId Sendmail_8_23 = "Sendmail-8.23" -licenseId Sendmail = "Sendmail" -licenseId SGI_B_1_0 = "SGI-B-1.0" -licenseId SGI_B_1_1 = "SGI-B-1.1" -licenseId SGI_B_2_0 = "SGI-B-2.0" -licenseId SHL_0_51 = "SHL-0.51" -licenseId SHL_0_5 = "SHL-0.5" -licenseId SimPL_2_0 = "SimPL-2.0" -licenseId SISSL_1_2 = "SISSL-1.2" -licenseId SISSL = "SISSL" -licenseId Sleepycat = "Sleepycat" -licenseId SMLNJ = "SMLNJ" -licenseId SMPPL = "SMPPL" -licenseId SNIA = "SNIA" -licenseId Spencer_86 = "Spencer-86" -licenseId Spencer_94 = "Spencer-94" -licenseId Spencer_99 = "Spencer-99" -licenseId SPL_1_0 = "SPL-1.0" -licenseId SSH_OpenSSH = "SSH-OpenSSH" -licenseId SSH_short = "SSH-short" -licenseId SSPL_1_0 = "SSPL-1.0" -licenseId SugarCRM_1_1_3 = "SugarCRM-1.1.3" -licenseId SWL = "SWL" -licenseId TAPR_OHL_1_0 = "TAPR-OHL-1.0" -licenseId TCL = "TCL" -licenseId TCP_wrappers = "TCP-wrappers" -licenseId TMate = "TMate" -licenseId TORQUE_1_1 = "TORQUE-1.1" -licenseId TOSL = "TOSL" -licenseId TU_Berlin_1_0 = "TU-Berlin-1.0" -licenseId TU_Berlin_2_0 = "TU-Berlin-2.0" -licenseId UCL_1_0 = "UCL-1.0" -licenseId Unicode_DFS_2015 = "Unicode-DFS-2015" -licenseId Unicode_DFS_2016 = "Unicode-DFS-2016" -licenseId Unicode_TOU = "Unicode-TOU" -licenseId Unlicense = "Unlicense" -licenseId UPL_1_0 = "UPL-1.0" -licenseId Vim = "Vim" -licenseId VOSTROM = "VOSTROM" -licenseId VSL_1_0 = "VSL-1.0" -licenseId W3C_19980720 = "W3C-19980720" -licenseId W3C_20150513 = "W3C-20150513" -licenseId W3C = "W3C" -licenseId Watcom_1_0 = "Watcom-1.0" -licenseId Wsuipa = "Wsuipa" -licenseId WTFPL = "WTFPL" -licenseId X11 = "X11" -licenseId Xerox = "Xerox" -licenseId XFree86_1_1 = "XFree86-1.1" -licenseId Xinetd = "xinetd" -licenseId Xnet = "Xnet" -licenseId Xpp = "xpp" -licenseId XSkat = "XSkat" -licenseId YPL_1_0 = "YPL-1.0" -licenseId YPL_1_1 = "YPL-1.1" -licenseId Zed = "Zed" -licenseId Zend_2_0 = "Zend-2.0" -licenseId Zimbra_1_3 = "Zimbra-1.3" -licenseId Zimbra_1_4 = "Zimbra-1.4" -licenseId Zlib_acknowledgement = "zlib-acknowledgement" -licenseId Zlib = "Zlib" -licenseId ZPL_1_1 = "ZPL-1.1" -licenseId ZPL_2_0 = "ZPL-2.0" -licenseId ZPL_2_1 = "ZPL-2.1" - --- | License name, e.g. @"GNU General Public License v2.0 only"@ -licenseName :: LicenseId -> String -licenseName NullBSD = "BSD Zero Clause License" -licenseName AAL = "Attribution Assurance License" -licenseName Abstyles = "Abstyles License" -licenseName Adobe_2006 = "Adobe Systems Incorporated Source Code License Agreement" -licenseName Adobe_Glyph = "Adobe Glyph List License" -licenseName ADSL = "Amazon Digital Services License" -licenseName AFL_1_1 = "Academic Free License v1.1" -licenseName AFL_1_2 = "Academic Free License v1.2" -licenseName AFL_2_0 = "Academic Free License v2.0" -licenseName AFL_2_1 = "Academic Free License v2.1" -licenseName AFL_3_0 = "Academic Free License v3.0" -licenseName Afmparse = "Afmparse License" -licenseName AGPL_1_0 = "Affero General Public License v1.0" -licenseName AGPL_1_0_only = "Affero General Public License v1.0 only" -licenseName AGPL_1_0_or_later = "Affero General Public License v1.0 or later" -licenseName AGPL_3_0_only = "GNU Affero General Public License v3.0 only" -licenseName AGPL_3_0_or_later = "GNU Affero General Public License v3.0 or later" -licenseName Aladdin = "Aladdin Free Public License" -licenseName AMDPLPA = "AMD's plpa_map.c License" -licenseName AML = "Apple MIT License" -licenseName AMPAS = "Academy of Motion Picture Arts and Sciences BSD" -licenseName ANTLR_PD = "ANTLR Software Rights Notice" -licenseName Apache_1_0 = "Apache License 1.0" -licenseName Apache_1_1 = "Apache License 1.1" -licenseName Apache_2_0 = "Apache License 2.0" -licenseName APAFML = "Adobe Postscript AFM License" -licenseName APL_1_0 = "Adaptive Public License 1.0" -licenseName APSL_1_0 = "Apple Public Source License 1.0" -licenseName APSL_1_1 = "Apple Public Source License 1.1" -licenseName APSL_1_2 = "Apple Public Source License 1.2" -licenseName APSL_2_0 = "Apple Public Source License 2.0" -licenseName Artistic_1_0_cl8 = "Artistic License 1.0 w/clause 8" -licenseName Artistic_1_0_Perl = "Artistic License 1.0 (Perl)" -licenseName Artistic_1_0 = "Artistic License 1.0" -licenseName Artistic_2_0 = "Artistic License 2.0" -licenseName Bahyph = "Bahyph License" -licenseName Barr = "Barr License" -licenseName Beerware = "Beerware License" -licenseName BitTorrent_1_0 = "BitTorrent Open Source License v1.0" -licenseName BitTorrent_1_1 = "BitTorrent Open Source License v1.1" -licenseName Blessing = "SQLite Blessing" -licenseName BlueOak_1_0_0 = "Blue Oak Model License 1.0.0" -licenseName Borceux = "Borceux license" -licenseName BSD_1_Clause = "BSD 1-Clause License" -licenseName BSD_2_Clause_FreeBSD = "BSD 2-Clause FreeBSD License" -licenseName BSD_2_Clause_NetBSD = "BSD 2-Clause NetBSD License" -licenseName BSD_2_Clause_Patent = "BSD-2-Clause Plus Patent License" -licenseName BSD_2_Clause_Views = "BSD 2-Clause with views sentence" -licenseName BSD_2_Clause = "BSD 2-Clause \"Simplified\" License" -licenseName BSD_3_Clause_Attribution = "BSD with attribution" -licenseName BSD_3_Clause_Clear = "BSD 3-Clause Clear License" -licenseName BSD_3_Clause_LBNL = "Lawrence Berkeley National Labs BSD variant license" -licenseName BSD_3_Clause_No_Nuclear_License_2014 = "BSD 3-Clause No Nuclear License 2014" -licenseName BSD_3_Clause_No_Nuclear_License = "BSD 3-Clause No Nuclear License" -licenseName BSD_3_Clause_No_Nuclear_Warranty = "BSD 3-Clause No Nuclear Warranty" -licenseName BSD_3_Clause_Open_MPI = "BSD 3-Clause Open MPI variant" -licenseName BSD_3_Clause = "BSD 3-Clause \"New\" or \"Revised\" License" -licenseName BSD_4_Clause_UC = "BSD-4-Clause (University of California-Specific)" -licenseName BSD_4_Clause = "BSD 4-Clause \"Original\" or \"Old\" License" -licenseName BSD_Protection = "BSD Protection License" -licenseName BSD_Source_Code = "BSD Source Code Attribution" -licenseName BSL_1_0 = "Boost Software License 1.0" -licenseName Bzip2_1_0_5 = "bzip2 and libbzip2 License v1.0.5" -licenseName Bzip2_1_0_6 = "bzip2 and libbzip2 License v1.0.6" -licenseName CAL_1_0_Combined_Work_Exception = "Cryptographic Autonomy License 1.0 (Combined Work Exception)" -licenseName CAL_1_0 = "Cryptographic Autonomy License 1.0" -licenseName Caldera = "Caldera License" -licenseName CATOSL_1_1 = "Computer Associates Trusted Open Source License 1.1" -licenseName CC_BY_1_0 = "Creative Commons Attribution 1.0 Generic" -licenseName CC_BY_2_0 = "Creative Commons Attribution 2.0 Generic" -licenseName CC_BY_2_5 = "Creative Commons Attribution 2.5 Generic" -licenseName CC_BY_3_0_AT = "Creative Commons Attribution 3.0 Austria" -licenseName CC_BY_3_0 = "Creative Commons Attribution 3.0 Unported" -licenseName CC_BY_4_0 = "Creative Commons Attribution 4.0 International" -licenseName CC_BY_NC_1_0 = "Creative Commons Attribution Non Commercial 1.0 Generic" -licenseName CC_BY_NC_2_0 = "Creative Commons Attribution Non Commercial 2.0 Generic" -licenseName CC_BY_NC_2_5 = "Creative Commons Attribution Non Commercial 2.5 Generic" -licenseName CC_BY_NC_3_0 = "Creative Commons Attribution Non Commercial 3.0 Unported" -licenseName CC_BY_NC_4_0 = "Creative Commons Attribution Non Commercial 4.0 International" -licenseName CC_BY_NC_ND_1_0 = "Creative Commons Attribution Non Commercial No Derivatives 1.0 Generic" -licenseName CC_BY_NC_ND_2_0 = "Creative Commons Attribution Non Commercial No Derivatives 2.0 Generic" -licenseName CC_BY_NC_ND_2_5 = "Creative Commons Attribution Non Commercial No Derivatives 2.5 Generic" -licenseName CC_BY_NC_ND_3_0_IGO = "Creative Commons Attribution Non Commercial No Derivatives 3.0 IGO" -licenseName CC_BY_NC_ND_3_0 = "Creative Commons Attribution Non Commercial No Derivatives 3.0 Unported" -licenseName CC_BY_NC_ND_4_0 = "Creative Commons Attribution Non Commercial No Derivatives 4.0 International" -licenseName CC_BY_NC_SA_1_0 = "Creative Commons Attribution Non Commercial Share Alike 1.0 Generic" -licenseName CC_BY_NC_SA_2_0 = "Creative Commons Attribution Non Commercial Share Alike 2.0 Generic" -licenseName CC_BY_NC_SA_2_5 = "Creative Commons Attribution Non Commercial Share Alike 2.5 Generic" -licenseName CC_BY_NC_SA_3_0 = "Creative Commons Attribution Non Commercial Share Alike 3.0 Unported" -licenseName CC_BY_NC_SA_4_0 = "Creative Commons Attribution Non Commercial Share Alike 4.0 International" -licenseName CC_BY_ND_1_0 = "Creative Commons Attribution No Derivatives 1.0 Generic" -licenseName CC_BY_ND_2_0 = "Creative Commons Attribution No Derivatives 2.0 Generic" -licenseName CC_BY_ND_2_5 = "Creative Commons Attribution No Derivatives 2.5 Generic" -licenseName CC_BY_ND_3_0 = "Creative Commons Attribution No Derivatives 3.0 Unported" -licenseName CC_BY_ND_4_0 = "Creative Commons Attribution No Derivatives 4.0 International" -licenseName CC_BY_SA_1_0 = "Creative Commons Attribution Share Alike 1.0 Generic" -licenseName CC_BY_SA_2_0 = "Creative Commons Attribution Share Alike 2.0 Generic" -licenseName CC_BY_SA_2_5 = "Creative Commons Attribution Share Alike 2.5 Generic" -licenseName CC_BY_SA_3_0_AT = "Creative Commons Attribution-Share Alike 3.0 Austria" -licenseName CC_BY_SA_3_0 = "Creative Commons Attribution Share Alike 3.0 Unported" -licenseName CC_BY_SA_4_0 = "Creative Commons Attribution Share Alike 4.0 International" -licenseName CC_PDDC = "Creative Commons Public Domain Dedication and Certification" -licenseName CC0_1_0 = "Creative Commons Zero v1.0 Universal" -licenseName CDDL_1_0 = "Common Development and Distribution License 1.0" -licenseName CDDL_1_1 = "Common Development and Distribution License 1.1" -licenseName CDLA_Permissive_1_0 = "Community Data License Agreement Permissive 1.0" -licenseName CDLA_Sharing_1_0 = "Community Data License Agreement Sharing 1.0" -licenseName CECILL_1_0 = "CeCILL Free Software License Agreement v1.0" -licenseName CECILL_1_1 = "CeCILL Free Software License Agreement v1.1" -licenseName CECILL_2_0 = "CeCILL Free Software License Agreement v2.0" -licenseName CECILL_2_1 = "CeCILL Free Software License Agreement v2.1" -licenseName CECILL_B = "CeCILL-B Free Software License Agreement" -licenseName CECILL_C = "CeCILL-C Free Software License Agreement" -licenseName CERN_OHL_1_1 = "CERN Open Hardware Licence v1.1" -licenseName CERN_OHL_1_2 = "CERN Open Hardware Licence v1.2" -licenseName CERN_OHL_P_2_0 = "CERN Open Hardware Licence Version 2 - Permissive" -licenseName CERN_OHL_S_2_0 = "CERN Open Hardware Licence Version 2 - Strongly Reciprocal" -licenseName CERN_OHL_W_2_0 = "CERN Open Hardware Licence Version 2 - Weakly Reciprocal" -licenseName ClArtistic = "Clarified Artistic License" -licenseName CNRI_Jython = "CNRI Jython License" -licenseName CNRI_Python_GPL_Compatible = "CNRI Python Open Source GPL Compatible License Agreement" -licenseName CNRI_Python = "CNRI Python License" -licenseName Condor_1_1 = "Condor Public License v1.1" -licenseName Copyleft_next_0_3_0 = "copyleft-next 0.3.0" -licenseName Copyleft_next_0_3_1 = "copyleft-next 0.3.1" -licenseName CPAL_1_0 = "Common Public Attribution License 1.0" -licenseName CPL_1_0 = "Common Public License 1.0" -licenseName CPOL_1_02 = "Code Project Open License 1.02" -licenseName Crossword = "Crossword License" -licenseName CrystalStacker = "CrystalStacker License" -licenseName CUA_OPL_1_0 = "CUA Office Public License v1.0" -licenseName Cube = "Cube License" -licenseName Curl = "curl License" -licenseName D_FSL_1_0 = "Deutsche Freie Software Lizenz" -licenseName Diffmark = "diffmark license" -licenseName DOC = "DOC License" -licenseName Dotseqn = "Dotseqn License" -licenseName DSDP = "DSDP License" -licenseName Dvipdfm = "dvipdfm License" -licenseName ECL_1_0 = "Educational Community License v1.0" -licenseName ECL_2_0 = "Educational Community License v2.0" -licenseName EFL_1_0 = "Eiffel Forum License v1.0" -licenseName EFL_2_0 = "Eiffel Forum License v2.0" -licenseName EGenix = "eGenix.com Public License 1.1.0" -licenseName Entessa = "Entessa Public License v1.0" -licenseName EPICS = "EPICS Open License" -licenseName EPL_1_0 = "Eclipse Public License 1.0" -licenseName EPL_2_0 = "Eclipse Public License 2.0" -licenseName ErlPL_1_1 = "Erlang Public License v1.1" -licenseName Etalab_2_0 = "Etalab Open License 2.0" -licenseName EUDatagrid = "EU DataGrid Software License" -licenseName EUPL_1_0 = "European Union Public License 1.0" -licenseName EUPL_1_1 = "European Union Public License 1.1" -licenseName EUPL_1_2 = "European Union Public License 1.2" -licenseName Eurosym = "Eurosym License" -licenseName Fair = "Fair License" -licenseName Frameworx_1_0 = "Frameworx Open License 1.0" -licenseName FreeImage = "FreeImage Public License v1.0" -licenseName FSFAP = "FSF All Permissive License" -licenseName FSFULLR = "FSF Unlimited License (with License Retention)" -licenseName FSFUL = "FSF Unlimited License" -licenseName FTL = "Freetype Project License" -licenseName GFDL_1_1_invariants_only = "GNU Free Documentation License v1.1 only - invariants" -licenseName GFDL_1_1_invariants_or_later = "GNU Free Documentation License v1.1 or later - invariants" -licenseName GFDL_1_1_no_invariants_only = "GNU Free Documentation License v1.1 only - no invariants" -licenseName GFDL_1_1_no_invariants_or_later = "GNU Free Documentation License v1.1 or later - no invariants" -licenseName GFDL_1_1_only = "GNU Free Documentation License v1.1 only" -licenseName GFDL_1_1_or_later = "GNU Free Documentation License v1.1 or later" -licenseName GFDL_1_2_invariants_only = "GNU Free Documentation License v1.2 only - invariants" -licenseName GFDL_1_2_invariants_or_later = "GNU Free Documentation License v1.2 or later - invariants" -licenseName GFDL_1_2_no_invariants_only = "GNU Free Documentation License v1.2 only - no invariants" -licenseName GFDL_1_2_no_invariants_or_later = "GNU Free Documentation License v1.2 or later - no invariants" -licenseName GFDL_1_2_only = "GNU Free Documentation License v1.2 only" -licenseName GFDL_1_2_or_later = "GNU Free Documentation License v1.2 or later" -licenseName GFDL_1_3_invariants_only = "GNU Free Documentation License v1.3 only - invariants" -licenseName GFDL_1_3_invariants_or_later = "GNU Free Documentation License v1.3 or later - invariants" -licenseName GFDL_1_3_no_invariants_only = "GNU Free Documentation License v1.3 only - no invariants" -licenseName GFDL_1_3_no_invariants_or_later = "GNU Free Documentation License v1.3 or later - no invariants" -licenseName GFDL_1_3_only = "GNU Free Documentation License v1.3 only" -licenseName GFDL_1_3_or_later = "GNU Free Documentation License v1.3 or later" -licenseName Giftware = "Giftware License" -licenseName GL2PS = "GL2PS License" -licenseName Glide = "3dfx Glide License" -licenseName Glulxe = "Glulxe License" -licenseName GLWTPL = "Good Luck With That Public License" -licenseName Gnuplot = "gnuplot License" -licenseName GPL_1_0_only = "GNU General Public License v1.0 only" -licenseName GPL_1_0_or_later = "GNU General Public License v1.0 or later" -licenseName GPL_2_0_only = "GNU General Public License v2.0 only" -licenseName GPL_2_0_or_later = "GNU General Public License v2.0 or later" -licenseName GPL_3_0_only = "GNU General Public License v3.0 only" -licenseName GPL_3_0_or_later = "GNU General Public License v3.0 or later" -licenseName GSOAP_1_3b = "gSOAP Public License v1.3b" -licenseName HaskellReport = "Haskell Language Report License" -licenseName Hippocratic_2_1 = "Hippocratic License 2.1" -licenseName HPND_sell_variant = "Historical Permission Notice and Disclaimer - sell variant" -licenseName HPND = "Historical Permission Notice and Disclaimer" -licenseName IBM_pibs = "IBM PowerPC Initialization and Boot Software" -licenseName ICU = "ICU License" -licenseName IJG = "Independent JPEG Group License" -licenseName ImageMagick = "ImageMagick License" -licenseName IMatix = "iMatix Standard Function Library Agreement" -licenseName Imlib2 = "Imlib2 License" -licenseName Info_ZIP = "Info-ZIP License" -licenseName Intel_ACPI = "Intel ACPI Software License Agreement" -licenseName Intel = "Intel Open Source License" -licenseName Interbase_1_0 = "Interbase Public License v1.0" -licenseName IPA = "IPA Font License" -licenseName IPL_1_0 = "IBM Public License v1.0" -licenseName ISC = "ISC License" -licenseName JasPer_2_0 = "JasPer License" -licenseName JPNIC = "Japan Network Information Center License" -licenseName JSON = "JSON License" -licenseName LAL_1_2 = "Licence Art Libre 1.2" -licenseName LAL_1_3 = "Licence Art Libre 1.3" -licenseName Latex2e = "Latex2e License" -licenseName Leptonica = "Leptonica License" -licenseName LGPL_2_0_only = "GNU Library General Public License v2 only" -licenseName LGPL_2_0_or_later = "GNU Library General Public License v2 or later" -licenseName LGPL_2_1_only = "GNU Lesser General Public License v2.1 only" -licenseName LGPL_2_1_or_later = "GNU Lesser General Public License v2.1 or later" -licenseName LGPL_3_0_only = "GNU Lesser General Public License v3.0 only" -licenseName LGPL_3_0_or_later = "GNU Lesser General Public License v3.0 or later" -licenseName LGPLLR = "Lesser General Public License For Linguistic Resources" -licenseName Libpng_2_0 = "PNG Reference Library version 2" -licenseName Libpng = "libpng License" -licenseName Libselinux_1_0 = "libselinux public domain notice" -licenseName Libtiff = "libtiff License" -licenseName LiLiQ_P_1_1 = "Licence Libre du Qu\233bec \8211 Permissive version 1.1" -licenseName LiLiQ_R_1_1 = "Licence Libre du Qu\233bec \8211 R\233ciprocit\233 version 1.1" -licenseName LiLiQ_Rplus_1_1 = "Licence Libre du Qu\233bec \8211 R\233ciprocit\233 forte version 1.1" -licenseName Linux_OpenIB = "Linux Kernel Variant of OpenIB.org license" -licenseName LPL_1_02 = "Lucent Public License v1.02" -licenseName LPL_1_0 = "Lucent Public License Version 1.0" -licenseName LPPL_1_0 = "LaTeX Project Public License v1.0" -licenseName LPPL_1_1 = "LaTeX Project Public License v1.1" -licenseName LPPL_1_2 = "LaTeX Project Public License v1.2" -licenseName LPPL_1_3a = "LaTeX Project Public License v1.3a" -licenseName LPPL_1_3c = "LaTeX Project Public License v1.3c" -licenseName MakeIndex = "MakeIndex License" -licenseName MirOS = "The MirOS Licence" -licenseName MIT_0 = "MIT No Attribution" -licenseName MIT_advertising = "Enlightenment License (e16)" -licenseName MIT_CMU = "CMU License" -licenseName MIT_enna = "enna License" -licenseName MIT_feh = "feh License" -licenseName MITNFA = "MIT +no-false-attribs license" -licenseName MIT = "MIT License" -licenseName Motosoto = "Motosoto License" -licenseName Mpich2 = "mpich2 License" -licenseName MPL_1_0 = "Mozilla Public License 1.0" -licenseName MPL_1_1 = "Mozilla Public License 1.1" -licenseName MPL_2_0_no_copyleft_exception = "Mozilla Public License 2.0 (no copyleft exception)" -licenseName MPL_2_0 = "Mozilla Public License 2.0" -licenseName MS_PL = "Microsoft Public License" -licenseName MS_RL = "Microsoft Reciprocal License" -licenseName MTLL = "Matrix Template Library License" -licenseName MulanPSL_1_0 = "Mulan Permissive Software License, Version 1" -licenseName MulanPSL_2_0 = "Mulan Permissive Software License, Version 2" -licenseName Multics = "Multics License" -licenseName Mup = "Mup License" -licenseName NASA_1_3 = "NASA Open Source Agreement 1.3" -licenseName Naumen = "Naumen Public License" -licenseName NBPL_1_0 = "Net Boolean Public License v1" -licenseName NCGL_UK_2_0 = "Non-Commercial Government Licence" -licenseName NCSA = "University of Illinois/NCSA Open Source License" -licenseName Net_SNMP = "Net-SNMP License" -licenseName NetCDF = "NetCDF license" -licenseName Newsletr = "Newsletr License" -licenseName NGPL = "Nethack General Public License" -licenseName NIST_PD_fallback = "NIST Public Domain Notice with license fallback" -licenseName NIST_PD = "NIST Public Domain Notice" -licenseName NLOD_1_0 = "Norwegian Licence for Open Government Data" -licenseName NLPL = "No Limit Public License" -licenseName Nokia = "Nokia Open Source License" -licenseName NOSL = "Netizen Open Source License" -licenseName Noweb = "Noweb License" -licenseName NPL_1_0 = "Netscape Public License v1.0" -licenseName NPL_1_1 = "Netscape Public License v1.1" -licenseName NPOSL_3_0 = "Non-Profit Open Software License 3.0" -licenseName NRL = "NRL License" -licenseName NTP_0 = "NTP No Attribution" -licenseName NTP = "NTP License" -licenseName O_UDA_1_0 = "Open Use of Data Agreement v1.0" -licenseName OCCT_PL = "Open CASCADE Technology Public License" -licenseName OCLC_2_0 = "OCLC Research Public License 2.0" -licenseName ODbL_1_0 = "ODC Open Database License v1.0" -licenseName ODC_By_1_0 = "Open Data Commons Attribution License v1.0" -licenseName OFL_1_0_no_RFN = "SIL Open Font License 1.0 with no Reserved Font Name" -licenseName OFL_1_0_RFN = "SIL Open Font License 1.0 with Reserved Font Name" -licenseName OFL_1_0 = "SIL Open Font License 1.0" -licenseName OFL_1_1_no_RFN = "SIL Open Font License 1.1 with no Reserved Font Name" -licenseName OFL_1_1_RFN = "SIL Open Font License 1.1 with Reserved Font Name" -licenseName OFL_1_1 = "SIL Open Font License 1.1" -licenseName OGC_1_0 = "OGC Software License, Version 1.0" -licenseName OGL_Canada_2_0 = "Open Government Licence - Canada" -licenseName OGL_UK_1_0 = "Open Government Licence v1.0" -licenseName OGL_UK_2_0 = "Open Government Licence v2.0" -licenseName OGL_UK_3_0 = "Open Government Licence v3.0" -licenseName OGTSL = "Open Group Test Suite License" -licenseName OLDAP_1_1 = "Open LDAP Public License v1.1" -licenseName OLDAP_1_2 = "Open LDAP Public License v1.2" -licenseName OLDAP_1_3 = "Open LDAP Public License v1.3" -licenseName OLDAP_1_4 = "Open LDAP Public License v1.4" -licenseName OLDAP_2_0_1 = "Open LDAP Public License v2.0.1" -licenseName OLDAP_2_0 = "Open LDAP Public License v2.0 (or possibly 2.0A and 2.0B)" -licenseName OLDAP_2_1 = "Open LDAP Public License v2.1" -licenseName OLDAP_2_2_1 = "Open LDAP Public License v2.2.1" -licenseName OLDAP_2_2_2 = "Open LDAP Public License 2.2.2" -licenseName OLDAP_2_2 = "Open LDAP Public License v2.2" -licenseName OLDAP_2_3 = "Open LDAP Public License v2.3" -licenseName OLDAP_2_4 = "Open LDAP Public License v2.4" -licenseName OLDAP_2_5 = "Open LDAP Public License v2.5" -licenseName OLDAP_2_6 = "Open LDAP Public License v2.6" -licenseName OLDAP_2_7 = "Open LDAP Public License v2.7" -licenseName OLDAP_2_8 = "Open LDAP Public License v2.8" -licenseName OML = "Open Market License" -licenseName OpenSSL = "OpenSSL License" -licenseName OPL_1_0 = "Open Public License v1.0" -licenseName OSET_PL_2_1 = "OSET Public License version 2.1" -licenseName OSL_1_0 = "Open Software License 1.0" -licenseName OSL_1_1 = "Open Software License 1.1" -licenseName OSL_2_0 = "Open Software License 2.0" -licenseName OSL_2_1 = "Open Software License 2.1" -licenseName OSL_3_0 = "Open Software License 3.0" -licenseName Parity_6_0_0 = "The Parity Public License 6.0.0" -licenseName Parity_7_0_0 = "The Parity Public License 7.0.0" -licenseName PDDL_1_0 = "ODC Public Domain Dedication & License 1.0" -licenseName PHP_3_01 = "PHP License v3.01" -licenseName PHP_3_0 = "PHP License v3.0" -licenseName Plexus = "Plexus Classworlds License" -licenseName PolyForm_Noncommercial_1_0_0 = "PolyForm Noncommercial License 1.0.0" -licenseName PolyForm_Small_Business_1_0_0 = "PolyForm Small Business License 1.0.0" -licenseName PostgreSQL = "PostgreSQL License" -licenseName PSF_2_0 = "Python Software Foundation License 2.0" -licenseName Psfrag = "psfrag License" -licenseName Psutils = "psutils License" -licenseName Python_2_0 = "Python License 2.0" -licenseName Qhull = "Qhull License" -licenseName QPL_1_0 = "Q Public License 1.0" -licenseName Rdisc = "Rdisc License" -licenseName RHeCos_1_1 = "Red Hat eCos Public License v1.1" -licenseName RPL_1_1 = "Reciprocal Public License 1.1" -licenseName RPL_1_5 = "Reciprocal Public License 1.5" -licenseName RPSL_1_0 = "RealNetworks Public Source License v1.0" -licenseName RSA_MD = "RSA Message-Digest License" -licenseName RSCPL = "Ricoh Source Code Public License" -licenseName Ruby = "Ruby License" -licenseName SAX_PD = "Sax Public Domain Notice" -licenseName Saxpath = "Saxpath License" -licenseName SCEA = "SCEA Shared Source License" -licenseName Sendmail_8_23 = "Sendmail License 8.23" -licenseName Sendmail = "Sendmail License" -licenseName SGI_B_1_0 = "SGI Free Software License B v1.0" -licenseName SGI_B_1_1 = "SGI Free Software License B v1.1" -licenseName SGI_B_2_0 = "SGI Free Software License B v2.0" -licenseName SHL_0_51 = "Solderpad Hardware License, Version 0.51" -licenseName SHL_0_5 = "Solderpad Hardware License v0.5" -licenseName SimPL_2_0 = "Simple Public License 2.0" -licenseName SISSL_1_2 = "Sun Industry Standards Source License v1.2" -licenseName SISSL = "Sun Industry Standards Source License v1.1" -licenseName Sleepycat = "Sleepycat License" -licenseName SMLNJ = "Standard ML of New Jersey License" -licenseName SMPPL = "Secure Messaging Protocol Public License" -licenseName SNIA = "SNIA Public License 1.1" -licenseName Spencer_86 = "Spencer License 86" -licenseName Spencer_94 = "Spencer License 94" -licenseName Spencer_99 = "Spencer License 99" -licenseName SPL_1_0 = "Sun Public License v1.0" -licenseName SSH_OpenSSH = "SSH OpenSSH license" -licenseName SSH_short = "SSH short notice" -licenseName SSPL_1_0 = "Server Side Public License, v 1" -licenseName SugarCRM_1_1_3 = "SugarCRM Public License v1.1.3" -licenseName SWL = "Scheme Widget Library (SWL) Software License Agreement" -licenseName TAPR_OHL_1_0 = "TAPR Open Hardware License v1.0" -licenseName TCL = "TCL/TK License" -licenseName TCP_wrappers = "TCP Wrappers License" -licenseName TMate = "TMate Open Source License" -licenseName TORQUE_1_1 = "TORQUE v2.5+ Software License v1.1" -licenseName TOSL = "Trusster Open Source License" -licenseName TU_Berlin_1_0 = "Technische Universitaet Berlin License 1.0" -licenseName TU_Berlin_2_0 = "Technische Universitaet Berlin License 2.0" -licenseName UCL_1_0 = "Upstream Compatibility License v1.0" -licenseName Unicode_DFS_2015 = "Unicode License Agreement - Data Files and Software (2015)" -licenseName Unicode_DFS_2016 = "Unicode License Agreement - Data Files and Software (2016)" -licenseName Unicode_TOU = "Unicode Terms of Use" -licenseName Unlicense = "The Unlicense" -licenseName UPL_1_0 = "Universal Permissive License v1.0" -licenseName Vim = "Vim License" -licenseName VOSTROM = "VOSTROM Public License for Open Source" -licenseName VSL_1_0 = "Vovida Software License v1.0" -licenseName W3C_19980720 = "W3C Software Notice and License (1998-07-20)" -licenseName W3C_20150513 = "W3C Software Notice and Document License (2015-05-13)" -licenseName W3C = "W3C Software Notice and License (2002-12-31)" -licenseName Watcom_1_0 = "Sybase Open Watcom Public License 1.0" -licenseName Wsuipa = "Wsuipa License" -licenseName WTFPL = "Do What The F*ck You Want To Public License" -licenseName X11 = "X11 License" -licenseName Xerox = "Xerox License" -licenseName XFree86_1_1 = "XFree86 License 1.1" -licenseName Xinetd = "xinetd License" -licenseName Xnet = "X.Net License" -licenseName Xpp = "XPP License" -licenseName XSkat = "XSkat License" -licenseName YPL_1_0 = "Yahoo! Public License v1.0" -licenseName YPL_1_1 = "Yahoo! Public License v1.1" -licenseName Zed = "Zed License" -licenseName Zend_2_0 = "Zend License v2.0" -licenseName Zimbra_1_3 = "Zimbra Public License v1.3" -licenseName Zimbra_1_4 = "Zimbra Public License v1.4" -licenseName Zlib_acknowledgement = "zlib/libpng License with Acknowledgement" -licenseName Zlib = "zlib License" -licenseName ZPL_1_1 = "Zope Public License 1.1" -licenseName ZPL_2_0 = "Zope Public License 2.0" -licenseName ZPL_2_1 = "Zope Public License 2.1" - --- | Whether the license is approved by Open Source Initiative (OSI). --- --- See . -licenseIsOsiApproved :: LicenseId -> Bool -licenseIsOsiApproved NullBSD = True -licenseIsOsiApproved AAL = True -licenseIsOsiApproved AFL_1_1 = True -licenseIsOsiApproved AFL_1_2 = True -licenseIsOsiApproved AFL_2_0 = True -licenseIsOsiApproved AFL_2_1 = True -licenseIsOsiApproved AFL_3_0 = True -licenseIsOsiApproved AGPL_3_0_only = True -licenseIsOsiApproved AGPL_3_0_or_later = True -licenseIsOsiApproved Apache_1_1 = True -licenseIsOsiApproved Apache_2_0 = True -licenseIsOsiApproved APL_1_0 = True -licenseIsOsiApproved APSL_1_0 = True -licenseIsOsiApproved APSL_1_1 = True -licenseIsOsiApproved APSL_1_2 = True -licenseIsOsiApproved APSL_2_0 = True -licenseIsOsiApproved Artistic_1_0_cl8 = True -licenseIsOsiApproved Artistic_1_0_Perl = True -licenseIsOsiApproved Artistic_1_0 = True -licenseIsOsiApproved Artistic_2_0 = True -licenseIsOsiApproved BSD_1_Clause = True -licenseIsOsiApproved BSD_2_Clause_Patent = True -licenseIsOsiApproved BSD_2_Clause = True -licenseIsOsiApproved BSD_3_Clause_LBNL = True -licenseIsOsiApproved BSD_3_Clause = True -licenseIsOsiApproved BSL_1_0 = True -licenseIsOsiApproved CAL_1_0_Combined_Work_Exception = True -licenseIsOsiApproved CAL_1_0 = True -licenseIsOsiApproved CATOSL_1_1 = True -licenseIsOsiApproved CDDL_1_0 = True -licenseIsOsiApproved CECILL_2_1 = True -licenseIsOsiApproved CNRI_Python = True -licenseIsOsiApproved CPAL_1_0 = True -licenseIsOsiApproved CPL_1_0 = True -licenseIsOsiApproved CUA_OPL_1_0 = True -licenseIsOsiApproved ECL_1_0 = True -licenseIsOsiApproved ECL_2_0 = True -licenseIsOsiApproved EFL_1_0 = True -licenseIsOsiApproved EFL_2_0 = True -licenseIsOsiApproved Entessa = True -licenseIsOsiApproved EPL_1_0 = True -licenseIsOsiApproved EPL_2_0 = True -licenseIsOsiApproved EUDatagrid = True -licenseIsOsiApproved EUPL_1_1 = True -licenseIsOsiApproved EUPL_1_2 = True -licenseIsOsiApproved Fair = True -licenseIsOsiApproved Frameworx_1_0 = True -licenseIsOsiApproved GPL_2_0_only = True -licenseIsOsiApproved GPL_2_0_or_later = True -licenseIsOsiApproved GPL_3_0_only = True -licenseIsOsiApproved GPL_3_0_or_later = True -licenseIsOsiApproved HPND = True -licenseIsOsiApproved Intel = True -licenseIsOsiApproved IPA = True -licenseIsOsiApproved IPL_1_0 = True -licenseIsOsiApproved ISC = True -licenseIsOsiApproved LGPL_2_0_only = True -licenseIsOsiApproved LGPL_2_0_or_later = True -licenseIsOsiApproved LGPL_2_1_only = True -licenseIsOsiApproved LGPL_2_1_or_later = True -licenseIsOsiApproved LGPL_3_0_only = True -licenseIsOsiApproved LGPL_3_0_or_later = True -licenseIsOsiApproved LiLiQ_P_1_1 = True -licenseIsOsiApproved LiLiQ_R_1_1 = True -licenseIsOsiApproved LiLiQ_Rplus_1_1 = True -licenseIsOsiApproved LPL_1_02 = True -licenseIsOsiApproved LPL_1_0 = True -licenseIsOsiApproved LPPL_1_3c = True -licenseIsOsiApproved MirOS = True -licenseIsOsiApproved MIT = True -licenseIsOsiApproved Motosoto = True -licenseIsOsiApproved MPL_1_0 = True -licenseIsOsiApproved MPL_1_1 = True -licenseIsOsiApproved MPL_2_0_no_copyleft_exception = True -licenseIsOsiApproved MPL_2_0 = True -licenseIsOsiApproved MS_PL = True -licenseIsOsiApproved MS_RL = True -licenseIsOsiApproved MulanPSL_2_0 = True -licenseIsOsiApproved Multics = True -licenseIsOsiApproved NASA_1_3 = True -licenseIsOsiApproved Naumen = True -licenseIsOsiApproved NCSA = True -licenseIsOsiApproved NGPL = True -licenseIsOsiApproved Nokia = True -licenseIsOsiApproved NPOSL_3_0 = True -licenseIsOsiApproved NTP = True -licenseIsOsiApproved OCLC_2_0 = True -licenseIsOsiApproved OFL_1_1_no_RFN = True -licenseIsOsiApproved OFL_1_1_RFN = True -licenseIsOsiApproved OFL_1_1 = True -licenseIsOsiApproved OGTSL = True -licenseIsOsiApproved OSET_PL_2_1 = True -licenseIsOsiApproved OSL_1_0 = True -licenseIsOsiApproved OSL_2_0 = True -licenseIsOsiApproved OSL_2_1 = True -licenseIsOsiApproved OSL_3_0 = True -licenseIsOsiApproved PHP_3_01 = True -licenseIsOsiApproved PHP_3_0 = True -licenseIsOsiApproved PostgreSQL = True -licenseIsOsiApproved Python_2_0 = True -licenseIsOsiApproved QPL_1_0 = True -licenseIsOsiApproved RPL_1_1 = True -licenseIsOsiApproved RPL_1_5 = True -licenseIsOsiApproved RPSL_1_0 = True -licenseIsOsiApproved RSCPL = True -licenseIsOsiApproved SimPL_2_0 = True -licenseIsOsiApproved SISSL = True -licenseIsOsiApproved Sleepycat = True -licenseIsOsiApproved SPL_1_0 = True -licenseIsOsiApproved UCL_1_0 = True -licenseIsOsiApproved Unlicense = True -licenseIsOsiApproved UPL_1_0 = True -licenseIsOsiApproved VSL_1_0 = True -licenseIsOsiApproved W3C = True -licenseIsOsiApproved Watcom_1_0 = True -licenseIsOsiApproved Xnet = True -licenseIsOsiApproved Zlib = True -licenseIsOsiApproved ZPL_2_0 = True -licenseIsOsiApproved _ = False - --- | Whether the license is considered libre by Free Software Foundation (FSF). --- --- See --- --- @since 3.4.0.0 --- -licenseIsFsfLibre :: LicenseId -> Bool -licenseIsFsfLibre AFL_1_1 = True -licenseIsFsfLibre AFL_1_2 = True -licenseIsFsfLibre AFL_2_0 = True -licenseIsFsfLibre AFL_2_1 = True -licenseIsFsfLibre AFL_3_0 = True -licenseIsFsfLibre AGPL_1_0 = True -licenseIsFsfLibre AGPL_3_0_only = True -licenseIsFsfLibre AGPL_3_0_or_later = True -licenseIsFsfLibre Apache_1_0 = True -licenseIsFsfLibre Apache_1_1 = True -licenseIsFsfLibre Apache_2_0 = True -licenseIsFsfLibre APSL_2_0 = True -licenseIsFsfLibre Artistic_2_0 = True -licenseIsFsfLibre BitTorrent_1_1 = True -licenseIsFsfLibre BSD_2_Clause_FreeBSD = True -licenseIsFsfLibre BSD_3_Clause_Clear = True -licenseIsFsfLibre BSD_3_Clause = True -licenseIsFsfLibre BSD_4_Clause = True -licenseIsFsfLibre BSL_1_0 = True -licenseIsFsfLibre CC_BY_4_0 = True -licenseIsFsfLibre CC_BY_SA_4_0 = True -licenseIsFsfLibre CC0_1_0 = True -licenseIsFsfLibre CDDL_1_0 = True -licenseIsFsfLibre CECILL_2_0 = True -licenseIsFsfLibre CECILL_B = True -licenseIsFsfLibre CECILL_C = True -licenseIsFsfLibre ClArtistic = True -licenseIsFsfLibre Condor_1_1 = True -licenseIsFsfLibre CPAL_1_0 = True -licenseIsFsfLibre CPL_1_0 = True -licenseIsFsfLibre ECL_2_0 = True -licenseIsFsfLibre EFL_2_0 = True -licenseIsFsfLibre EPL_1_0 = True -licenseIsFsfLibre EPL_2_0 = True -licenseIsFsfLibre EUDatagrid = True -licenseIsFsfLibre EUPL_1_1 = True -licenseIsFsfLibre EUPL_1_2 = True -licenseIsFsfLibre FSFAP = True -licenseIsFsfLibre FTL = True -licenseIsFsfLibre GFDL_1_1_only = True -licenseIsFsfLibre GFDL_1_1_or_later = True -licenseIsFsfLibre GFDL_1_2_only = True -licenseIsFsfLibre GFDL_1_2_or_later = True -licenseIsFsfLibre GFDL_1_3_only = True -licenseIsFsfLibre GFDL_1_3_or_later = True -licenseIsFsfLibre Gnuplot = True -licenseIsFsfLibre GPL_2_0_only = True -licenseIsFsfLibre GPL_2_0_or_later = True -licenseIsFsfLibre GPL_3_0_only = True -licenseIsFsfLibre GPL_3_0_or_later = True -licenseIsFsfLibre HPND = True -licenseIsFsfLibre IJG = True -licenseIsFsfLibre IMatix = True -licenseIsFsfLibre Imlib2 = True -licenseIsFsfLibre Intel = True -licenseIsFsfLibre IPA = True -licenseIsFsfLibre IPL_1_0 = True -licenseIsFsfLibre ISC = True -licenseIsFsfLibre LGPL_2_1_only = True -licenseIsFsfLibre LGPL_2_1_or_later = True -licenseIsFsfLibre LGPL_3_0_only = True -licenseIsFsfLibre LGPL_3_0_or_later = True -licenseIsFsfLibre LPL_1_02 = True -licenseIsFsfLibre LPPL_1_2 = True -licenseIsFsfLibre LPPL_1_3a = True -licenseIsFsfLibre MIT = True -licenseIsFsfLibre MPL_1_1 = True -licenseIsFsfLibre MPL_2_0 = True -licenseIsFsfLibre MS_PL = True -licenseIsFsfLibre MS_RL = True -licenseIsFsfLibre NCSA = True -licenseIsFsfLibre Nokia = True -licenseIsFsfLibre NOSL = True -licenseIsFsfLibre NPL_1_0 = True -licenseIsFsfLibre NPL_1_1 = True -licenseIsFsfLibre ODbL_1_0 = True -licenseIsFsfLibre OFL_1_0 = True -licenseIsFsfLibre OFL_1_1 = True -licenseIsFsfLibre OLDAP_2_3 = True -licenseIsFsfLibre OLDAP_2_7 = True -licenseIsFsfLibre OpenSSL = True -licenseIsFsfLibre OSL_1_0 = True -licenseIsFsfLibre OSL_1_1 = True -licenseIsFsfLibre OSL_2_0 = True -licenseIsFsfLibre OSL_2_1 = True -licenseIsFsfLibre OSL_3_0 = True -licenseIsFsfLibre PHP_3_01 = True -licenseIsFsfLibre Python_2_0 = True -licenseIsFsfLibre QPL_1_0 = True -licenseIsFsfLibre RPSL_1_0 = True -licenseIsFsfLibre Ruby = True -licenseIsFsfLibre SGI_B_2_0 = True -licenseIsFsfLibre SISSL = True -licenseIsFsfLibre Sleepycat = True -licenseIsFsfLibre SMLNJ = True -licenseIsFsfLibre SPL_1_0 = True -licenseIsFsfLibre Unlicense = True -licenseIsFsfLibre UPL_1_0 = True -licenseIsFsfLibre Vim = True -licenseIsFsfLibre W3C = True -licenseIsFsfLibre WTFPL = True -licenseIsFsfLibre X11 = True -licenseIsFsfLibre XFree86_1_1 = True -licenseIsFsfLibre Xinetd = True -licenseIsFsfLibre YPL_1_1 = True -licenseIsFsfLibre Zend_2_0 = True -licenseIsFsfLibre Zimbra_1_3 = True -licenseIsFsfLibre Zlib = True -licenseIsFsfLibre ZPL_2_0 = True -licenseIsFsfLibre ZPL_2_1 = True -licenseIsFsfLibre _ = False - -------------------------------------------------------------------------------- --- Creation -------------------------------------------------------------------------------- - -licenseIdList :: LicenseListVersion -> [LicenseId] -licenseIdList LicenseListVersion_3_0 = - [ AGPL_1_0 - , BSD_2_Clause_FreeBSD - , BSD_2_Clause_NetBSD - ] - ++ bulkOfLicenses -licenseIdList LicenseListVersion_3_2 = - [ AGPL_1_0_only - , AGPL_1_0_or_later - , BSD_2_Clause_FreeBSD - , BSD_2_Clause_NetBSD - , Linux_OpenIB - , MIT_0 - , ODC_By_1_0 - , TU_Berlin_1_0 - , TU_Berlin_2_0 - ] - ++ bulkOfLicenses -licenseIdList LicenseListVersion_3_6 = - [ AGPL_1_0_only - , AGPL_1_0_or_later - , Blessing - , BlueOak_1_0_0 - , BSD_2_Clause_FreeBSD - , BSD_2_Clause_NetBSD - , BSD_3_Clause_Open_MPI - , CC_PDDC - , CERN_OHL_1_1 - , CERN_OHL_1_2 - , Copyleft_next_0_3_0 - , Copyleft_next_0_3_1 - , HPND_sell_variant - , JPNIC - , Libpng_2_0 - , Linux_OpenIB - , MIT_0 - , ODC_By_1_0 - , OGL_UK_1_0 - , OGL_UK_2_0 - , OGL_UK_3_0 - , Parity_6_0_0 - , Sendmail_8_23 - , SHL_0_51 - , SHL_0_5 - , SSPL_1_0 - , TAPR_OHL_1_0 - , TU_Berlin_1_0 - , TU_Berlin_2_0 - ] - ++ bulkOfLicenses -licenseIdList LicenseListVersion_3_9 = - [ AGPL_1_0_only - , AGPL_1_0_or_later - , Blessing - , BlueOak_1_0_0 - , BSD_2_Clause_FreeBSD - , BSD_3_Clause_Open_MPI - , CAL_1_0_Combined_Work_Exception - , CAL_1_0 - , CC_PDDC - , CERN_OHL_1_1 - , CERN_OHL_1_2 - , CERN_OHL_P_2_0 - , CERN_OHL_S_2_0 - , CERN_OHL_W_2_0 - , Copyleft_next_0_3_0 - , Copyleft_next_0_3_1 - , Etalab_2_0 - , Hippocratic_2_1 - , HPND_sell_variant - , JPNIC - , Libpng_2_0 - , Libselinux_1_0 - , Linux_OpenIB - , MIT_0 - , MulanPSL_1_0 - , MulanPSL_2_0 - , NCGL_UK_2_0 - , NTP_0 - , O_UDA_1_0 - , ODC_By_1_0 - , OFL_1_0_no_RFN - , OFL_1_0_RFN - , OFL_1_1_no_RFN - , OFL_1_1_RFN - , OGC_1_0 - , OGL_Canada_2_0 - , OGL_UK_1_0 - , OGL_UK_2_0 - , OGL_UK_3_0 - , Parity_6_0_0 - , Parity_7_0_0 - , PolyForm_Noncommercial_1_0_0 - , PolyForm_Small_Business_1_0_0 - , PSF_2_0 - , Sendmail_8_23 - , SHL_0_51 - , SHL_0_5 - , SSH_OpenSSH - , SSH_short - , SSPL_1_0 - , TAPR_OHL_1_0 - , TU_Berlin_1_0 - , TU_Berlin_2_0 - , UCL_1_0 - ] - ++ bulkOfLicenses -licenseIdList LicenseListVersion_3_10 = - [ AGPL_1_0_only - , AGPL_1_0_or_later - , Blessing - , BlueOak_1_0_0 - , BSD_2_Clause_FreeBSD - , BSD_3_Clause_Open_MPI - , CAL_1_0_Combined_Work_Exception - , CAL_1_0 - , CC_PDDC - , CERN_OHL_1_1 - , CERN_OHL_1_2 - , CERN_OHL_P_2_0 - , CERN_OHL_S_2_0 - , CERN_OHL_W_2_0 - , Copyleft_next_0_3_0 - , Copyleft_next_0_3_1 - , Etalab_2_0 - , Hippocratic_2_1 - , HPND_sell_variant - , JPNIC - , Libpng_2_0 - , Libselinux_1_0 - , Linux_OpenIB - , MIT_0 - , MulanPSL_1_0 - , MulanPSL_2_0 - , NCGL_UK_2_0 - , NTP_0 - , O_UDA_1_0 - , ODC_By_1_0 - , OFL_1_0_no_RFN - , OFL_1_0_RFN - , OFL_1_1_no_RFN - , OFL_1_1_RFN - , OGC_1_0 - , OGL_Canada_2_0 - , OGL_UK_1_0 - , OGL_UK_2_0 - , OGL_UK_3_0 - , Parity_6_0_0 - , Parity_7_0_0 - , PolyForm_Noncommercial_1_0_0 - , PolyForm_Small_Business_1_0_0 - , PSF_2_0 - , Sendmail_8_23 - , SHL_0_51 - , SHL_0_5 - , SSH_OpenSSH - , SSH_short - , SSPL_1_0 - , TAPR_OHL_1_0 - , TU_Berlin_1_0 - , TU_Berlin_2_0 - , UCL_1_0 - ] - ++ bulkOfLicenses - --- | Create a 'LicenseId' from a 'String'. -mkLicenseId :: LicenseListVersion -> String -> Maybe LicenseId -mkLicenseId LicenseListVersion_3_0 s = Map.lookup s stringLookup_3_0 -mkLicenseId LicenseListVersion_3_2 s = Map.lookup s stringLookup_3_2 -mkLicenseId LicenseListVersion_3_6 s = Map.lookup s stringLookup_3_6 -mkLicenseId LicenseListVersion_3_9 s = Map.lookup s stringLookup_3_9 -mkLicenseId LicenseListVersion_3_10 s = Map.lookup s stringLookup_3_10 - -stringLookup_3_0 :: Map String LicenseId -stringLookup_3_0 = Map.fromList $ map (\i -> (licenseId i, i)) $ - licenseIdList LicenseListVersion_3_0 - -stringLookup_3_2 :: Map String LicenseId -stringLookup_3_2 = Map.fromList $ map (\i -> (licenseId i, i)) $ - licenseIdList LicenseListVersion_3_2 - -stringLookup_3_6 :: Map String LicenseId -stringLookup_3_6 = Map.fromList $ map (\i -> (licenseId i, i)) $ - licenseIdList LicenseListVersion_3_6 - -stringLookup_3_9 :: Map String LicenseId -stringLookup_3_9 = Map.fromList $ map (\i -> (licenseId i, i)) $ - licenseIdList LicenseListVersion_3_9 - -stringLookup_3_10 :: Map String LicenseId -stringLookup_3_10 = Map.fromList $ map (\i -> (licenseId i, i)) $ - licenseIdList LicenseListVersion_3_10 - --- | Licenses in all SPDX License lists -bulkOfLicenses :: [LicenseId] -bulkOfLicenses = - [ NullBSD - , AAL - , Abstyles - , Adobe_2006 - , Adobe_Glyph - , ADSL - , AFL_1_1 - , AFL_1_2 - , AFL_2_0 - , AFL_2_1 - , AFL_3_0 - , Afmparse - , AGPL_3_0_only - , AGPL_3_0_or_later - , Aladdin - , AMDPLPA - , AML - , AMPAS - , ANTLR_PD - , Apache_1_0 - , Apache_1_1 - , Apache_2_0 - , APAFML - , APL_1_0 - , APSL_1_0 - , APSL_1_1 - , APSL_1_2 - , APSL_2_0 - , Artistic_1_0_cl8 - , Artistic_1_0_Perl - , Artistic_1_0 - , Artistic_2_0 - , Bahyph - , Barr - , Beerware - , BitTorrent_1_0 - , BitTorrent_1_1 - , Borceux - , BSD_1_Clause - , BSD_2_Clause_Patent - , BSD_2_Clause - , BSD_3_Clause_Attribution - , BSD_3_Clause_Clear - , BSD_3_Clause_LBNL - , BSD_3_Clause_No_Nuclear_License_2014 - , BSD_3_Clause_No_Nuclear_License - , BSD_3_Clause_No_Nuclear_Warranty - , BSD_3_Clause - , BSD_4_Clause_UC - , BSD_4_Clause - , BSD_Protection - , BSD_Source_Code - , BSL_1_0 - , Bzip2_1_0_5 - , Bzip2_1_0_6 - , Caldera - , CATOSL_1_1 - , CC_BY_1_0 - , CC_BY_2_0 - , CC_BY_2_5 - , CC_BY_3_0 - , CC_BY_4_0 - , CC_BY_NC_1_0 - , CC_BY_NC_2_0 - , CC_BY_NC_2_5 - , CC_BY_NC_3_0 - , CC_BY_NC_4_0 - , CC_BY_NC_ND_1_0 - , CC_BY_NC_ND_2_0 - , CC_BY_NC_ND_2_5 - , CC_BY_NC_ND_3_0 - , CC_BY_NC_ND_4_0 - , CC_BY_NC_SA_1_0 - , CC_BY_NC_SA_2_0 - , CC_BY_NC_SA_2_5 - , CC_BY_NC_SA_3_0 - , CC_BY_NC_SA_4_0 - , CC_BY_ND_1_0 - , CC_BY_ND_2_0 - , CC_BY_ND_2_5 - , CC_BY_ND_3_0 - , CC_BY_ND_4_0 - , CC_BY_SA_1_0 - , CC_BY_SA_2_0 - , CC_BY_SA_2_5 - , CC_BY_SA_3_0 - , CC_BY_SA_4_0 - , CC0_1_0 - , CDDL_1_0 - , CDDL_1_1 - , CDLA_Permissive_1_0 - , CDLA_Sharing_1_0 - , CECILL_1_0 - , CECILL_1_1 - , CECILL_2_0 - , CECILL_2_1 - , CECILL_B - , CECILL_C - , ClArtistic - , CNRI_Jython - , CNRI_Python_GPL_Compatible - , CNRI_Python - , Condor_1_1 - , CPAL_1_0 - , CPL_1_0 - , CPOL_1_02 - , Crossword - , CrystalStacker - , CUA_OPL_1_0 - , Cube - , Curl - , D_FSL_1_0 - , Diffmark - , DOC - , Dotseqn - , DSDP - , Dvipdfm - , ECL_1_0 - , ECL_2_0 - , EFL_1_0 - , EFL_2_0 - , EGenix - , Entessa - , EPL_1_0 - , EPL_2_0 - , ErlPL_1_1 - , EUDatagrid - , EUPL_1_0 - , EUPL_1_1 - , EUPL_1_2 - , Eurosym - , Fair - , Frameworx_1_0 - , FreeImage - , FSFAP - , FSFULLR - , FSFUL - , FTL - , GFDL_1_1_only - , GFDL_1_1_or_later - , GFDL_1_2_only - , GFDL_1_2_or_later - , GFDL_1_3_only - , GFDL_1_3_or_later - , Giftware - , GL2PS - , Glide - , Glulxe - , Gnuplot - , GPL_1_0_only - , GPL_1_0_or_later - , GPL_2_0_only - , GPL_2_0_or_later - , GPL_3_0_only - , GPL_3_0_or_later - , GSOAP_1_3b - , HaskellReport - , HPND - , IBM_pibs - , ICU - , IJG - , ImageMagick - , IMatix - , Imlib2 - , Info_ZIP - , Intel_ACPI - , Intel - , Interbase_1_0 - , IPA - , IPL_1_0 - , ISC - , JasPer_2_0 - , JSON - , LAL_1_2 - , LAL_1_3 - , Latex2e - , Leptonica - , LGPL_2_0_only - , LGPL_2_0_or_later - , LGPL_2_1_only - , LGPL_2_1_or_later - , LGPL_3_0_only - , LGPL_3_0_or_later - , LGPLLR - , Libpng - , Libtiff - , LiLiQ_P_1_1 - , LiLiQ_R_1_1 - , LiLiQ_Rplus_1_1 - , LPL_1_02 - , LPL_1_0 - , LPPL_1_0 - , LPPL_1_1 - , LPPL_1_2 - , LPPL_1_3a - , LPPL_1_3c - , MakeIndex - , MirOS - , MIT_advertising - , MIT_CMU - , MIT_enna - , MIT_feh - , MITNFA - , MIT - , Motosoto - , Mpich2 - , MPL_1_0 - , MPL_1_1 - , MPL_2_0_no_copyleft_exception - , MPL_2_0 - , MS_PL - , MS_RL - , MTLL - , Multics - , Mup - , NASA_1_3 - , Naumen - , NBPL_1_0 - , NCSA - , Net_SNMP - , NetCDF - , Newsletr - , NGPL - , NLOD_1_0 - , NLPL - , Nokia - , NOSL - , Noweb - , NPL_1_0 - , NPL_1_1 - , NPOSL_3_0 - , NRL - , NTP - , OCCT_PL - , OCLC_2_0 - , ODbL_1_0 - , OFL_1_0 - , OFL_1_1 - , OGTSL - , OLDAP_1_1 - , OLDAP_1_2 - , OLDAP_1_3 - , OLDAP_1_4 - , OLDAP_2_0_1 - , OLDAP_2_0 - , OLDAP_2_1 - , OLDAP_2_2_1 - , OLDAP_2_2_2 - , OLDAP_2_2 - , OLDAP_2_3 - , OLDAP_2_4 - , OLDAP_2_5 - , OLDAP_2_6 - , OLDAP_2_7 - , OLDAP_2_8 - , OML - , OpenSSL - , OPL_1_0 - , OSET_PL_2_1 - , OSL_1_0 - , OSL_1_1 - , OSL_2_0 - , OSL_2_1 - , OSL_3_0 - , PDDL_1_0 - , PHP_3_01 - , PHP_3_0 - , Plexus - , PostgreSQL - , Psfrag - , Psutils - , Python_2_0 - , Qhull - , QPL_1_0 - , Rdisc - , RHeCos_1_1 - , RPL_1_1 - , RPL_1_5 - , RPSL_1_0 - , RSA_MD - , RSCPL - , Ruby - , SAX_PD - , Saxpath - , SCEA - , Sendmail - , SGI_B_1_0 - , SGI_B_1_1 - , SGI_B_2_0 - , SimPL_2_0 - , SISSL_1_2 - , SISSL - , Sleepycat - , SMLNJ - , SMPPL - , SNIA - , Spencer_86 - , Spencer_94 - , Spencer_99 - , SPL_1_0 - , SugarCRM_1_1_3 - , SWL - , TCL - , TCP_wrappers - , TMate - , TORQUE_1_1 - , TOSL - , Unicode_DFS_2015 - , Unicode_DFS_2016 - , Unicode_TOU - , Unlicense - , UPL_1_0 - , Vim - , VOSTROM - , VSL_1_0 - , W3C_19980720 - , W3C_20150513 - , W3C - , Watcom_1_0 - , Wsuipa - , WTFPL - , X11 - , Xerox - , XFree86_1_1 - , Xinetd - , Xnet - , Xpp - , XSkat - , YPL_1_0 - , YPL_1_1 - , Zed - , Zend_2_0 - , Zimbra_1_3 - , Zimbra_1_4 - , Zlib_acknowledgement - , Zlib - , ZPL_1_1 - , ZPL_2_0 - , ZPL_2_1 - ] diff --git a/src/Distribution/SPDX/LicenseListVersion.hs b/src/Distribution/SPDX/LicenseListVersion.hs deleted file mode 100644 --- a/src/Distribution/SPDX/LicenseListVersion.hs +++ /dev/null @@ -1,22 +0,0 @@ -module Distribution.SPDX.LicenseListVersion ( - LicenseListVersion (..), - cabalSpecVersionToSPDXListVersion, - ) where - -import Distribution.CabalSpecVersion - --- | SPDX License List version @Cabal@ is aware of. -data LicenseListVersion - = LicenseListVersion_3_0 - | LicenseListVersion_3_2 - | LicenseListVersion_3_6 - | LicenseListVersion_3_9 - | LicenseListVersion_3_10 - deriving (Eq, Ord, Show, Enum, Bounded) - -cabalSpecVersionToSPDXListVersion :: CabalSpecVersion -> LicenseListVersion -cabalSpecVersionToSPDXListVersion CabalSpecV3_6 = LicenseListVersion_3_10 -cabalSpecVersionToSPDXListVersion CabalSpecV3_4 = LicenseListVersion_3_9 -cabalSpecVersionToSPDXListVersion CabalSpecV3_0 = LicenseListVersion_3_6 -cabalSpecVersionToSPDXListVersion CabalSpecV2_4 = LicenseListVersion_3_2 -cabalSpecVersionToSPDXListVersion _ = LicenseListVersion_3_0 diff --git a/src/Distribution/SPDX/LicenseReference.hs b/src/Distribution/SPDX/LicenseReference.hs deleted file mode 100644 --- a/src/Distribution/SPDX/LicenseReference.hs +++ /dev/null @@ -1,80 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -module Distribution.SPDX.LicenseReference ( - LicenseRef, - licenseRef, - licenseDocumentRef, - mkLicenseRef, - mkLicenseRef', - ) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Utils.Generic (isAsciiAlphaNum) -import Distribution.Pretty -import Distribution.Parsec - -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp - --- | A user defined license reference denoted by @LicenseRef-[idstring]@ (for a license not on the SPDX License List); -data LicenseRef = LicenseRef - { _lrDocument :: !(Maybe String) - , _lrLicense :: !String - } - deriving (Show, Read, Eq, Ord, Typeable, Data, Generic) - --- | License reference. -licenseRef :: LicenseRef -> String -licenseRef = _lrLicense - --- | Document reference. -licenseDocumentRef :: LicenseRef -> Maybe String -licenseDocumentRef = _lrDocument - -instance Binary LicenseRef -instance Structured LicenseRef - -instance NFData LicenseRef where - rnf (LicenseRef d l) = rnf d `seq` rnf l - -instance Pretty LicenseRef where - pretty (LicenseRef Nothing l) = Disp.text "LicenseRef-" <<>> Disp.text l - pretty (LicenseRef (Just d) l) = - Disp.text "DocumentRef-" <<>> Disp.text d <<>> Disp.char ':' <<>> Disp.text "LicenseRef-" <<>> Disp.text l - -instance Parsec LicenseRef where - parsec = name <|> doc - where - name = do - _ <- P.string "LicenseRef-" - n <- some $ P.satisfy $ \c -> isAsciiAlphaNum c || c == '-' || c == '.' - pure (LicenseRef Nothing n) - - doc = do - _ <- P.string "DocumentRef-" - d <- some $ P.satisfy $ \c -> isAsciiAlphaNum c || c == '-' || c == '.' - _ <- P.char ':' - _ <- P.string "LicenseRef-" - n <- some $ P.satisfy $ \c -> isAsciiAlphaNum c || c == '-' || c == '.' - pure (LicenseRef (Just d) n) - --- | Create 'LicenseRef' from optional document ref and name. -mkLicenseRef :: Maybe String -> String -> Maybe LicenseRef -mkLicenseRef d l = do - d' <- traverse checkIdString d - l' <- checkIdString l - pure (LicenseRef d' l') - where - checkIdString s - | all (\c -> isAsciiAlphaNum c || c == '-' || c == '.') s = Just s - | otherwise = Nothing - --- | Like 'mkLicenseRef' but convert invalid characters into @-@. -mkLicenseRef' :: Maybe String -> String -> LicenseRef -mkLicenseRef' d l = LicenseRef (fmap f d) (f l) - where - f = map g - g c | isAsciiAlphaNum c || c == '-' || c == '.' = c - | otherwise = '-' diff --git a/src/Distribution/Simple.hs b/src/Distribution/Simple.hs --- a/src/Distribution/Simple.hs +++ b/src/Distribution/Simple.hs @@ -67,6 +67,7 @@ import Distribution.Package import Distribution.PackageDescription import Distribution.PackageDescription.Configuration +import Distribution.Simple.PackageDescription import Distribution.Simple.Program import Distribution.Simple.Program.Db import Distribution.Simple.PreProcess @@ -110,7 +111,6 @@ import Data.List (unionBy, (\\)) -import Distribution.PackageDescription.Parsec -- | A simple implementation of @main@ for a Cabal setup script. -- It reads the package description file using IO, and performs the @@ -182,7 +182,6 @@ [configureCommand progs `commandAddAction` \fs as -> configureAction hooks fs as >> return () ,buildCommand progs `commandAddAction` buildAction hooks - ,showBuildInfoCommand progs `commandAddAction` showBuildInfoAction hooks ,replCommand progs `commandAddAction` replAction hooks ,installCommand `commandAddAction` installAction hooks ,copyCommand `commandAddAction` copyAction hooks @@ -266,33 +265,6 @@ hookedAction verbosity preBuild buildHook postBuild (return lbi { withPrograms = progs }) hooks flags' { buildArgs = args } args - -showBuildInfoAction :: UserHooks -> ShowBuildInfoFlags -> Args -> IO () -showBuildInfoAction hooks (ShowBuildInfoFlags flags fileOutput) args = do - distPref <- findDistPrefOrDefault (buildDistPref flags) - let verbosity = fromFlag $ buildVerbosity flags - lbi <- getBuildConfig hooks verbosity distPref - let flags' = flags { buildDistPref = toFlag distPref - , buildCabalFilePath = maybeToFlag (cabalFilePath lbi) - } - - progs <- reconfigurePrograms verbosity - (buildProgramPaths flags') - (buildProgramArgs flags') - (withPrograms lbi) - - pbi <- preBuild hooks args flags' - let lbi' = lbi { withPrograms = progs } - pkg_descr0 = localPkgDescr lbi' - pkg_descr = updatePackageDescription pbi pkg_descr0 - -- TODO: Somehow don't ignore build hook? - buildInfoString <- showBuildInfo pkg_descr lbi' flags - - case fileOutput of - Nothing -> putStr buildInfoString - Just fp -> writeFile fp buildInfoString - - postBuild hooks args flags' pkg_descr lbi' replAction :: UserHooks -> ReplFlags -> Args -> IO () replAction hooks flags args = do diff --git a/src/Distribution/Simple/Bench.hs b/src/Distribution/Simple/Bench.hs --- a/src/Distribution/Simple/Bench.hs +++ b/src/Distribution/Simple/Bench.hs @@ -58,7 +58,7 @@ -- Check that the benchmark executable exists. exists <- doesFileExist cmd unless exists $ die' verbosity $ - "Error: Could not find benchmark program \"" + "Could not find benchmark program \"" ++ cmd ++ "\". Did you build the package first?" notice verbosity $ startMessage name diff --git a/src/Distribution/Simple/Build.hs b/src/Distribution/Simple/Build.hs --- a/src/Distribution/Simple/Build.hs +++ b/src/Distribution/Simple/Build.hs @@ -19,7 +19,7 @@ -- module Distribution.Simple.Build ( - build, showBuildInfo, repl, + build, repl, startInterpreter, initialBuildSteps, @@ -69,15 +69,17 @@ import Distribution.Simple.BuildToolDepends import Distribution.Simple.PreProcess import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.Program +import Distribution.Simple.Program.Builtin (haskellSuiteProgram) +import qualified Distribution.Simple.Program.GHC as GHC import Distribution.Simple.Program.Types -import Distribution.Simple.Program.Db import Distribution.Simple.ShowBuildInfo import Distribution.Simple.BuildPaths import Distribution.Simple.Configure import Distribution.Simple.Register import Distribution.Simple.Test.LibV09 import Distribution.Simple.Utils -import Distribution.Simple.Utils.Json +import Distribution.Utils.Json import Distribution.System import Distribution.Pretty @@ -88,8 +90,9 @@ import Control.Monad import qualified Data.Set as Set +import qualified Data.ByteString.Lazy as LBS import System.FilePath ( (), (<.>), takeDirectory ) -import System.Directory ( getCurrentDirectory ) +import System.Directory ( getCurrentDirectory, removeFile, doesFileExist ) -- ----------------------------------------------------------------------------- -- |Build the libraries and executables in this package. @@ -113,6 +116,12 @@ internalPackageDB <- createInternalPackageDB verbosity lbi distPref + -- Before the actual building, dump out build-information. + -- This way, if the actual compilation failed, the options have still been + -- dumped. + dumpBuildInfo verbosity distPref (configDumpBuildInfo (configFlags lbi)) pkg_descr lbi flags + + -- Now do the actual building (\f -> foldM_ f (installedPkgs lbi) componentsToBuild) $ \index target -> do let comp = targetComponent target clbi = targetCLBI target @@ -127,24 +136,67 @@ mb_ipi <- buildComponent verbosity (buildNumJobs flags) pkg_descr lbi' suffixes comp clbi distPref return (maybe index (Index.insert `flip` index) mb_ipi) + return () where distPref = fromFlag (buildDistPref flags) verbosity = fromFlag (buildVerbosity flags) -showBuildInfo :: PackageDescription -- ^ Mostly information from the .cabal file - -> LocalBuildInfo -- ^ Configuration information - -> BuildFlags -- ^ Flags that the user passed to build - -> IO String -showBuildInfo pkg_descr lbi flags = do - let verbosity = fromFlag (buildVerbosity flags) - targets <- readTargetInfos verbosity pkg_descr lbi (buildArgs flags) - let targetsToBuild = neededTargetsInBuildOrder' pkg_descr lbi (map nodeKey targets) - doc = mkBuildInfo pkg_descr lbi flags targetsToBuild - return $ renderJson doc "" +-- | Write available build information for 'LocalBuildInfo' to disk. +-- +-- Dumps detailed build information 'build-info.json' to the given directory. +-- Build information contains basics such as compiler details, but also +-- lists what modules a component contains and how to compile the component, assuming +-- lib:Cabal made sure that dependencies are up-to-date. +dumpBuildInfo :: Verbosity + -> FilePath -- ^ To which directory should the build-info be dumped? + -> Flag DumpBuildInfo -- ^ Should we dump detailed build information for this component? + -> PackageDescription -- ^ Mostly information from the .cabal file + -> LocalBuildInfo -- ^ Configuration information + -> BuildFlags -- ^ Flags that the user passed to build + -> IO () +dumpBuildInfo verbosity distPref dumpBuildInfoFlag pkg_descr lbi flags = do + when shouldDumpBuildInfo $ do + -- Changing this line might break consumers of the dumped build info. + -- Announce changes on mailing lists! + let activeTargets = allTargetsInBuildOrder' pkg_descr lbi + info verbosity $ "Dump build information for: " + ++ intercalate ", " + (map (showComponentName . componentLocalName . targetCLBI) + activeTargets) + pwd <- getCurrentDirectory + (compilerProg, _) <- case flavorToProgram (compilerFlavor (compiler lbi)) of + Nothing -> die' verbosity $ "dumpBuildInfo: Unknown compiler flavor: " + ++ show (compilerFlavor (compiler lbi)) + Just program -> requireProgram verbosity program (withPrograms lbi) + let (warns, json) = mkBuildInfo pwd pkg_descr lbi flags (compilerProg, compiler lbi) activeTargets + buildInfoText = renderJson json + unless (null warns) $ + warn verbosity $ "Encountered warnings while dumping build-info:\n" + ++ unlines warns + LBS.writeFile (buildInfoPref distPref) buildInfoText + + when (not shouldDumpBuildInfo) $ do + -- Remove existing build-info.json as it might be outdated now. + exists <- doesFileExist (buildInfoPref distPref) + when exists $ removeFile (buildInfoPref distPref) + where + shouldDumpBuildInfo = fromFlagOrDefault NoDumpBuildInfo dumpBuildInfoFlag == DumpBuildInfo + + -- | Given the flavor of the compiler, try to find out + -- which program we need. + flavorToProgram :: CompilerFlavor -> Maybe Program + flavorToProgram GHC = Just ghcProgram + flavorToProgram GHCJS = Just ghcjsProgram + flavorToProgram UHC = Just uhcProgram + flavorToProgram JHC = Just jhcProgram + flavorToProgram HaskellSuite {} = Just haskellSuiteProgram + flavorToProgram _ = Nothing + + repl :: PackageDescription -- ^ Mostly information from the .cabal file -> LocalBuildInfo -- ^ Configuration information -> ReplFlags -- ^ Flags that the user passed to build @@ -281,14 +333,14 @@ let exe = testSuiteExeV10AsExe test preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes extras <- preprocessExtras verbosity comp lbi + (genDir, generatedExtras) <- generateCode (testCodeGenerators test) (testName test) pkg_descr (testBuildInfo test) lbi clbi verbosity setupMessage' verbosity "Building" (packageId pkg_descr) (componentLocalName clbi) (maybeComponentInstantiatedWith clbi) let ebi = buildInfo exe - exe' = exe { buildInfo = addExtraCSources ebi extras } + exe' = exe { buildInfo = addSrcDir (addExtraOtherModules (addExtraCSources ebi extras) generatedExtras) genDir } -- todo extend hssrcdirs buildExe verbosity numJobs pkg_descr lbi exe' clbi return Nothing - buildComponent verbosity numJobs pkg_descr lbi0 suffixes comp@(CTest test@TestSuite { testInterface = TestSuiteLibV09{} }) @@ -302,10 +354,13 @@ let (pkg, lib, libClbi, lbi, ipi, exe, exeClbi) = testSuiteLibV09AsLibAndExe pkg_descr test clbi lbi0 distPref pwd preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes - extras <- preprocessExtras verbosity comp lbi + extras <- preprocessExtras verbosity comp lbi -- TODO find cpphs processed files + (genDir, generatedExtras) <- generateCode (testCodeGenerators test) (testName test) pkg_descr (testBuildInfo test) lbi clbi verbosity setupMessage' verbosity "Building" (packageId pkg_descr) (componentLocalName clbi) (maybeComponentInstantiatedWith clbi) - buildLib verbosity numJobs pkg lbi lib libClbi + let libbi = libBuildInfo lib + lib' = lib { libBuildInfo = addSrcDir (addExtraOtherModules libbi generatedExtras) genDir } + buildLib verbosity numJobs pkg lbi lib' libClbi -- NB: need to enable multiple instances here, because on 7.10+ -- the package name is the same as the library, and we still -- want the registration to go through. @@ -349,6 +404,32 @@ die' verbosity $ "No support for building benchmark type " ++ prettyShow tt + +generateCode + :: [String] + -> UnqualComponentName + -> PackageDescription + -> BuildInfo + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> Verbosity + -> IO (FilePath, [ModuleName.ModuleName]) +generateCode codeGens nm pdesc bi lbi clbi verbosity = do + when (not . null $ codeGens) $ createDirectoryIfMissingVerbose verbosity True tgtDir + (\x -> (tgtDir,x)) . concat <$> mapM go codeGens + where + allLibs = (maybe id (:) $ library pdesc) (subLibraries pdesc) + dependencyLibs = filter (const True) allLibs -- intersect with componentPackageDeps of clbi + srcDirs = concatMap (hsSourceDirs . libBuildInfo) dependencyLibs + nm' = unUnqualComponentName nm + tgtDir = buildDir lbi nm' nm' ++ "-gen" + go :: String -> IO [ModuleName.ModuleName] + go codeGenProg = fmap fromString . lines <$> getDbProgramOutput verbosity (simpleProgram codeGenProg) (withPrograms lbi) + ((tgtDir : map getSymbolicPath srcDirs) ++ + ("--" : + GHC.renderGhcOptions (compiler lbi) (hostPlatform lbi) (GHC.componentGhcOptions verbosity lbi bi clbi tgtDir))) + + -- | Add extra C sources generated by preprocessing to build -- information. addExtraCSources :: BuildInfo -> [FilePath] -> BuildInfo @@ -384,8 +465,23 @@ old = Set.fromList $ asmSources bi exs = Set.fromList extras +-- | Add extra HS modules generated by preprocessing to build +-- information. +addExtraOtherModules :: BuildInfo -> [ModuleName.ModuleName] -> BuildInfo +addExtraOtherModules bi extras = bi { otherModules = new } + where new = Set.toList $ old `Set.union` exs + old = Set.fromList $ otherModules bi + exs = Set.fromList extras -replComponent :: [String] +-- | Add extra source dir for generated modules. +addSrcDir :: BuildInfo -> FilePath -> BuildInfo +addSrcDir bi extra = bi { hsSourceDirs = new } + where new = Set.toList $ old `Set.union` ex + old = Set.fromList $ hsSourceDirs bi + ex = Set.fromList [unsafeMakeSymbolicPath extra] -- TODO + + +replComponent :: ReplOptions -> Verbosity -> PackageDescription -> LocalBuildInfo @@ -644,7 +740,7 @@ UHC -> UHC.buildExe verbosity pkg_descr lbi exe clbi _ -> die' verbosity "Building is not supported with this compiler." -replLib :: [String] -> Verbosity -> PackageDescription +replLib :: ReplOptions -> Verbosity -> PackageDescription -> LocalBuildInfo -> Library -> ComponentLocalBuildInfo -> IO () replLib replFlags verbosity pkg_descr lbi lib clbi = @@ -652,19 +748,19 @@ -- 'cabal repl' doesn't need to support 'ghc --make -j', so we just pass -- NoFlag as the numJobs parameter. GHC -> GHC.replLib replFlags verbosity NoFlag pkg_descr lbi lib clbi - GHCJS -> GHCJS.replLib replFlags verbosity NoFlag pkg_descr lbi lib clbi + GHCJS -> GHCJS.replLib (replOptionsFlags replFlags) verbosity NoFlag pkg_descr lbi lib clbi _ -> die' verbosity "A REPL is not supported for this compiler." -replExe :: [String] -> Verbosity -> PackageDescription +replExe :: ReplOptions -> Verbosity -> PackageDescription -> LocalBuildInfo -> Executable -> ComponentLocalBuildInfo -> IO () replExe replFlags verbosity pkg_descr lbi exe clbi = case compilerFlavor (compiler lbi) of GHC -> GHC.replExe replFlags verbosity NoFlag pkg_descr lbi exe clbi - GHCJS -> GHCJS.replExe replFlags verbosity NoFlag pkg_descr lbi exe clbi + GHCJS -> GHCJS.replExe (replOptionsFlags replFlags) verbosity NoFlag pkg_descr lbi exe clbi _ -> die' verbosity "A REPL is not supported for this compiler." -replFLib :: [String] -> Verbosity -> PackageDescription +replFLib :: ReplOptions -> Verbosity -> PackageDescription -> LocalBuildInfo -> ForeignLib -> ComponentLocalBuildInfo -> IO () replFLib replFlags verbosity pkg_descr lbi exe clbi = diff --git a/src/Distribution/Simple/Build/Macros.hs b/src/Distribution/Simple/Build/Macros.hs --- a/src/Distribution/Simple/Build/Macros.hs +++ b/src/Distribution/Simple/Build/Macros.hs @@ -18,7 +18,7 @@ -- numbers. -- -- TODO Figure out what to do about backpack and internal libraries. It is very --- suspecious that this stuff works with munged package identifiers +-- suspicious that this stuff works with munged package identifiers module Distribution.Simple.Build.Macros ( generateCabalMacrosHeader, generatePackageVersionMacros, diff --git a/src/Distribution/Simple/BuildPaths.hs b/src/Distribution/Simple/BuildPaths.hs --- a/src/Distribution/Simple/BuildPaths.hs +++ b/src/Distribution/Simple/BuildPaths.hs @@ -15,7 +15,7 @@ module Distribution.Simple.BuildPaths ( defaultDistPref, srcPref, - haddockDirName, hscolourPref, haddockPref, + buildInfoPref, haddockDirName, hscolourPref, haddockPref, autogenPackageModulesDir, autogenComponentModulesDir, @@ -66,6 +66,10 @@ hscolourPref :: HaddockTarget -> FilePath -> PackageDescription -> FilePath hscolourPref = haddockPref + +-- | Build info json file, generated in every build +buildInfoPref :: FilePath -> FilePath +buildInfoPref distPref = distPref "build-info.json" -- | This is the name of the directory in which the generated haddocks -- should be stored. It does not include the @/doc/html@ prefix. diff --git a/src/Distribution/Simple/BuildToolDepends.hs b/src/Distribution/Simple/BuildToolDepends.hs --- a/src/Distribution/Simple/BuildToolDepends.hs +++ b/src/Distribution/Simple/BuildToolDepends.hs @@ -16,7 +16,7 @@ -- | Desugar a "build-tools" entry into proper a executable dependency if -- possible. -- --- An entry can be so desguared in two cases: +-- An entry can be so desugared in two cases: -- -- 1. The name in build-tools matches a locally defined executable. The -- executable dependency produced is on that exe in the current package. diff --git a/src/Distribution/Simple/Command.hs b/src/Distribution/Simple/Command.hs --- a/src/Distribution/Simple/Command.hs +++ b/src/Distribution/Simple/Command.hs @@ -223,16 +223,15 @@ commandGetOpts showOrParse command = concatMap viewAsGetOpt (commandOptions command showOrParse) -viewAsGetOpt :: OptionField a -> [GetOpt.OptDescr (a->a)] +viewAsGetOpt :: OptionField a -> [GetOpt.OptDescr (a -> a)] viewAsGetOpt (OptionField _n aa) = concatMap optDescrToGetOpt aa where optDescrToGetOpt (ReqArg d (cs,ss) arg_desc set _) = - [GetOpt.Option cs ss (GetOpt.ReqArg set' arg_desc) d] - where set' = readEOrFail set + [GetOpt.Option cs ss (GetOpt.ReqArg (runReadE set) arg_desc) d] optDescrToGetOpt (OptArg d (cs,ss) arg_desc set def _) = [GetOpt.Option cs ss (GetOpt.OptArg set' arg_desc) d] - where set' Nothing = def - set' (Just txt) = readEOrFail set txt + where set' Nothing = Right def + set' (Just txt) = runReadE set txt optDescrToGetOpt (ChoiceOpt alts) = [GetOpt.Option sf lf (GetOpt.NoArg set) d | (d,(sf,lf),set,_) <- alts ] optDescrToGetOpt (BoolOpt d (sfT, lfT) ([], []) set _) = @@ -391,13 +390,8 @@ -> [GetOpt.OptDescr a] -> [GetOpt.OptDescr (Either CommonFlag a)] addCommonFlags showOrParseArgs options = - map (fmapOptDesc Left) (commonFlags showOrParseArgs) - ++ map (fmapOptDesc Right) options - where fmapOptDesc f (GetOpt.Option s l d m) = - GetOpt.Option s l (fmapArgDesc f d) m - fmapArgDesc f (GetOpt.NoArg a) = GetOpt.NoArg (f a) - fmapArgDesc f (GetOpt.ReqArg s d) = GetOpt.ReqArg (f . s) d - fmapArgDesc f (GetOpt.OptArg s d) = GetOpt.OptArg (f . s) d + map (fmap Left) (commonFlags showOrParseArgs) + ++ map (fmap Right) options -- | Parse a bunch of command line arguments -- diff --git a/src/Distribution/Simple/Compiler.hs b/src/Distribution/Simple/Compiler.hs --- a/src/Distribution/Simple/Compiler.hs +++ b/src/Distribution/Simple/Compiler.hs @@ -62,6 +62,7 @@ profilingSupported, backpackSupported, arResponseFilesSupported, + arDashLSupported, libraryDynDirSupported, libraryVisibilitySupported, @@ -165,7 +166,7 @@ -- |Some compilers have a notion of a database of available packages. -- For some there is just one global db of packages, other compilers -- support a per-user or an arbitrary db specified at some location in --- the file system. This can be used to build isloated environments of +-- the file system. This can be used to build isolated environments of -- packages, for example to build a collection of related packages -- without installing them globally. -- @@ -364,6 +365,12 @@ -- arguments (i.e. @file-style arguments). arResponseFilesSupported :: Compiler -> Bool arResponseFilesSupported = ghcSupported "ar supports at file" + +-- | Does this compiler's "ar" command support llvm-ar's -L flag, +-- which compels the archiver to add an input archive's members +-- rather than adding the archive itself. +arDashLSupported :: Compiler -> Bool +arDashLSupported = ghcSupported "ar supports -L" -- | Does this compiler support Haskell program coverage? coverageSupported :: Compiler -> Bool diff --git a/src/Distribution/Simple/Configure.hs b/src/Distribution/Simple/Configure.hs --- a/src/Distribution/Simple/Configure.hs +++ b/src/Distribution/Simple/Configure.hs @@ -106,7 +106,7 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy.Char8 as BLC8 import Data.List - ( (\\), inits, stripPrefix, intersect, dropWhileEnd ) + ( (\\), inits, stripPrefix, intersect) import qualified Data.Map as Map import System.Directory ( canonicalizePath, createDirectoryIfMissing, doesFileExist @@ -635,6 +635,22 @@ "--enable-split-objs; ignoring") return False + let compilerSupportsGhciLibs :: Bool + compilerSupportsGhciLibs = + case compilerId comp of + CompilerId GHC version + | version > mkVersion [9,3] && windows -> + False + CompilerId GHC _ -> + True + CompilerId GHCJS _ -> + True + _ -> False + where + windows = case compPlatform of + Platform _ Windows -> True + Platform _ _ -> False + let ghciLibByDefault = case compilerId comp of CompilerId GHC _ -> @@ -651,6 +667,15 @@ not (GHCJS.isDynamic comp) _ -> False + withGHCiLib_ <- + case fromFlagOrDefault ghciLibByDefault (configGHCiLib cfg) of + True | not compilerSupportsGhciLibs -> do + warn verbosity $ + "--enable-library-for-ghci is no longer supported on Windows with" + ++ " GHC 9.4 and later; ignoring..." + return False + v -> return v + let sharedLibsByDefault | fromFlag (configDynExe cfg) = -- build a shared library if dynamically-linked @@ -679,6 +704,7 @@ withDynExe_ = fromFlag $ configDynExe cfg withFullyStaticExe_ = fromFlag $ configFullyStaticExe cfg + when (withDynExe_ && not withSharedLib_) $ warn verbosity $ "Executables will use dynamic linking, but a shared library " ++ "is not being built. Linking will fail if any executables " @@ -746,8 +772,7 @@ withProfExeDetail = ProfDetailNone, withOptimization = fromFlag $ configOptimization cfg, withDebugInfo = fromFlag $ configDebugInfo cfg, - withGHCiLib = fromFlagOrDefault ghciLibByDefault $ - configGHCiLib cfg, + withGHCiLib = withGHCiLib_, splitSections = split_sections, splitObjs = split_objs, stripExes = strip_exe, @@ -1011,6 +1036,7 @@ where addExtraIncludeLibDirs pkg_descr = let extraBi = mempty { extraLibDirs = configExtraLibDirs cfg + , extraLibDirsStatic = configExtraLibDirsStatic cfg , extraFrameworkDirs = configExtraFrameworkDirs cfg , includeDirs = configExtraIncludeDirs cfg} modifyLib l = l{ libBuildInfo = libBuildInfo l @@ -1134,7 +1160,7 @@ computeEffectiveProfiling :: ConfigFlags -> (Bool {- lib -}, Bool {- exe -}) computeEffectiveProfiling cfg = -- The --profiling flag sets the default for both libs and exes, - -- but can be overidden by --library-profiling, or the old deprecated + -- but can be overridden by --library-profiling, or the old deprecated -- --executable-profiling flag. -- -- The --profiling-detail and --library-profiling-detail flags behave @@ -1284,7 +1310,7 @@ -- If we know the exact pkg to use, then use it. Just pkginstance -> Right pkginstance -- Otherwise we just pick an arbitrary instance of the latest version. - Nothing -> case pickLastIPI $ PackageIndex.lookupDependency installedIndex dep_pkgname vr of + Nothing -> case pickLastIPI $ PackageIndex.lookupInternalDependency installedIndex dep_pkgname vr lib of Nothing -> Left (DependencyNotExists dep_pkgname) Just pkg -> Right pkg return $ ExternalDependency $ ipiToPreExistingComponent ipi @@ -1638,7 +1664,8 @@ let pkgs = nub [ prettyShow pkg | PkgconfigDependency pkg _ <- pkgdeps ] ccflags <- pkgconfig ("--cflags" : pkgs) ldflags <- pkgconfig ("--libs" : pkgs) - return (ccLdOptionsBuildInfo (words ccflags) (words ldflags)) + ldflags_static <- pkgconfig ("--libs" : "--static" : pkgs) + return (ccLdOptionsBuildInfo (words ccflags) (words ldflags) (words ldflags_static)) -- | Makes a 'BuildInfo' from C compiler and linker flags. -- @@ -1648,17 +1675,22 @@ -- -- > ccflags <- getDbProgramOutput verbosity prog progdb ["--cflags"] -- > ldflags <- getDbProgramOutput verbosity prog progdb ["--libs"] --- > return (ccldOptionsBuildInfo (words ccflags) (words ldflags)) +-- > ldflags_static <- getDbProgramOutput verbosity prog progdb ["--libs", "--static"] +-- > return (ccldOptionsBuildInfo (words ccflags) (words ldflags) (words ldflags_static)) -- -ccLdOptionsBuildInfo :: [String] -> [String] -> BuildInfo -ccLdOptionsBuildInfo cflags ldflags = +ccLdOptionsBuildInfo :: [String] -> [String] -> [String] -> BuildInfo +ccLdOptionsBuildInfo cflags ldflags ldflags_static = let (includeDirs', cflags') = partition ("-I" `isPrefixOf`) cflags (extraLibs', ldflags') = partition ("-l" `isPrefixOf`) ldflags (extraLibDirs', ldflags'') = partition ("-L" `isPrefixOf`) ldflags' + (extraLibsStatic') = filter ("-l" `isPrefixOf`) ldflags_static + (extraLibDirsStatic') = filter ("-L" `isPrefixOf`) ldflags_static in mempty { includeDirs = map (drop 2) includeDirs', extraLibs = map (drop 2) extraLibs', extraLibDirs = map (drop 2) extraLibDirs', + extraLibsStatic = map (drop 2) extraLibsStatic', + extraLibDirsStatic = map (drop 2) extraLibDirsStatic', ccOptions = cflags', ldOptions = ldflags'' } @@ -1707,7 +1739,10 @@ explainErrors missingHdr missingLibs) where allHeaders = collectField includes - allLibs = collectField extraLibs + allLibs = collectField $ + if withFullyStaticExe lbi + then extraLibsStatic + else extraLibs ifBuildsWith headers args success failure = do checkDuplicateHeaders @@ -1810,12 +1845,17 @@ , opt <- IPI.ccOptions dep ] commonLdArgs = [ "-L" ++ dir - | dir <- ordNub (collectField extraLibDirs) ] + | dir <- ordNub $ collectField (if withFullyStaticExe lbi + then extraLibDirsStatic + else extraLibDirs + ) ] ++ collectField ldOptions ++ [ "-L" ++ dir | dir <- ordNub [ dir | dep <- deps - , dir <- IPI.libraryDirs dep ] + , dir <- if withFullyStaticExe lbi + then IPI.libraryDirsStatic dep + else IPI.libraryDirs dep ] ] --TODO: do we also need dependent packages' ld options? makeLdArgs libs = [ "-l"++lib | lib <- libs ] ++ commonLdArgs @@ -2025,12 +2065,12 @@ ] goGhcPlatform :: Platform -> Maybe String - goGhcPlatform (Platform X86_64 OSX ) = goGhcOsx (foreignLibType flib) + goGhcPlatform (Platform _ OSX ) = goGhcOsx (foreignLibType flib) goGhcPlatform (Platform _ Linux ) = goGhcLinux (foreignLibType flib) goGhcPlatform (Platform I386 Windows) = goGhcWindows (foreignLibType flib) goGhcPlatform (Platform X86_64 Windows) = goGhcWindows (foreignLibType flib) goGhcPlatform _ = unsupported [ - "Building foreign libraries is currently only supported on OSX, " + "Building foreign libraries is currently only supported on Mac OS, " , "Linux and Windows" ] diff --git a/src/Distribution/Simple/GHC.hs b/src/Distribution/Simple/GHC.hs --- a/src/Distribution/Simple/GHC.hs +++ b/src/Distribution/Simple/GHC.hs @@ -103,6 +103,7 @@ import Distribution.Simple.Compiler import Distribution.Version import Distribution.System +import Distribution.Types.PackageName.Magic import Distribution.Verbosity import Distribution.Pretty import Distribution.Utils.NubList @@ -114,7 +115,8 @@ import qualified Data.Map as Map import System.Directory ( doesFileExist, getAppUserDataDirectory, createDirectoryIfMissing - , canonicalizePath, removeFile, renameFile, getDirectoryContents ) + , canonicalizePath, removeFile, renameFile, getDirectoryContents + , makeRelativeToCurrentDirectory ) import System.FilePath ( (), (<.>), takeExtension , takeDirectory, replaceExtension ,isRelative ) @@ -137,12 +139,12 @@ (userMaybeSpecifyPath "ghc" hcPath conf0) let implInfo = ghcVersionImplInfo ghcVersion - -- Cabal currently supports ghc >= 7.0.1 && < 9.4 + -- Cabal currently supports ghc >= 7.0.1 && < 9.6 -- ... and the following odd development version - unless (ghcVersion < mkVersion [9,4]) $ + unless (ghcVersion < mkVersion [9,6]) $ warn verbosity $ "Unknown/unsupported 'ghc' version detected " - ++ "(Cabal " ++ prettyShow cabalVersion ++ " supports 'ghc' version < 9.4): " + ++ "(Cabal " ++ prettyShow cabalVersion ++ " supports 'ghc' version < 9.6): " ++ programPath ghcProg ++ " is version " ++ prettyShow ghcVersion -- This is slightly tricky, we have to configure ghc first, then we use the @@ -493,13 +495,13 @@ -> Library -> ComponentLocalBuildInfo -> IO () buildLib = buildOrReplLib Nothing -replLib :: [String] -> Verbosity +replLib :: ReplOptions -> Verbosity -> Cabal.Flag (Maybe Int) -> PackageDescription -> LocalBuildInfo -> Library -> ComponentLocalBuildInfo -> IO () replLib = buildOrReplLib . Just -buildOrReplLib :: Maybe [String] -> Verbosity +buildOrReplLib :: Maybe ReplOptions -> Verbosity -> Cabal.Flag (Maybe Int) -> PackageDescription -> LocalBuildInfo -> Library -> ComponentLocalBuildInfo -> IO () @@ -523,6 +525,8 @@ platform@(Platform _hostArch hostOS) = hostPlatform lbi has_code = not (componentIsIndefinite clbi) + relLibTargetDir <- makeRelativeToCurrentDirectory libTargetDir + (ghcProg, _) <- requireProgram verbosity ghcProgram (withPrograms lbi) let runGhcProg = runGHC verbosity ghcProg comp platform @@ -593,19 +597,25 @@ -- through to GHC's linker. ++ maybe [] programOverrideArgs (lookupProgram ldProgram (withPrograms lbi)), - ghcOptLinkLibs = extraLibs libBi, - ghcOptLinkLibPath = toNubListR $ extraLibDirs libBi, + ghcOptLinkLibs = if withFullyStaticExe lbi + then extraLibsStatic libBi + else extraLibs libBi, + ghcOptLinkLibPath = toNubListR $ + if withFullyStaticExe lbi + then extraLibDirsStatic libBi + else extraLibDirs libBi, ghcOptLinkFrameworks = toNubListR $ PD.frameworks libBi, ghcOptLinkFrameworkDirs = toNubListR $ PD.extraFrameworkDirs libBi, ghcOptInputFiles = toNubListR - [libTargetDir x | x <- cLikeObjs] + [relLibTargetDir x | x <- cLikeObjs] } replOpts = vanillaOpts { ghcOptExtra = Internal.filterGhciFlags (ghcOptExtra vanillaOpts) - <> replFlags, - ghcOptNumJobs = mempty + <> replOptionsFlags replFlags, + ghcOptNumJobs = mempty, + ghcOptInputModules = replNoLoad replFlags (ghcOptInputModules vanillaOpts) } `mappend` linkerOpts `mappend` mempty { @@ -653,7 +663,7 @@ info verbosity "Building C++ Sources..." sequence_ [ do let baseCxxOpts = Internal.componentCxxGhcOptions verbosity implInfo - lbi libBi clbi libTargetDir filename + lbi libBi clbi relLibTargetDir filename vanillaCxxOpts = if isGhcDynamic then baseCxxOpts { ghcOptFPic = toFlag True } else baseCxxOpts @@ -682,7 +692,7 @@ info verbosity "Building C Sources..." sequence_ [ do let baseCcOpts = Internal.componentCcGhcOptions verbosity implInfo - lbi libBi clbi libTargetDir filename + lbi libBi clbi relLibTargetDir filename vanillaCcOpts = if isGhcDynamic -- Dynamic GHC requires C sources to be built -- with -fPIC for REPL to work. See #2207. @@ -713,7 +723,7 @@ info verbosity "Building Assembler Sources..." sequence_ [ do let baseAsmOpts = Internal.componentAsmGhcOptions verbosity implInfo - lbi libBi clbi libTargetDir filename + lbi libBi clbi relLibTargetDir filename vanillaAsmOpts = if isGhcDynamic -- Dynamic GHC requires objects to be built -- with -fPIC for REPL to work. See #2207. @@ -744,7 +754,7 @@ info verbosity "Building C-- Sources..." sequence_ [ do let baseCmmOpts = Internal.componentCmmGhcOptions verbosity implInfo - lbi libBi clbi libTargetDir filename + lbi libBi clbi relLibTargetDir filename vanillaCmmOpts = if isGhcDynamic -- Dynamic GHC requires C sources to be built -- with -fPIC for REPL to work. See #2207. @@ -785,14 +795,14 @@ cLikeSharedObjs = map (`replaceExtension` ("dyn_" ++ objExtension)) cLikeSources compiler_id = compilerId (compiler lbi) - vanillaLibFilePath = libTargetDir mkLibName uid - profileLibFilePath = libTargetDir mkProfLibName uid - sharedLibFilePath = libTargetDir + vanillaLibFilePath = relLibTargetDir mkLibName uid + profileLibFilePath = relLibTargetDir mkProfLibName uid + sharedLibFilePath = relLibTargetDir mkSharedLibName (hostPlatform lbi) compiler_id uid - staticLibFilePath = libTargetDir + staticLibFilePath = relLibTargetDir mkStaticLibName (hostPlatform lbi) compiler_id uid - ghciLibFilePath = libTargetDir Internal.mkGHCiLibName uid - ghciProfLibFilePath = libTargetDir Internal.mkGHCiProfLibName uid + ghciLibFilePath = relLibTargetDir Internal.mkGHCiLibName uid + ghciProfLibFilePath = relLibTargetDir Internal.mkGHCiProfLibName uid libInstallPath = libdir $ absoluteComponentInstallDirs pkg_descr lbi uid NoCopyDest @@ -816,16 +826,16 @@ , x <- allLibModules lib clbi ] hObjs <- Internal.getHaskellObjects implInfo lib lbi clbi - libTargetDir objExtension True + relLibTargetDir objExtension True hProfObjs <- if withProfLib lbi then Internal.getHaskellObjects implInfo lib lbi clbi - libTargetDir ("p_" ++ objExtension) True + relLibTargetDir ("p_" ++ objExtension) True else return [] hSharedObjs <- if withSharedLib lbi then Internal.getHaskellObjects implInfo lib lbi clbi - libTargetDir ("dyn_" ++ objExtension) False + relLibTargetDir ("dyn_" ++ objExtension) False else return [] unless (null hObjs && null cLikeObjs && null stubObjs) $ do @@ -833,15 +843,15 @@ let staticObjectFiles = hObjs - ++ map (libTargetDir ) cLikeObjs + ++ map (relLibTargetDir ) cLikeObjs ++ stubObjs profObjectFiles = hProfObjs - ++ map (libTargetDir ) cLikeProfObjs + ++ map (relLibTargetDir ) cLikeProfObjs ++ stubProfObjs dynamicObjectFiles = hSharedObjs - ++ map (libTargetDir ) cLikeSharedObjs + ++ map (relLibTargetDir ) cLikeSharedObjs ++ stubSharedObjs -- After the relocation lib is created we invoke ghc -shared -- with the dependencies spelled out as -package arguments @@ -964,7 +974,7 @@ buildFLib v njobs pkg lbi = gbuild v njobs pkg lbi . GBuildFLib replFLib - :: [String] -> Verbosity + :: ReplOptions -> Verbosity -> Cabal.Flag (Maybe Int) -> PackageDescription -> LocalBuildInfo -> ForeignLib -> ComponentLocalBuildInfo -> IO () @@ -980,7 +990,7 @@ buildExe v njobs pkg lbi = gbuild v njobs pkg lbi . GBuildExe replExe - :: [String] -> Verbosity + :: ReplOptions -> Verbosity -> Cabal.Flag (Maybe Int) -> PackageDescription -> LocalBuildInfo -> Executable -> ComponentLocalBuildInfo -> IO () @@ -992,9 +1002,9 @@ -- 'GBuildMode' distinguishes between the various kinds of operation. data GBuildMode = GBuildExe Executable - | GReplExe [String] Executable + | GReplExe ReplOptions Executable | GBuildFLib ForeignLib - | GReplFLib [String] ForeignLib + | GReplFLib ReplOptions ForeignLib gbuildInfo :: GBuildMode -> BuildInfo gbuildInfo (GBuildExe exe) = buildInfo exe @@ -1181,11 +1191,12 @@ -- | Locate and return the 'BuildSources' required to build and link. gbuildSources :: Verbosity + -> PackageId -> CabalSpecVersion -> FilePath -> GBuildMode -> IO BuildSources -gbuildSources verbosity specVer tmpDir bm = +gbuildSources verbosity pkgId specVer tmpDir bm = case bm of GBuildExe exe -> exeSources exe GReplExe _ exe -> exeSources exe @@ -1198,7 +1209,8 @@ let mainModName = fromMaybe ModuleName.main $ exeMainModuleName exe otherModNames = exeModules exe - if isHaskell main + -- Scripts have fakePackageId and are always Haskell but can have any extension. + if isHaskell main || pkgId == fakePackageId then if specVer < CabalSpecV2_0 && (mainModName `elem` otherModNames) then do @@ -1254,12 +1266,18 @@ inputSourceModules = foreignLibModules flib } - isHaskell :: FilePath -> Bool - isHaskell fp = elem (takeExtension fp) [".hs", ".lhs"] - isCxx :: FilePath -> Bool isCxx fp = elem (takeExtension fp) [".cpp", ".cxx", ".c++"] +-- | FilePath has a Haskell extension: .hs or .lhs +isHaskell :: FilePath -> Bool +isHaskell fp = elem (takeExtension fp) [".hs", ".lhs"] + +replNoLoad :: Ord a => ReplOptions -> NubListR a -> NubListR a +replNoLoad replFlags l + | replOptionsNoLoad replFlags == Flag True = mempty + | otherwise = l + -- | Generic build function. See comment for 'GBuildMode'. gbuild :: Verbosity -> Cabal.Flag (Maybe Int) -> PackageDescription -> LocalBuildInfo @@ -1276,9 +1294,7 @@ implInfo = getImplInfo comp runGhcProg = runGHC verbosity ghcProg comp platform - let (bnfo, threaded) = case bm of - GBuildFLib _ -> popThreadedFlag (gbuildInfo bm) - _ -> (gbuildInfo bm, False) + let bnfo = gbuildInfo bm -- the name that GHC really uses (e.g., with .exe on Windows for executables) let targetName = gbuildTargetName lbi bm @@ -1300,7 +1316,7 @@ | otherwise = mempty rpaths <- getRPaths lbi clbi - buildSources <- gbuildSources verbosity (specVersion pkg_descr) tmpDir bm + buildSources <- gbuildSources verbosity (package pkg_descr) (specVersion pkg_descr) tmpDir bm let cSrcs = cSourcesFiles buildSources cxxSrcs = cxxSourceFiles buildSources @@ -1317,7 +1333,12 @@ baseOpts = (componentGhcOptions verbosity lbi bnfo clbi tmpDir) `mappend` mempty { ghcOptMode = toFlag GhcModeMake, - ghcOptInputFiles = toNubListR inputFiles, + ghcOptInputFiles = toNubListR $ if package pkg_descr == fakePackageId + then filter isHaskell inputFiles + else inputFiles, + ghcOptInputScripts = toNubListR $ if package pkg_descr == fakePackageId + then filter (not . isHaskell) inputFiles + else [], ghcOptInputModules = toNubListR inputModules } staticOpts = baseOpts `mappend` mempty { @@ -1356,8 +1377,13 @@ -- through to GHC's linker. ++ maybe [] programOverrideArgs (lookupProgram ldProgram (withPrograms lbi)), - ghcOptLinkLibs = extraLibs bnfo, - ghcOptLinkLibPath = toNubListR $ extraLibDirs bnfo, + ghcOptLinkLibs = if withFullyStaticExe lbi + then extraLibsStatic bnfo + else extraLibs bnfo, + ghcOptLinkLibPath = toNubListR $ + if withFullyStaticExe lbi + then extraLibDirsStatic bnfo + else extraLibDirs bnfo, ghcOptLinkFrameworks = toNubListR $ PD.frameworks bnfo, ghcOptLinkFrameworkDirs = toNubListR $ @@ -1373,7 +1399,9 @@ replOpts = baseOpts { ghcOptExtra = Internal.filterGhciFlags (ghcOptExtra baseOpts) - <> replFlags + <> replOptionsFlags replFlags, + ghcOptInputModules = replNoLoad replFlags (ghcOptInputModules baseOpts), + ghcOptInputFiles = replNoLoad replFlags (ghcOptInputFiles baseOpts) } -- For a normal compile we do separate invocations of ghc for -- compiling as for linking. But for repl we have to do just @@ -1508,26 +1536,43 @@ when e (removeFile target) runGhcProg linkOpts { ghcOptOutputFile = toFlag target } GBuildFLib flib -> do - let rtsInfo = extractRtsInfo lbi - rtsOptLinkLibs = [ - if needDynamic - then if threaded - then dynRtsThreadedLib (rtsDynamicInfo rtsInfo) - else dynRtsVanillaLib (rtsDynamicInfo rtsInfo) - else if threaded - then statRtsThreadedLib (rtsStaticInfo rtsInfo) - else statRtsVanillaLib (rtsStaticInfo rtsInfo) - ] + let -- Instruct GHC to link against libHSrts. + rtsLinkOpts :: GhcOptions + rtsLinkOpts + | supportsFLinkRts = + mempty { + ghcOptLinkRts = toFlag True + } + | otherwise = + mempty { + ghcOptLinkLibs = rtsOptLinkLibs, + ghcOptLinkLibPath = toNubListR $ rtsLibPaths rtsInfo + } + where + threaded = hasThreaded (gbuildInfo bm) + supportsFLinkRts = compilerVersion comp >= mkVersion [9,0] + rtsInfo = extractRtsInfo lbi + rtsOptLinkLibs = [ + if needDynamic + then if threaded + then dynRtsThreadedLib (rtsDynamicInfo rtsInfo) + else dynRtsVanillaLib (rtsDynamicInfo rtsInfo) + else if threaded + then statRtsThreadedLib (rtsStaticInfo rtsInfo) + else statRtsVanillaLib (rtsStaticInfo rtsInfo) + ] + + + linkOpts :: GhcOptions linkOpts = case foreignLibType flib of ForeignLibNativeShared -> commonOpts `mappend` linkerOpts `mappend` dynLinkerOpts + `mappend` rtsLinkOpts `mappend` mempty { ghcOptLinkNoHsMain = toFlag True, ghcOptShared = toFlag True, - ghcOptLinkLibs = rtsOptLinkLibs, - ghcOptLinkLibPath = toNubListR $ rtsLibPaths rtsInfo, ghcOptFPic = toFlag True, ghcOptLinkModDefFiles = toNubListR $ gbuildModDefFiles bm } @@ -1746,6 +1791,7 @@ supportRPaths IOS = False supportRPaths Android = False supportRPaths Ghcjs = False + supportRPaths Wasi = False supportRPaths Hurd = False supportRPaths (OtherOS _) = False -- Do _not_ add a default case so that we get a warning here when a new OS @@ -1753,24 +1799,13 @@ getRPaths _ _ = return mempty --- | Remove the "-threaded" flag when building a foreign library, as it has no --- effect when used with "-shared". Returns the updated 'BuildInfo', along --- with whether or not the flag was present, so we can use it to link against --- the appropriate RTS on our own. -popThreadedFlag :: BuildInfo -> (BuildInfo, Bool) -popThreadedFlag bi = - ( bi { options = filterHcOptions (/= "-threaded") (options bi) } - , hasThreaded (options bi)) - +-- | Determine whether the given 'BuildInfo' is intended to link against the +-- threaded RTS. This is used to determine which RTS to link against when +-- building a foreign library with a GHC without support for @-flink-rts@. +hasThreaded :: BuildInfo -> Bool +hasThreaded bi = elem "-threaded" ghc where - filterHcOptions :: (String -> Bool) - -> PerCompilerFlavor [String] - -> PerCompilerFlavor [String] - filterHcOptions p (PerCompilerFlavor ghc ghcjs) = - PerCompilerFlavor (filter p ghc) ghcjs - - hasThreaded :: PerCompilerFlavor [String] -> Bool - hasThreaded (PerCompilerFlavor ghc _) = elem "-threaded" ghc + PerCompilerFlavor ghc _ = options bi -- | Extracts a String representing a hash of the ABI of a built -- library. It can fail if the library has not yet been built. diff --git a/src/Distribution/Simple/GHC/Internal.hs b/src/Distribution/Simple/GHC/Internal.hs --- a/src/Distribution/Simple/GHC/Internal.hs +++ b/src/Distribution/Simple/GHC/Internal.hs @@ -301,7 +301,10 @@ NormalDebugInfo -> ["-g"] MaximalDebugInfo -> ["-g3"]) ++ ccOptions bi, - ghcOptObjDir = toFlag odir + ghcOptCcProgram = maybeToFlag $ programPath <$> + lookupProgram gccProgram (withPrograms lbi), + ghcOptObjDir = toFlag odir, + ghcOptExtra = hcOptions GHC bi } @@ -337,7 +340,10 @@ NormalDebugInfo -> ["-g"] MaximalDebugInfo -> ["-g3"]) ++ cxxOptions bi, - ghcOptObjDir = toFlag odir + ghcOptCcProgram = maybeToFlag $ programPath <$> + lookupProgram gccProgram (withPrograms lbi), + ghcOptObjDir = toFlag odir, + ghcOptExtra = hcOptions GHC bi } @@ -536,6 +542,7 @@ = ipo { IPI.importDirs = map f (IPI.importDirs ipo), IPI.libraryDirs = map f (IPI.libraryDirs ipo), + IPI.libraryDirsStatic = map f (IPI.libraryDirsStatic ipo), IPI.includeDirs = map f (IPI.includeDirs ipo), IPI.frameworkDirs = map f (IPI.frameworkDirs ipo), IPI.haddockInterfaces = map f (IPI.haddockInterfaces ipo), diff --git a/src/Distribution/Simple/GHCJS.hs b/src/Distribution/Simple/GHCJS.hs --- a/src/Distribution/Simple/GHCJS.hs +++ b/src/Distribution/Simple/GHCJS.hs @@ -67,6 +67,7 @@ import Distribution.CabalSpecVersion import Distribution.Version import Distribution.System +import Distribution.Types.PackageName.Magic import Distribution.Verbosity import Distribution.Pretty import Distribution.Utils.NubList @@ -961,11 +962,12 @@ -- | Locate and return the 'BuildSources' required to build and link. gbuildSources :: Verbosity + -> PackageId -> CabalSpecVersion -> FilePath -> GBuildMode -> IO BuildSources -gbuildSources verbosity specVer tmpDir bm = +gbuildSources verbosity pkgId specVer tmpDir bm = case bm of GBuildExe exe -> exeSources exe GReplExe _ exe -> exeSources exe @@ -978,7 +980,8 @@ let mainModName = fromMaybe ModuleName.main $ exeMainModuleName exe otherModNames = exeModules exe - if isHaskell main + -- Scripts have fakePackageId and are always Haskell but can have any extension. + if isHaskell main || pkgId == fakePackageId then if specVer < CabalSpecV2_0 && (mainModName `elem` otherModNames) then do @@ -1033,12 +1036,13 @@ inputSourceModules = foreignLibModules flib } - isHaskell :: FilePath -> Bool - isHaskell fp = elem (takeExtension fp) [".hs", ".lhs"] - isCxx :: FilePath -> Bool isCxx fp = elem (takeExtension fp) [".cpp", ".cxx", ".c++"] +-- | FilePath has a Haskell extension: .hs or .lhs +isHaskell :: FilePath -> Bool +isHaskell fp = elem (takeExtension fp) [".hs", ".lhs"] + -- | Generic build function. See comment for 'GBuildMode'. gbuild :: Verbosity -> Cabal.Flag (Maybe Int) -> PackageDescription -> LocalBuildInfo @@ -1079,7 +1083,7 @@ | otherwise = mempty rpaths <- getRPaths lbi clbi - buildSources <- gbuildSources verbosity (specVersion pkg_descr) tmpDir bm + buildSources <- gbuildSources verbosity (package pkg_descr) (specVersion pkg_descr) tmpDir bm let cSrcs = cSourcesFiles buildSources cxxSrcs = cxxSourceFiles buildSources @@ -1093,11 +1097,27 @@ needProfiling = withProfExe lbi -- build executables + buildRunner = case clbi of + LibComponentLocalBuildInfo {} -> False + FLibComponentLocalBuildInfo {} -> False + ExeComponentLocalBuildInfo {} -> True + TestComponentLocalBuildInfo {} -> True + BenchComponentLocalBuildInfo {} -> True baseOpts = (componentGhcOptions verbosity lbi bnfo clbi tmpDir) `mappend` mempty { ghcOptMode = toFlag GhcModeMake, - ghcOptInputFiles = toNubListR inputFiles, - ghcOptInputModules = toNubListR inputModules + ghcOptInputFiles = toNubListR $ if package pkg_descr == fakePackageId + then filter isHaskell inputFiles + else inputFiles, + ghcOptInputScripts = toNubListR $ if package pkg_descr == fakePackageId + then filter (not . isHaskell) inputFiles + else [], + ghcOptInputModules = toNubListR inputModules, + -- for all executable components (exe/test/bench), + -- GHCJS must be passed the "-build-runner" option + ghcOptExtra = + if buildRunner then ["-build-runner"] + else mempty } staticOpts = baseOpts `mappend` mempty { ghcOptDynLinkMode = toFlag GhcStaticOnly, @@ -1516,6 +1536,7 @@ supportRPaths IOS = False supportRPaths Android = False supportRPaths Ghcjs = False + supportRPaths Wasi = False supportRPaths Hurd = False supportRPaths (OtherOS _) = False -- Do _not_ add a default case so that we get a warning here when a new OS diff --git a/src/Distribution/Simple/Glob.hs b/src/Distribution/Simple/Glob.hs --- a/src/Distribution/Simple/Glob.hs +++ b/src/Distribution/Simple/Glob.hs @@ -96,7 +96,8 @@ ++ "'. If a wildcard '*' is used it must be with an file extension." explainGlobSyntaxError filepath LiteralFileNameGlobStar = "invalid file glob '" ++ filepath - ++ "'. If a wildcard '**' is used as a parent directory, the" + ++ "'. Prior to 'cabal-version: 3.8'" + ++ " if a wildcard '**' is used as a parent directory, the" ++ " file's base name must be a wildcard '*'." explainGlobSyntaxError _ EmptyGlob = "invalid file glob. A glob cannot be the empty string." @@ -111,7 +112,7 @@ ++ "Alternatively if you require compatibility with earlier Cabal " ++ "versions then list all the files explicitly." -data IsRecursive = Recursive | NonRecursive +data IsRecursive = Recursive | NonRecursive deriving Eq data MultiDot = MultiDotDisabled | MultiDotEnabled @@ -125,7 +126,7 @@ -- ^ First argument: Is this a @**/*.ext@ pattern? -- Second argument: should we match against the exact extensions, or accept a suffix? -- Third argument: the extensions to accept. - | FinalLit FilePath + | FinalLit IsRecursive FilePath -- ^ Literal file name. reconstructGlob :: Glob -> FilePath @@ -134,7 +135,8 @@ reconstructGlob (GlobFinal final) = case final of FinalMatch Recursive _ exts -> "**" "*" <.> exts FinalMatch NonRecursive _ exts -> "*" <.> exts - FinalLit path -> path + FinalLit Recursive path -> "**" path + FinalLit NonRecursive path -> path -- | Returns 'Nothing' if the glob didn't match at all, or 'Just' the -- result if the glob matched (or would have matched with a higher @@ -159,8 +161,8 @@ let (candidateBase, candidateExts) = splitExtensions seg guard (null segs && not (null candidateBase)) checkExt multidot ext candidateExts - FinalLit filename -> do - guard (null segs && filename == seg) + FinalLit isRecursive filename -> do + guard ((isRecursive == Recursive || null segs) && filename == seg) return (GlobMatch ()) checkExt @@ -181,12 +183,14 @@ Left EmptyGlob (filename : "**" : segments) | allowGlobStar -> do - ext <- case splitExtensions filename of + finalSegment <- case splitExtensions filename of ("*", ext) | '*' `elem` ext -> Left StarInExtension | null ext -> Left NoExtensionOnStar - | otherwise -> Right ext - _ -> Left LiteralFileNameGlobStar - foldM addStem (GlobFinal $ FinalMatch Recursive multidot ext) segments + | otherwise -> Right (FinalMatch Recursive multidot ext) + _ -> if allowLiteralFilenameGlobStar + then Right (FinalLit Recursive filename) + else Left LiteralFileNameGlobStar + foldM addStem (GlobFinal finalSegment) segments | otherwise -> Left VersionDoesNotSupportGlobStar (filename : segments) -> do pat <- case splitExtensions filename of @@ -196,7 +200,7 @@ | otherwise -> Right (FinalMatch NonRecursive multidot ext) (_, ext) | '*' `elem` ext -> Left StarInExtension | '*' `elem` filename -> Left StarInFileName - | otherwise -> Right (FinalLit filename) + | otherwise -> Right (FinalLit NonRecursive filename) foldM addStem (GlobFinal pat) segments where allowGlob = version >= CabalSpecV1_6 @@ -207,6 +211,7 @@ multidot | version >= CabalSpecV2_4 = MultiDotEnabled | otherwise = MultiDotDisabled + allowLiteralFilenameGlobStar = version >= CabalSpecV3_8 -- | This will 'die'' when the glob matches no files, or if the glob -- refers to a missing directory, or if the glob fails to parse. @@ -300,7 +305,20 @@ return $ mapMaybe checkName candidates else return [ GlobMissingDirectory joinedPrefix ] - FinalLit fn -> do + FinalLit Recursive fn -> do + let prefix = dir joinedPrefix + directoryExists <- doesDirectoryExist prefix + if directoryExists + then do + candidates <- getDirectoryContentsRecursive prefix + let checkName candidate + | takeFileName candidate == fn = Just $ GlobMatch (joinedPrefix candidate) + | otherwise = Nothing + return $ mapMaybe checkName candidates + else + return [ GlobMissingDirectory joinedPrefix ] + + FinalLit NonRecursive fn -> do exists <- doesFileExist (dir joinedPrefix fn) return [ GlobMatch (joinedPrefix fn) | exists ] diff --git a/src/Distribution/Simple/Haddock.hs b/src/Distribution/Simple/Haddock.hs --- a/src/Distribution/Simple/Haddock.hs +++ b/src/Distribution/Simple/Haddock.hs @@ -279,27 +279,23 @@ let libArgs' = commonArgs `mappend` libArgs runHaddock verbosity tmpFileOpts comp platform haddockProg libArgs' - case libName lib of - LMainLibName -> - pure index - LSubLibName _ -> do - pwd <- getCurrentDirectory + pwd <- getCurrentDirectory - let - ipi = inplaceInstalledPackageInfo - pwd (flag haddockDistPref) pkg_descr - (mkAbiHash "inplace") lib lbi' clbi + let + ipi = inplaceInstalledPackageInfo + pwd (flag haddockDistPref) pkg_descr + (mkAbiHash "inplace") lib lbi' clbi - debug verbosity $ "Registering inplace:\n" - ++ (InstalledPackageInfo.showInstalledPackageInfo ipi) + debug verbosity $ "Registering inplace:\n" + ++ (InstalledPackageInfo.showInstalledPackageInfo ipi) - registerPackage verbosity (compiler lbi') (withPrograms lbi') - (withPackageDB lbi') ipi - HcPkg.defaultRegisterOptions { - HcPkg.registerMultiInstance = True - } + registerPackage verbosity (compiler lbi') (withPrograms lbi') + (withPackageDB lbi') ipi + HcPkg.defaultRegisterOptions { + HcPkg.registerMultiInstance = True + } - return $ PackageIndex.insert ipi index + return $ PackageIndex.insert ipi index CFLib flib -> (when (flag haddockForeignLibs) $ do withTempDirectoryEx verbosity tmpFileOpts (buildDir lbi') "tmp" $ diff --git a/src/Distribution/Simple/PackageDescription.hs b/src/Distribution/Simple/PackageDescription.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/PackageDescription.hs @@ -0,0 +1,103 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.PackageDescription +-- Copyright : Isaac Jones 2003-2005 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This defines parsers for the @.cabal@ format + +module Distribution.Simple.PackageDescription ( + -- * Read and Parse files + readGenericPackageDescription, + readHookedBuildInfo, + + -- * Utility Parsing function + parseString, + ) where + +import Prelude () +import Distribution.Compat.Prelude + +import Distribution.Fields.ParseResult +import Distribution.PackageDescription +import Distribution.PackageDescription.Parsec + ( parseGenericPackageDescription, parseHookedBuildInfo ) +import Distribution.Parsec.Error ( showPError ) +import Distribution.Parsec.Warning + ( PWarning(..), PWarnType(PWTExperimental), showPWarning ) +import Distribution.Simple.Utils ( equating, die', warn ) +import Distribution.Verbosity ( normal, Verbosity ) + +import Data.List ( groupBy ) +import Text.Printf ( printf ) +import qualified Data.ByteString as BS +import System.Directory (doesFileExist) + +readGenericPackageDescription :: Verbosity -> FilePath -> IO GenericPackageDescription +readGenericPackageDescription = readAndParseFile parseGenericPackageDescription + +readHookedBuildInfo :: Verbosity -> FilePath -> IO HookedBuildInfo +readHookedBuildInfo = readAndParseFile parseHookedBuildInfo + +-- | Helper combinator to do parsing plumbing for files. +-- +-- Given a parser and a filename, return the parse of the file, +-- after checking if the file exists. +-- +-- Argument order is chosen to encourage partial application. +readAndParseFile + :: (BS.ByteString -> ParseResult a) -- ^ File contents to final value parser + -> Verbosity -- ^ Verbosity level + -> FilePath -- ^ File to read + -> IO a +readAndParseFile parser verbosity fpath = do + exists <- doesFileExist fpath + unless exists $ + die' verbosity $ + "Error Parsing: file \"" ++ fpath ++ "\" doesn't exist. Cannot continue." + bs <- BS.readFile fpath + parseString parser verbosity fpath bs + +parseString + :: (BS.ByteString -> ParseResult a) -- ^ File contents to final value parser + -> Verbosity -- ^ Verbosity level + -> String -- ^ File name + -> BS.ByteString + -> IO a +parseString parser verbosity name bs = do + let (warnings, result) = runParseResult (parser bs) + traverse_ (warn verbosity . showPWarning name) (flattenDups verbosity warnings) + case result of + Right x -> return x + Left (_, errors) -> do + traverse_ (warn verbosity . showPError name) errors + die' verbosity $ "Failed parsing \"" ++ name ++ "\"." + +-- | Collapse duplicate experimental feature warnings into single warning, with +-- a count of further sites +flattenDups :: Verbosity -> [PWarning] -> [PWarning] +flattenDups verbosity ws + | verbosity <= normal = rest ++ experimentals + | otherwise = ws -- show all instances + where + (exps, rest) = partition (\(PWarning w _ _) -> w == PWTExperimental) ws + experimentals = + concatMap flatCount + . groupBy (equating warningStr) + . sortBy (comparing warningStr) + $ exps + + warningStr (PWarning _ _ w) = w + + -- flatten if we have 3 or more examples + flatCount :: [PWarning] -> [PWarning] + flatCount w@[] = w + flatCount w@[_] = w + flatCount w@[_,_] = w + flatCount (PWarning t pos w:xs) = + [PWarning t pos + (w <> printf " (and %d more occurrences)" (length xs)) + ] diff --git a/src/Distribution/Simple/PreProcess.hs b/src/Distribution/Simple/PreProcess.hs --- a/src/Distribution/Simple/PreProcess.hs +++ b/src/Distribution/Simple/PreProcess.hs @@ -25,7 +25,8 @@ PPSuffixHandler, PreProcessor(..), mkSimplePreProcessor, runSimplePreProcessor, ppCpp, ppCpp', ppGreenCard, ppC2hs, ppHsc2hs, - ppHappy, ppAlex, ppUnlit, platformDefines + ppHappy, ppAlex, ppUnlit, platformDefines, + unsorted ) where @@ -50,12 +51,13 @@ import Distribution.Simple.Program.ResponseFile import Distribution.Simple.Test.LibV09 import Distribution.System +import Distribution.Types.PackageName.Magic import Distribution.Pretty import Distribution.Version import Distribution.Verbosity import Distribution.Utils.Path -import System.Directory (doesFileExist) +import System.Directory (doesFileExist, doesDirectoryExist) import System.Info (os, arch) import System.FilePath (splitExtension, dropExtensions, (), (<.>), takeDirectory, normalise, replaceExtension, @@ -109,12 +111,29 @@ -- eg alex and happy have --ghc flags. However we can't really include -- ghc-specific code into supposedly portable source tarballs. + -- | This function can reorder /all/ modules, not just those that the + -- require the preprocessor in question. As such, this function should be + -- well-behaved and not reorder modules it doesn't have dominion over! + ppOrdering :: Verbosity + -> [FilePath] -- Source directories + -> [ModuleName] -- Module names + -> IO [ModuleName], -- Sorted modules + runPreProcessor :: (FilePath, FilePath) -- Location of the source file relative to a base dir -> (FilePath, FilePath) -- Output file name, relative to an output base dir -> Verbosity -- verbosity -> IO () -- Should exit if the preprocessor fails } +-- | Just present the modules in the order given; this is the default and it is +-- appropriate for preprocessors which do not have any sort of dependencies +-- between modules. +unsorted :: Verbosity + -> [FilePath] + -> [ModuleName] + -> IO [ModuleName] +unsorted _ _ ms = pure ms + -- | Function to determine paths to possible extra C sources for a -- preprocessor: just takes the path to the build directory and uses -- this to search for C sources with names that match the @@ -153,61 +172,72 @@ -> Verbosity -> [PPSuffixHandler] -> IO () -preprocessComponent pd comp lbi clbi isSrcDist verbosity handlers = do - -- NB: never report instantiation here; we'll report it properly when - -- building. - setupMessage' verbosity "Preprocessing" (packageId pd) - (componentLocalName clbi) (Nothing :: Maybe [(ModuleName, Module)]) - case comp of - (CLib lib@Library{ libBuildInfo = bi }) -> do - let dirs = map getSymbolicPath (hsSourceDirs bi) ++ - [ autogenComponentModulesDir lbi clbi ,autogenPackageModulesDir lbi] - for_ (map ModuleName.toFilePath $ allLibModules lib clbi) $ - pre dirs (componentBuildDir lbi clbi) (localHandlers bi) - (CFLib flib@ForeignLib { foreignLibBuildInfo = bi, foreignLibName = nm }) -> do - let nm' = unUnqualComponentName nm - let flibDir = buildDir lbi nm' nm' ++ "-tmp" - dirs = map getSymbolicPath (hsSourceDirs bi) ++ [autogenComponentModulesDir lbi clbi - ,autogenPackageModulesDir lbi] - for_ (map ModuleName.toFilePath $ foreignLibModules flib) $ - pre dirs flibDir (localHandlers bi) - (CExe exe@Executable { buildInfo = bi, exeName = nm }) -> do - let nm' = unUnqualComponentName nm - let exeDir = buildDir lbi nm' nm' ++ "-tmp" - dirs = map getSymbolicPath (hsSourceDirs bi) ++ [autogenComponentModulesDir lbi clbi - ,autogenPackageModulesDir lbi] - for_ (map ModuleName.toFilePath $ otherModules bi) $ - pre dirs exeDir (localHandlers bi) - pre (map getSymbolicPath (hsSourceDirs bi)) exeDir (localHandlers bi) $ - dropExtensions (modulePath exe) - CTest test@TestSuite{ testName = nm } -> do - let nm' = unUnqualComponentName nm - case testInterface test of - TestSuiteExeV10 _ f -> - preProcessTest test f $ buildDir lbi nm' nm' ++ "-tmp" - TestSuiteLibV09 _ _ -> do - let testDir = buildDir lbi stubName test - stubName test ++ "-tmp" - writeSimpleTestStub test testDir - preProcessTest test (stubFilePath test) testDir - TestSuiteUnsupported tt -> - die' verbosity $ "No support for preprocessing test " - ++ "suite type " ++ prettyShow tt - CBench bm@Benchmark{ benchmarkName = nm } -> do - let nm' = unUnqualComponentName nm - case benchmarkInterface bm of - BenchmarkExeV10 _ f -> - preProcessBench bm f $ buildDir lbi nm' nm' ++ "-tmp" - BenchmarkUnsupported tt -> - die' verbosity $ "No support for preprocessing benchmark " - ++ "type " ++ prettyShow tt +preprocessComponent pd comp lbi clbi isSrcDist verbosity handlers = + -- Skip preprocessing for scripts since they should be regular Haskell files, + -- but may have no or unknown extensions. + when (package pd /= fakePackageId) $ do + -- NB: never report instantiation here; we'll report it properly when + -- building. + setupMessage' verbosity "Preprocessing" (packageId pd) + (componentLocalName clbi) (Nothing :: Maybe [(ModuleName, Module)]) + case comp of + (CLib lib@Library{ libBuildInfo = bi }) -> do + let dirs = map getSymbolicPath (hsSourceDirs bi) ++ + [ autogenComponentModulesDir lbi clbi ,autogenPackageModulesDir lbi] + let hndlrs = localHandlers bi + mods <- orderingFromHandlers verbosity dirs hndlrs (allLibModules lib clbi) + for_ (map ModuleName.toFilePath mods) $ + pre dirs (componentBuildDir lbi clbi) hndlrs + (CFLib flib@ForeignLib { foreignLibBuildInfo = bi, foreignLibName = nm }) -> do + let nm' = unUnqualComponentName nm + let flibDir = buildDir lbi nm' nm' ++ "-tmp" + dirs = map getSymbolicPath (hsSourceDirs bi) ++ [autogenComponentModulesDir lbi clbi + ,autogenPackageModulesDir lbi] + let hndlrs = localHandlers bi + mods <- orderingFromHandlers verbosity dirs hndlrs (foreignLibModules flib) + for_ (map ModuleName.toFilePath mods) $ + pre dirs flibDir hndlrs + (CExe exe@Executable { buildInfo = bi, exeName = nm }) -> do + let nm' = unUnqualComponentName nm + let exeDir = buildDir lbi nm' nm' ++ "-tmp" + dirs = map getSymbolicPath (hsSourceDirs bi) ++ [autogenComponentModulesDir lbi clbi + ,autogenPackageModulesDir lbi] + let hndlrs = localHandlers bi + mods <- orderingFromHandlers verbosity dirs hndlrs (otherModules bi) + for_ (map ModuleName.toFilePath mods) $ + pre dirs exeDir hndlrs + pre (map getSymbolicPath (hsSourceDirs bi)) exeDir (localHandlers bi) $ + dropExtensions (modulePath exe) + CTest test@TestSuite{ testName = nm } -> do + let nm' = unUnqualComponentName nm + case testInterface test of + TestSuiteExeV10 _ f -> + preProcessTest test f $ buildDir lbi nm' nm' ++ "-tmp" + TestSuiteLibV09 _ _ -> do + let testDir = buildDir lbi stubName test + stubName test ++ "-tmp" + writeSimpleTestStub test testDir + preProcessTest test (stubFilePath test) testDir + TestSuiteUnsupported tt -> + die' verbosity $ "No support for preprocessing test " + ++ "suite type " ++ prettyShow tt + CBench bm@Benchmark{ benchmarkName = nm } -> do + let nm' = unUnqualComponentName nm + case benchmarkInterface bm of + BenchmarkExeV10 _ f -> + preProcessBench bm f $ buildDir lbi nm' nm' ++ "-tmp" + BenchmarkUnsupported tt -> + die' verbosity $ "No support for preprocessing benchmark " + ++ "type " ++ prettyShow tt where + orderingFromHandlers v d hndlrs mods = + foldM (\acc (_,pp) -> ppOrdering pp v d acc) mods hndlrs builtinHaskellSuffixes = ["hs", "lhs", "hsig", "lhsig"] builtinCSuffixes = cSourceExtensions builtinSuffixes = builtinHaskellSuffixes ++ builtinCSuffixes localHandlers bi = [(ext, h bi lbi clbi) | (ext, h) <- handlers] pre dirs dir lhndlrs fp = - preprocessFile (map unsafeMakeSymbolicPath dirs) dir isSrcDist fp verbosity builtinSuffixes lhndlrs + preprocessFile (map unsafeMakeSymbolicPath dirs) dir isSrcDist fp verbosity builtinSuffixes lhndlrs True preProcessTest test = preProcessComponent (testBuildInfo test) (testModules test) preProcessBench bm = preProcessComponent (benchmarkBuildInfo bm) @@ -225,20 +255,20 @@ , autogenPackageModulesDir lbi ] sequence_ [ preprocessFile (map unsafeMakeSymbolicPath sourceDirs) dir isSrcDist (ModuleName.toFilePath modu) verbosity builtinSuffixes - biHandlers + biHandlers False | modu <- modules ] - -- XXX: what we do here (re SymbolicPath dir) -- XXX: 2020-10-15 do we rely here on CWD being the PackageDir? + -- Note we don't fail on missing in this case, because the main file may be generated later (i.e. by a test code generator) preprocessFile (unsafeMakeSymbolicPath dir : hsSourceDirs bi) dir isSrcDist (dropExtensions $ exePath) verbosity - builtinSuffixes biHandlers + builtinSuffixes biHandlers False --TODO: try to list all the modules that could not be found -- not just the first one. It's annoying and slow due to the need -- to reconfigure after editing the .cabal file each time. --- |Find the first extension of the file that exists, and preprocess it +-- | Find the first extension of the file that exists, and preprocess it -- if required. preprocessFile :: [SymbolicPath PackageDir SourceDir] -- ^ source directories @@ -249,8 +279,9 @@ -> Verbosity -- ^verbosity -> [String] -- ^builtin suffixes -> [(String, PreProcessor)] -- ^possible preprocessors + -> Bool -- ^fail on missing file -> IO () -preprocessFile searchLoc buildLoc forSDist baseFile verbosity builtinSuffixes handlers = do +preprocessFile searchLoc buildLoc forSDist baseFile verbosity builtinSuffixes handlers failOnMissing = do -- look for files in the various source dirs with this module name -- and a file extension of a known preprocessor psrcFiles <- findFileWithExtension' (map fst handlers) (map getSymbolicPath searchLoc) baseFile @@ -264,8 +295,8 @@ -- the rest of the build system being aware of it (somewhat dodgy) Nothing -> do bsrcFiles <- findFileWithExtension builtinSuffixes (buildLoc : map getSymbolicPath searchLoc) baseFile - case bsrcFiles of - Nothing -> + case (bsrcFiles, failOnMissing) of + (Nothing, True) -> die' verbosity $ "can't find source for " ++ baseFile ++ " in " ++ intercalate ", " (map getSymbolicPath searchLoc) _ -> return () @@ -332,6 +363,7 @@ ppGreenCard _ lbi _ = PreProcessor { platformIndependent = False, + ppOrdering = unsorted, runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> runDbProgram verbosity greencardProgram (withPrograms lbi) (["-tffi", "-o" ++ outFile, inFile]) @@ -343,6 +375,7 @@ ppUnlit = PreProcessor { platformIndependent = True, + ppOrdering = unsorted, runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> withUTF8FileContents inFile $ \contents -> either (writeUTF8File outFile) (die' verbosity) (unlit inFile contents) @@ -365,6 +398,7 @@ ppGhcCpp program xHs extraArgs _bi lbi clbi = PreProcessor { platformIndependent = False, + ppOrdering = unsorted, runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> do (prog, version, _) <- requireProgramVersion verbosity program anyVersion (withPrograms lbi) @@ -385,6 +419,7 @@ ppCpphs extraArgs _bi lbi clbi = PreProcessor { platformIndependent = False, + ppOrdering = unsorted, runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> do (cpphsProg, cpphsVersion, _) <- requireProgramVersion verbosity cpphsProgram anyVersion (withPrograms lbi) @@ -401,6 +436,7 @@ ppHsc2hs bi lbi clbi = PreProcessor { platformIndependent = False, + ppOrdering = unsorted, runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> do (gccProg, _) <- requireProgram verbosity gccProgram (withPrograms lbi) (hsc2hsProg, hsc2hsVersion, _) <- requireProgramVersion verbosity @@ -468,9 +504,19 @@ [ "-I" ++ autogenComponentModulesDir lbi clbi, "-I" ++ autogenPackageModulesDir lbi, "-include", autogenComponentModulesDir lbi clbi cppHeaderName ] ] - ++ [ "--lflag=-L" ++ opt | opt <- PD.extraLibDirs bi ] - ++ [ "--lflag=-Wl,-R," ++ opt | isELF - , opt <- PD.extraLibDirs bi ] + ++ [ "--lflag=-L" ++ opt + | opt <- + if withFullyStaticExe lbi + then PD.extraLibDirsStatic bi + else PD.extraLibDirs bi + ] + ++ [ "--lflag=-Wl,-R," ++ opt + | isELF + , opt <- + if withFullyStaticExe lbi + then PD.extraLibDirsStatic bi + else PD.extraLibDirs bi + ] ++ [ "--lflag=-l" ++ opt | opt <- PD.extraLibs bi ] ++ [ "--lflag=" ++ opt | opt <- PD.ldOptions bi ] @@ -484,7 +530,12 @@ , opt <- [ "-L" ++ opt | opt <- Installed.libraryDirs pkg ] ++ [ "-Wl,-R," ++ opt | isELF , opt <- Installed.libraryDirs pkg ] - ++ [ "-l" ++ opt | opt <- Installed.extraLibraries pkg ] + ++ [ "-l" ++ opt + | opt <- + if withFullyStaticExe lbi + then Installed.extraLibrariesStatic pkg + else Installed.extraLibraries pkg + ] ++ [ opt | opt <- Installed.ldOptions pkg ] ] ++ preccldFlags ++ hsc2hsOptions bi @@ -539,6 +590,7 @@ ppC2hs bi lbi clbi = PreProcessor { platformIndependent = False, + ppOrdering = unsorted, runPreProcessor = \(inBaseDir, inRelativeFile) (outBaseDir, outRelativeFile) verbosity -> do (c2hsProg, _, _) <- requireProgramVersion verbosity @@ -656,6 +708,7 @@ IOS -> ["ios"] Android -> ["android"] Ghcjs -> ["ghcjs"] + Wasi -> ["wasi"] Hurd -> ["hurd"] OtherOS _ -> [] archStr = case hostArch of @@ -670,12 +723,14 @@ SH -> [] IA64 -> ["ia64"] S390 -> ["s390"] + S390X -> ["s390x"] Alpha -> ["alpha"] Hppa -> ["hppa"] Rs6000 -> ["rs6000"] M68k -> ["m68k"] Vax -> ["vax"] JavaScript -> ["javascript"] + Wasm32 -> ["wasm32"] OtherArch _ -> [] ppHappy :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor @@ -698,6 +753,7 @@ standardPP lbi prog args = PreProcessor { platformIndependent = False, + ppOrdering = unsorted, runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> runDbProgram verbosity prog (withPrograms lbi) (args ++ ["-o", outFile, inFile]) @@ -757,9 +813,13 @@ ++ "type " ++ prettyShow tt where pp :: FilePath -> IO [FilePath] - pp dir = (map (dir ) . filter not_sub . concat) - <$> for knownExtrasHandlers - (withLexicalCallStack (\f -> f dir)) + pp dir = do + b <- doesDirectoryExist dir + if b + then (map (dir ) . filter not_sub . concat) + <$> for knownExtrasHandlers + (withLexicalCallStack (\f -> f dir)) + else pure [] -- TODO: This is a terrible hack to work around #3545 while we don't -- reorganize the directory layout. Basically, for the main -- library, we might accidentally pick up autogenerated sources for diff --git a/src/Distribution/Simple/Program/Ar.hs b/src/Distribution/Simple/Program/Ar.hs --- a/src/Distribution/Simple/Program/Ar.hs +++ b/src/Distribution/Simple/Program/Ar.hs @@ -24,7 +24,7 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BS8 import Distribution.Compat.CopyFile (filesEqual) -import Distribution.Simple.Compiler (arResponseFilesSupported) +import Distribution.Simple.Compiler (arResponseFilesSupported, arDashLSupported) import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..)) import Distribution.Simple.Program ( ProgramInvocation, arProgram, requireProgram ) @@ -68,17 +68,25 @@ -- do that. We have duplicates because of modules like "A.M" and "B.M" -- both make an object file "M.o" and ar does not consider the directory. -- + -- -- llvm-ar, which GHC >=9.4 uses on Windows, supports a "L" modifier + -- in "q" mode which compels the archiver to add the members of an input + -- archive to the output, rather than the archive itself. This is + -- necessary as GHC may produce .o files that are actually archives. See + -- https://gitlab.haskell.org/ghc/ghc/-/issues/21068. + -- -- Our solution is to use "ar r" in the simple case when one call is enough. -- When we need to call ar multiple times we use "ar q" and for the last -- call on OSX we use "ar qs" so that it'll make the index. let simpleArgs = case hostOS of OSX -> ["-r", "-s"] + _ | dashLSupported -> ["-qL"] _ -> ["-r"] initialArgs = ["-q"] finalArgs = case hostOS of OSX -> ["-q", "-s"] + _ | dashLSupported -> ["-qL"] _ -> ["-q"] extraArgs = verbosityOpts verbosity ++ [tmpPath] @@ -90,8 +98,10 @@ oldVersionManualOverride = fromFlagOrDefault False $ configUseResponseFiles $ configFlags lbi - responseArgumentsNotSupported = + responseArgumentsNotSupported = not (arResponseFilesSupported (compiler lbi)) + dashLSupported = + arDashLSupported (compiler lbi) invokeWithResponesFile :: FilePath -> ProgramInvocation invokeWithResponesFile atFile = diff --git a/src/Distribution/Simple/Program/GHC.hs b/src/Distribution/Simple/Program/GHC.hs --- a/src/Distribution/Simple/Program/GHC.hs +++ b/src/Distribution/Simple/Program/GHC.hs @@ -52,9 +52,9 @@ = argumentFilters . filter simpleFilters . filterRtsOpts $ ghcArgs where supportedGHCVersions :: VersionRange - supportedGHCVersions = intersectVersionRanges - (orLaterVersion (mkVersion [8,0])) - (earlierVersion (mkVersion [9,1])) + supportedGHCVersions = orLaterVersion (mkVersion [8,0]) + -- we (weakly) support unknown future GHC versions for the purpose + -- of filtering GHC arguments from :: Monoid m => [Int] -> m -> m from version flags @@ -333,6 +333,9 @@ -- | The main input files; could be .hs, .hi, .c, .o, depending on mode. ghcOptInputFiles :: NubListR FilePath, + -- | Script files with irregular extensions that need -x hs. + ghcOptInputScripts :: NubListR FilePath, + -- | The names of input Haskell modules, mainly for @--make@ mode. ghcOptInputModules :: NubListR ModuleName, @@ -412,6 +415,9 @@ -- @ghc -framework-path@ flag. ghcOptLinkFrameworkDirs :: NubListR String, + -- | Instruct GHC to link against @libHSrts@ when producing a shared library. + ghcOptLinkRts :: Flag Bool, + -- | Don't do the link step, useful in make mode; the @ghc -no-link@ flag. ghcOptNoLink :: Flag Bool, @@ -446,6 +452,9 @@ -- | Extra header files to include for old-style FFI; the @ghc -#include@ flag. ghcOptFfiIncludes :: NubListR FilePath, + -- | Program to use for the C and C++ compiler; the @ghc -pgmc@ flag. + ghcOptCcProgram :: Flag FilePath, + ---------------------------- -- Language and extensions @@ -589,6 +598,7 @@ , ghcOptExtraDefault opts , [ "-no-link" | flagBool ghcOptNoLink ] + , [ "-flink-rts" | flagBool ghcOptLinkRts ] --------------- -- Misc flags @@ -691,6 +701,7 @@ _ -> "-optc" in [ cxxflag ++ opt | opt <- ghcOptCxxOptions opts] , [ "-opta" ++ opt | opt <- ghcOptAsmOptions opts] + , concat [ ["-pgmc", cc] | cc <- flag ghcOptCcProgram ] ----------------- -- Linker stuff @@ -775,6 +786,7 @@ -- Specify the input file(s) first, so that in ghci the `main-is` module is -- in scope instead of the first module defined in `other-modules`. , flags ghcOptInputFiles + , concat [ [ "-x", "hs", script] | script <- flags ghcOptInputScripts ] , [ prettyShow modu | modu <- flags ghcOptInputModules ] , concat [ [ "-o", out] | out <- flag ghcOptOutputFile ] diff --git a/src/Distribution/Simple/Program/HcPkg.hs b/src/Distribution/Simple/Program/HcPkg.hs --- a/src/Distribution/Simple/Program/HcPkg.hs +++ b/src/Distribution/Simple/Program/HcPkg.hs @@ -314,6 +314,7 @@ importDirs = mungePaths (importDirs pkginfo), includeDirs = mungePaths (includeDirs pkginfo), libraryDirs = mungePaths (libraryDirs pkginfo), + libraryDirsStatic = mungePaths (libraryDirsStatic pkginfo), libraryDynDirs = mungePaths (libraryDynDirs pkginfo), frameworkDirs = mungePaths (frameworkDirs pkginfo), haddockInterfaces = mungePaths (haddockInterfaces pkginfo), diff --git a/src/Distribution/Simple/Program/Script.hs b/src/Distribution/Simple/Program/Script.hs --- a/src/Distribution/Simple/Program/Script.hs +++ b/src/Distribution/Simple/Program/Script.hs @@ -48,7 +48,7 @@ ++ [ "cd " ++ quote cwd | cwd <- maybeToList mcwd ] ++ [ (case minput of Nothing -> "" - Just input -> "echo " ++ quote (iodataToText input) ++ " | ") + Just input -> "printf '%s' " ++ quote (iodataToText input) ++ " | ") ++ unwords (map quote $ path : args) ++ " \"$@\""] where diff --git a/src/Distribution/Simple/Register.hs b/src/Distribution/Simple/Register.hs --- a/src/Distribution/Simple/Register.hs +++ b/src/Distribution/Simple/Register.hs @@ -425,12 +425,14 @@ IPI.trusted = IPI.trusted IPI.emptyInstalledPackageInfo, IPI.importDirs = [ libdir installDirs | hasModules ], IPI.libraryDirs = libdirs, + IPI.libraryDirsStatic = libdirsStatic, IPI.libraryDynDirs = dynlibdirs, IPI.dataDir = datadir installDirs, IPI.hsLibraries = (if hasLibrary then [getHSLibraryName (componentUnitId clbi)] else []) ++ extraBundledLibs bi, IPI.extraLibraries = extraLibs bi, + IPI.extraLibrariesStatic = extraLibsStatic bi, IPI.extraGHCiLibraries = extraGHCiLibs bi, IPI.includeDirs = absinc ++ adjustRelIncDirs relinc, IPI.includes = includes bi, @@ -467,6 +469,16 @@ || (not (null (jsSources bi)) && compilerFlavor comp == GHCJS)) && not (componentIsIndefinite clbi) + libdirsStatic + | hasLibrary = libdir installDirs : extraLibDirsStaticOrFallback + | otherwise = extraLibDirsStaticOrFallback + where + -- If no static library dirs were given, the package likely makes no + -- distinction between fully static linking and otherwise. + -- Fall back to the normal library dirs in that case. + extraLibDirsStaticOrFallback = case extraLibDirsStatic bi of + [] -> extraLibDirs bi + dirs -> dirs (libdirs, dynlibdirs) | not hasLibrary = (extraLibDirs bi, []) diff --git a/src/Distribution/Simple/Setup.hs b/src/Distribution/Simple/Setup.hs --- a/src/Distribution/Simple/Setup.hs +++ b/src/Distribution/Simple/Setup.hs @@ -38,15 +38,16 @@ GlobalFlags(..), emptyGlobalFlags, defaultGlobalFlags, globalCommand, ConfigFlags(..), emptyConfigFlags, defaultConfigFlags, configureCommand, configPrograms, - configAbsolutePaths, readPackageDbList, showPackageDbList, + configAbsolutePaths, readPackageDb, readPackageDbList, showPackageDb, showPackageDbList, CopyFlags(..), emptyCopyFlags, defaultCopyFlags, copyCommand, InstallFlags(..), emptyInstallFlags, defaultInstallFlags, installCommand, HaddockTarget(..), HaddockFlags(..), emptyHaddockFlags, defaultHaddockFlags, haddockCommand, HscolourFlags(..), emptyHscolourFlags, defaultHscolourFlags, hscolourCommand, BuildFlags(..), emptyBuildFlags, defaultBuildFlags, buildCommand, - ShowBuildInfoFlags(..), defaultShowBuildFlags, showBuildInfoCommand, + DumpBuildInfo(..), ReplFlags(..), defaultReplFlags, replCommand, + ReplOptions(..), CleanFlags(..), emptyCleanFlags, defaultCleanFlags, cleanCommand, RegisterFlags(..), emptyRegisterFlags, defaultRegisterFlags, registerCommand, unregisterCommand, @@ -98,6 +99,7 @@ import Distribution.Verbosity import Distribution.Utils.NubList import Distribution.Types.ComponentId +import Distribution.Types.DumpBuildInfo import Distribution.Types.GivenComponent import Distribution.Types.Module import Distribution.Types.PackageVersionConstraint @@ -200,7 +202,6 @@ -- ProgramDb directly and not via ConfigFlags configPrograms_ :: Option' (Last' ProgramDb), -- ^All programs that -- @cabal@ may run - configProgramPaths :: [(String, FilePath)], -- ^user specified programs paths configProgramArgs :: [(String, [String])], -- ^user specified programs args configProgramPathExtra :: NubList FilePath, -- ^Extend the $PATH @@ -232,6 +233,9 @@ -- paths configScratchDir :: Flag FilePath, configExtraLibDirs :: [FilePath], -- ^ path to search for extra libraries + configExtraLibDirsStatic :: [FilePath], -- ^ path to search for extra + -- libraries when linking + -- fully static executables configExtraFrameworkDirs :: [FilePath], -- ^ path to search for extra -- frameworks (OS X only) configExtraIncludeDirs :: [FilePath], -- ^ path to search for header files @@ -271,6 +275,11 @@ -- ^Halt and show an error message indicating an error in flag assignment configRelocatable :: Flag Bool, -- ^ Enable relocatable package built configDebugInfo :: Flag DebugInfoLevel, -- ^ Emit debug info. + configDumpBuildInfo :: Flag DumpBuildInfo, + -- ^ Should we dump available build information on build? + -- Dump build information to disk before attempting to build, + -- tooling can parse these files and use them to compile the + -- source files themselves. configUseResponseFiles :: Flag Bool, -- ^ Whether to use response files at all. They're used for such tools -- as haddock, or ld. @@ -316,6 +325,7 @@ && equal configInstallDirs && equal configScratchDir && equal configExtraLibDirs + && equal configExtraLibDirsStatic && equal configExtraIncludeDirs && equal configIPID && equal configDeterministic @@ -339,6 +349,7 @@ && equal configFlagError && equal configRelocatable && equal configDebugInfo + && equal configDumpBuildInfo && equal configUseResponseFiles where equal f = on (==) f a b @@ -372,8 +383,8 @@ configVerbosity = Flag normal, configUserInstall = Flag False, --TODO: reverse this #if defined(mingw32_HOST_OS) - -- See #1589. - configGHCiLib = Flag True, + -- See #8062 and GHC #21019. + configGHCiLib = Flag False, #else configGHCiLib = NoFlag, #endif @@ -389,6 +400,7 @@ configFlagError = NoFlag, configRelocatable = Flag False, configDebugInfo = Flag NoDebugInfo, + configDumpBuildInfo = NoFlag, configUseResponseFiles = NoFlag } @@ -557,6 +569,17 @@ "Don't emit debug info" ] + , multiOption "build-info" + configDumpBuildInfo + (\v flags -> flags { configDumpBuildInfo = v }) + [noArg (Flag DumpBuildInfo) [] + ["enable-build-info"] + "Enable build information generation during project building", + noArg (Flag NoDumpBuildInfo) [] + ["disable-build-info"] + "Disable build information generation during project building" + ] + ,option "" ["library-for-ghci"] "compile library for use with GHCi" configGHCiLib (\v flags -> flags { configGHCiLib = v }) @@ -634,6 +657,11 @@ configExtraLibDirs (\v flags -> flags {configExtraLibDirs = v}) (reqArg' "PATH" (\x -> [x]) id) + ,option "" ["extra-lib-dirs-static"] + "A list of directories to search for external libraries when linking fully static executables" + configExtraLibDirsStatic (\v flags -> flags {configExtraLibDirsStatic = v}) + (reqArg' "PATH" (\x -> [x]) id) + ,option "" ["extra-framework-dirs"] "A list of directories to search for external frameworks (OS X only)" configExtraFrameworkDirs @@ -723,19 +751,29 @@ (fmap fromPathTemplate . get) (set . fmap toPathTemplate) readPackageDbList :: String -> [Maybe PackageDB] -readPackageDbList "clear" = [Nothing] -readPackageDbList "global" = [Just GlobalPackageDB] -readPackageDbList "user" = [Just UserPackageDB] -readPackageDbList other = [Just (SpecificPackageDB other)] +readPackageDbList str = [readPackageDb str] +-- | Parse a PackageDB stack entry +-- +-- @since 3.7.0.0 +readPackageDb :: String -> Maybe PackageDB +readPackageDb "clear" = Nothing +readPackageDb "global" = Just GlobalPackageDB +readPackageDb "user" = Just UserPackageDB +readPackageDb other = Just (SpecificPackageDB other) + showPackageDbList :: [Maybe PackageDB] -> [String] showPackageDbList = map showPackageDb - where - showPackageDb Nothing = "clear" - showPackageDb (Just GlobalPackageDB) = "global" - showPackageDb (Just UserPackageDB) = "user" - showPackageDb (Just (SpecificPackageDB db)) = db +-- | Show a PackageDB stack entry +-- +-- @since 3.7.0.0 +showPackageDb :: Maybe PackageDB -> String +showPackageDb Nothing = "clear" +showPackageDb (Just GlobalPackageDB) = "global" +showPackageDb (Just UserPackageDB) = "user" +showPackageDb (Just (SpecificPackageDB db)) = db + showProfDetailLevelFlag :: Flag ProfDetailLevel -> [String] showProfDetailLevelFlag NoFlag = [] showProfDetailLevelFlag (Flag dl) = [showProfDetailLevel dl] @@ -1657,13 +1695,30 @@ -- * REPL Flags -- ------------------------------------------------------------ +data ReplOptions = ReplOptions { + replOptionsFlags :: [String], + replOptionsNoLoad :: Flag Bool + } + deriving (Show, Generic, Typeable) + +instance Binary ReplOptions +instance Structured ReplOptions + + +instance Monoid ReplOptions where + mempty = ReplOptions mempty (Flag False) + mappend = (<>) + +instance Semigroup ReplOptions where + (<>) = gmappend + data ReplFlags = ReplFlags { replProgramPaths :: [(String, FilePath)], replProgramArgs :: [(String, [String])], replDistPref :: Flag FilePath, replVerbosity :: Flag Verbosity, replReload :: Flag Bool, - replReplOptions :: [String] + replReplOptions :: ReplOptions } deriving (Show, Generic, Typeable) @@ -1674,7 +1729,7 @@ replDistPref = NoFlag, replVerbosity = Flag normal, replReload = Flag False, - replReplOptions = [] + replReplOptions = mempty } instance Monoid ReplFlags where @@ -1755,9 +1810,17 @@ where liftReplOption = liftOption replReplOptions (\v flags -> flags { replReplOptions = v }) -replOptions :: ShowOrParseArgs -> [OptionField [String]] -replOptions _ = [ option [] ["repl-options"] "use this option for the repl" id - const (reqArg "FLAG" (succeedReadE (:[])) id) ] +replOptions :: ShowOrParseArgs -> [OptionField ReplOptions] +replOptions _ = + [ option [] ["repl-no-load"] + "Disable loading of project modules at REPL startup." + replOptionsNoLoad (\p flags -> flags { replOptionsNoLoad = p }) + trueArg + , option [] ["repl-options"] + "Use the option(s) for the repl" + replOptionsFlags (\p flags -> flags { replOptionsFlags = p }) + (reqArg "FLAG" (succeedReadE words) id) + ] -- ------------------------------------------------------------ -- * Test flags @@ -1823,16 +1886,8 @@ { commandName = "test" , commandSynopsis = "Run all/specific tests in the test suite." - , commandDescription = Just $ \pname -> wrapText $ - "If necessary (re)configures with `--enable-tests` flag and builds" - ++ " the test suite.\n" - ++ "\n" - ++ "Remember that the tests' dependencies must be installed if there" - ++ " are additional ones; e.g. with `" ++ pname - ++ " install --only-dependencies --enable-tests`.\n" - ++ "\n" - ++ "By defining UserHooks in a custom Setup.hs, the package can" - ++ " define actions to be executed before and after running tests.\n" + , commandDescription = Just $ \ _pname -> wrapText $ + testOrBenchmarkHelpText "test" , commandNotes = Nothing , commandUsage = usageAlternatives "test" [ "[FLAGS]" @@ -1842,6 +1897,24 @@ , commandOptions = testOptions' } +-- | Help text for @test@ and @bench@ commands. +testOrBenchmarkHelpText + :: String -- ^ Either @"test"@ or @"benchmark"@. + -> String -- ^ Help text. +testOrBenchmarkHelpText s = unlines $ map unwords + [ [ "The package must have been build with configuration" + , concat [ "flag `--enable-", s, "s`." ] + ] + , [] -- blank line + , [ concat [ "Note that additional dependencies of the ", s, "s" ] + , "must have already been installed." + ] + , [] + , [ "By defining UserHooks in a custom Setup.hs, the package can define" + , concat [ "actions to be executed before and after running ", s, "s." ] + ] + ] + testOptions' :: ShowOrParseArgs -> [OptionField TestFlags] testOptions' showOrParseArgs = [ optionVerbosity testVerbosity (\v flags -> flags { testVerbosity = v }) @@ -1937,17 +2010,8 @@ { commandName = "bench" , commandSynopsis = "Run all/specific benchmarks." - , commandDescription = Just $ \pname -> wrapText $ - "If necessary (re)configures with `--enable-benchmarks` flag and" - ++ " builds the benchmarks.\n" - ++ "\n" - ++ "Remember that the benchmarks' dependencies must be installed if" - ++ " there are additional ones; e.g. with `" ++ pname - ++ " install --only-dependencies --enable-benchmarks`.\n" - ++ "\n" - ++ "By defining UserHooks in a custom Setup.hs, the package can" - ++ " define actions to be executed before and after running" - ++ " benchmarks.\n" + , commandDescription = Just $ \ _pname -> wrapText $ + testOrBenchmarkHelpText "benchmark" , commandNotes = Nothing , commandUsage = usageAlternatives "bench" [ "[FLAGS]" @@ -2147,81 +2211,6 @@ | n < 1 -> Left "The number of jobs should be 1 or more." | otherwise -> Right (Just n) _ -> Left "The jobs value should be a number or '$ncpus'" - - --- ------------------------------------------------------------ --- * show-build-info command flags --- ------------------------------------------------------------ - -data ShowBuildInfoFlags = ShowBuildInfoFlags - { buildInfoBuildFlags :: BuildFlags - , buildInfoOutputFile :: Maybe FilePath - } deriving (Show, Typeable) - -defaultShowBuildFlags :: ShowBuildInfoFlags -defaultShowBuildFlags = - ShowBuildInfoFlags - { buildInfoBuildFlags = defaultBuildFlags - , buildInfoOutputFile = Nothing - } - -showBuildInfoCommand :: ProgramDb -> CommandUI ShowBuildInfoFlags -showBuildInfoCommand progDb = CommandUI - { commandName = "show-build-info" - , commandSynopsis = "Emit details about how a package would be built." - , commandDescription = Just $ \_ -> wrapText $ - "Components encompass executables, tests, and benchmarks.\n" - ++ "\n" - ++ "Affected by configuration options, see `configure`.\n" - , commandNotes = Just $ \pname -> - "Examples:\n" - ++ " " ++ pname ++ " show-build-info " - ++ " All the components in the package\n" - ++ " " ++ pname ++ " show-build-info foo " - ++ " A component (i.e. lib, exe, test suite)\n\n" - ++ programFlagsDescription progDb ---TODO: re-enable once we have support for module/file targets --- ++ " " ++ pname ++ " show-build-info Foo.Bar " --- ++ " A module\n" --- ++ " " ++ pname ++ " show-build-info Foo/Bar.hs" --- ++ " A file\n\n" --- ++ "If a target is ambiguous it can be qualified with the component " --- ++ "name, e.g.\n" --- ++ " " ++ pname ++ " show-build-info foo:Foo.Bar\n" --- ++ " " ++ pname ++ " show-build-info testsuite1:Foo/Bar.hs\n" - , commandUsage = usageAlternatives "show-build-info" $ - [ "[FLAGS]" - , "COMPONENTS [FLAGS]" - ] - , commandDefaultFlags = defaultShowBuildFlags - , commandOptions = \showOrParseArgs -> - parseBuildFlagsForShowBuildInfoFlags showOrParseArgs progDb - ++ - [ option [] ["buildinfo-json-output"] - "Write the result to the given file instead of stdout" - buildInfoOutputFile (\pf flags -> flags { buildInfoOutputFile = pf }) - (reqArg' "FILE" Just (maybe [] pure)) - ] - - } - -parseBuildFlagsForShowBuildInfoFlags :: ShowOrParseArgs -> ProgramDb -> [OptionField ShowBuildInfoFlags] -parseBuildFlagsForShowBuildInfoFlags showOrParseArgs progDb = - map - (liftOption - buildInfoBuildFlags - (\bf flags -> flags { buildInfoBuildFlags = bf } ) - ) - buildFlags - where - buildFlags = buildOptions progDb showOrParseArgs - ++ - [ optionVerbosity - buildVerbosity (\v flags -> flags { buildVerbosity = v }) - - , optionDistPref - buildDistPref (\d flags -> flags { buildDistPref = d }) showOrParseArgs - ] -- ------------------------------------------------------------ -- * Other Utils diff --git a/src/Distribution/Simple/ShowBuildInfo.hs b/src/Distribution/Simple/ShowBuildInfo.hs --- a/src/Distribution/Simple/ShowBuildInfo.hs +++ b/src/Distribution/Simple/ShowBuildInfo.hs @@ -2,7 +2,7 @@ -- This module defines a simple JSON-based format for exporting basic -- information about a Cabal package and the compiler configuration Cabal -- would use to build it. This can be produced with the --- @cabal new-show-build-info@ command. +-- @cabal build --enable-build-info@ command. -- -- -- This format is intended for consumption by external tooling and should @@ -14,7 +14,7 @@ -- Below is an example of the output this module produces, -- -- @ --- { "cabal-version": "1.23.0.0", +-- { "cabal-lib-version": "1.23.0.0", -- "compiler": { -- "flavour": "GHC", -- "compiler-id": "ghc-7.10.2", @@ -34,7 +34,10 @@ -- } -- @ -- --- The @cabal-version@ property provides the version of the Cabal library +-- The output format needs to be validated against 'doc/json-schemas/build-info.schema.json'. +-- If the format changes, update the schema as well! +-- +-- The @cabal-lib-version@ property provides the version of the Cabal library -- which generated the output. The @compiler@ property gives some basic -- information about the compiler Cabal would use to compile the package. -- @@ -54,8 +57,14 @@ -- Note: At the moment this is only supported when using the GHC compiler. -- -module Distribution.Simple.ShowBuildInfo (mkBuildInfo) where +{-# LANGUAGE OverloadedStrings #-} +module Distribution.Simple.ShowBuildInfo ( + mkBuildInfo, mkBuildInfo', mkCompilerInfo, mkComponentInfo + ) where + +import System.FilePath + import Distribution.Compat.Prelude import Prelude () @@ -65,82 +74,110 @@ import Distribution.PackageDescription import Distribution.Compiler import Distribution.Verbosity -import Distribution.Simple.Compiler -import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.Compiler (Compiler, showCompilerId, compilerFlavor) import Distribution.Simple.Program import Distribution.Simple.Setup import Distribution.Simple.Utils (cabalVersion) -import Distribution.Simple.Utils.Json +import Distribution.Utils.Json +import Distribution.Types.Component +import Distribution.Types.ComponentLocalBuildInfo +import Distribution.Types.LocalBuildInfo import Distribution.Types.TargetInfo import Distribution.Text import Distribution.Pretty -import Distribution.Utils.Path -- | Construct a JSON document describing the build information for a -- package. mkBuildInfo - :: PackageDescription -- ^ Mostly information from the .cabal file + :: FilePath -- ^ The source directory of the package + -> PackageDescription -- ^ Mostly information from the .cabal file -> LocalBuildInfo -- ^ Configuration information -> BuildFlags -- ^ Flags that the user passed to build + -> (ConfiguredProgram, Compiler) + -- ^ Compiler information. + -- Needs to be passed explicitly, as we can't extract that information here + -- without some partial function. -> [TargetInfo] - -> Json -mkBuildInfo pkg_descr lbi _flags targetsToBuild = info + -> ([String], Json) -- ^ Json representation of buildinfo alongside generated warnings +mkBuildInfo wdir pkg_descr lbi _flags compilerInfo targetsToBuild = (warnings, JsonObject buildInfoFields) where - targetToNameAndLBI target = - (componentLocalName $ targetCLBI target, targetCLBI target) - componentsToBuild = map targetToNameAndLBI targetsToBuild - (.=) :: String -> Json -> (String, Json) - k .= v = (k, v) + buildInfoFields = mkBuildInfo' (uncurry mkCompilerInfo compilerInfo) componentInfos + componentInfosWithWarnings = map (mkComponentInfo wdir pkg_descr lbi . targetCLBI) targetsToBuild + componentInfos = map snd componentInfosWithWarnings + warnings = concatMap fst componentInfosWithWarnings - info = JsonObject - [ "cabal-version" .= JsonString (display cabalVersion) - , "compiler" .= mkCompilerInfo - , "components" .= JsonArray (map mkComponentInfo componentsToBuild) - ] +-- | A variant of 'mkBuildInfo' if you need to call 'mkCompilerInfo' and +-- 'mkComponentInfo' yourself. +-- +-- If you change the format or any name in the output json, don't forget to update +-- the schema at @\/doc\/json-schemas\/build-info.schema.json@ and the docs of +-- @--enable-build-info@\/@--disable-build-info@. +mkBuildInfo' + :: Json -- ^ The 'Json' from 'mkCompilerInfo' + -> [Json] -- ^ The 'Json' from 'mkComponentInfo' + -> [(String, Json)] +mkBuildInfo' compilerInfo componentInfos = + [ "cabal-lib-version" .= JsonString (display cabalVersion) + , "compiler" .= compilerInfo + , "components" .= JsonArray componentInfos + ] - mkCompilerInfo = JsonObject - [ "flavour" .= JsonString (prettyShow $ compilerFlavor $ compiler lbi) - , "compiler-id" .= JsonString (showCompilerId $ compiler lbi) - , "path" .= path - ] - where - path = maybe JsonNull (JsonString . programPath) - $ (flavorToProgram . compilerFlavor $ compiler lbi) - >>= flip lookupProgram (withPrograms lbi) +mkCompilerInfo :: ConfiguredProgram -> Compiler -> Json +mkCompilerInfo compilerProgram compilerInfo = JsonObject + [ "flavour" .= JsonString (prettyShow $ compilerFlavor compilerInfo) + , "compiler-id" .= JsonString (showCompilerId compilerInfo) + , "path" .= JsonString (programPath compilerProgram) + ] - flavorToProgram :: CompilerFlavor -> Maybe Program - flavorToProgram GHC = Just ghcProgram - flavorToProgram GHCJS = Just ghcjsProgram - flavorToProgram UHC = Just uhcProgram - flavorToProgram JHC = Just jhcProgram - flavorToProgram _ = Nothing +mkComponentInfo :: FilePath -> PackageDescription -> LocalBuildInfo -> ComponentLocalBuildInfo -> ([String], Json) +mkComponentInfo wdir pkg_descr lbi clbi = (warnings, JsonObject $ + [ "type" .= JsonString compType + , "name" .= JsonString (prettyShow name) + , "unit-id" .= JsonString (prettyShow $ componentUnitId clbi) + , "compiler-args" .= JsonArray (map JsonString compilerArgs) + , "modules" .= JsonArray (map (JsonString . display) modules) + , "src-files" .= JsonArray (map JsonString sourceFiles) + , "hs-src-dirs" .= JsonArray (map (JsonString . prettyShow) $ hsSourceDirs bi) + , "src-dir" .= JsonString (addTrailingPathSeparator wdir) + ] <> cabalFile) + where + (warnings, compilerArgs) = getCompilerArgs bi lbi clbi + name = componentLocalName clbi + bi = componentBuildInfo comp + -- If this error happens, a cabal invariant has been violated + comp = fromMaybe (error $ "mkBuildInfo: no component " ++ prettyShow name) $ lookupComponent pkg_descr name + compType = case comp of + CLib _ -> "lib" + CExe _ -> "exe" + CTest _ -> "test" + CBench _ -> "bench" + CFLib _ -> "flib" + modules = case comp of + CLib lib -> explicitLibModules lib + CExe exe -> exeModules exe + CTest test -> + case testInterface test of + TestSuiteExeV10 _ _ -> [] + TestSuiteLibV09 _ modName -> [modName] + TestSuiteUnsupported _ -> [] + CBench bench -> benchmarkModules bench + CFLib flib -> foreignLibModules flib + sourceFiles = case comp of + CLib _ -> [] + CExe exe -> [modulePath exe] + CTest test -> + case testInterface test of + TestSuiteExeV10 _ fp -> [fp] + TestSuiteLibV09 _ _ -> [] + TestSuiteUnsupported _ -> [] + CBench bench -> case benchmarkInterface bench of + BenchmarkExeV10 _ fp -> [fp] + BenchmarkUnsupported _ -> [] - mkComponentInfo (name, clbi) = JsonObject - [ "type" .= JsonString compType - , "name" .= JsonString (prettyShow name) - , "unit-id" .= JsonString (prettyShow $ componentUnitId clbi) - , "compiler-args" .= JsonArray (map JsonString $ getCompilerArgs bi lbi clbi) - , "modules" .= JsonArray (map (JsonString . display) modules) - , "src-files" .= JsonArray (map JsonString sourceFiles) - , "src-dirs" .= JsonArray (map JsonString $ map getSymbolicPath $ hsSourceDirs bi) - ] - where - bi = componentBuildInfo comp - comp = fromMaybe (error $ "mkBuildInfo: no component " ++ prettyShow name) $ lookupComponent pkg_descr name - compType = case comp of - CLib _ -> "lib" - CExe _ -> "exe" - CTest _ -> "test" - CBench _ -> "bench" - CFLib _ -> "flib" - modules = case comp of - CLib lib -> explicitLibModules lib - CExe exe -> exeModules exe - _ -> [] - sourceFiles = case comp of - CLib _ -> [] - CExe exe -> [modulePath exe] - _ -> [] + CFLib _ -> [] + cabalFile + | Just fp <- pkgDescrFile lbi = [("cabal-file", JsonString fp)] + | otherwise = [] -- | Get the command-line arguments that would be passed -- to the compiler to build the given component. @@ -148,13 +185,15 @@ :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo - -> [String] + -> ([String], [String]) getCompilerArgs bi lbi clbi = case compilerFlavor $ compiler lbi of - GHC -> ghc - GHCJS -> ghc - c -> error $ "ShowBuildInfo.getCompilerArgs: Don't know how to get "++ - "build arguments for compiler "++show c + GHC -> ([], ghc) + GHCJS -> ([], ghc) + c -> + ( ["ShowBuildInfo.getCompilerArgs: Don't know how to get build " + ++ " arguments for compiler " ++ show c] + , []) where -- This is absolutely awful ghc = GHC.renderGhcOptions (compiler lbi) (hostPlatform lbi) baseOpts diff --git a/src/Distribution/Simple/SrcDist.hs b/src/Distribution/Simple/SrcDist.hs --- a/src/Distribution/Simple/SrcDist.hs +++ b/src/Distribution/Simple/SrcDist.hs @@ -125,7 +125,7 @@ -- -- Since @Cabal-3.4@ returns a single list. There shouldn't be any -- executable files, they are hardly portable. --- +-- listPackageSources :: Verbosity -- ^ verbosity -> FilePath -- ^ directory with cabal file @@ -145,7 +145,11 @@ -- Since @3.4.0.0 listPackageSourcesWithDie :: Verbosity -- ^ verbosity - -> (Verbosity -> String -> IO [FilePath]) -- ^ 'die'' alternative + -> (Verbosity -> String -> IO [FilePath]) + -- ^ 'die'' alternative. + -- Since 'die'' prefixes the error message with 'errorPrefix', + -- whatever is passed in here and wants to die should do the same. + -- See issue #7331. -> FilePath -- ^ directory with cabal file -> PackageDescription -- ^ info from the cabal file -> [PPSuffixHandler] -- ^ extra preprocessors (include suffixes) @@ -159,11 +163,20 @@ listPackageSources' :: Verbosity + -- ^ verbosity -> (Verbosity -> String -> IO [FilePath]) + -- ^ 'die'' alternative. + -- Since 'die'' prefixes the error message with 'errorPrefix', + -- whatever is passed in here and wants to die should do the same. + -- See issue #7331. -> FilePath + -- ^ directory with cabal file -> PackageDescription + -- ^ info from the cabal file -> [PPSuffixHandler] + -- ^ extra preprocessors (include suffixes) -> IO [FilePath] + -- ^ relative paths listPackageSources' verbosity rip cwd pkg_descr pps = fmap concat . sequenceA $ [ @@ -263,10 +276,10 @@ -- |Prepare a directory tree of source files. -prepareTree :: Verbosity -- ^verbosity - -> PackageDescription -- ^info from the cabal file - -> FilePath -- ^source tree to populate - -> [PPSuffixHandler] -- ^extra preprocessors (includes suffixes) +prepareTree :: Verbosity -- ^ verbosity + -> PackageDescription -- ^ info from the cabal file + -> FilePath -- ^ source tree to populate + -> [PPSuffixHandler] -- ^ extra preprocessors (includes suffixes) -> IO () prepareTree verbosity pkg_descr0 targetDir pps = do ordinary <- listPackageSources verbosity "." pkg_descr pps @@ -333,7 +346,7 @@ b <- doesFileExist (cwd path) if b then return (f,path) else findIncludeFile verbosity cwd ds f --- | Remove the auto-generated modules (like 'Paths_*') from 'exposed-modules' +-- | Remove the auto-generated modules (like 'Paths_*') from 'exposed-modules' -- and 'other-modules'. filterAutogenModules :: PackageDescription -> PackageDescription filterAutogenModules pkg_descr0 = mapLib filterAutogenModuleLib $ @@ -438,6 +451,10 @@ allSourcesBuildInfo :: Verbosity -> (Verbosity -> String -> IO [FilePath]) + -- ^ 'die'' alternative. + -- Since 'die'' prefixes the error message with 'errorPrefix', + -- whatever is passed in here and wants to die should do the same. + -- See issue #7331. -> FilePath -- ^ cwd -- change me to 'BuildPath Absolute PackageDir' -> BuildInfo -> [PPSuffixHandler] -- ^ Extra preprocessors @@ -470,7 +487,7 @@ suffixes = ppSuffixes pps ++ ["hs", "lhs", "hsig", "lhsig"] notFound :: ModuleName -> IO [FilePath] - notFound m = rip verbosity $ "Error: Could not find module: " ++ prettyShow m + notFound m = rip verbosity $ "Could not find module: " ++ prettyShow m ++ " with any suffix: " ++ show suffixes ++ ". If the module " ++ "is autogenerated it should be added to 'autogen-modules'." diff --git a/src/Distribution/Simple/Test/ExeV10.hs b/src/Distribution/Simple/Test/ExeV10.hs --- a/src/Distribution/Simple/Test/ExeV10.hs +++ b/src/Distribution/Simple/Test/ExeV10.hs @@ -9,7 +9,6 @@ import Distribution.Compat.Prelude import Distribution.Types.UnqualComponentName -import Distribution.Compat.CreatePipe import Distribution.Compat.Environment import qualified Distribution.PackageDescription as PD import Distribution.Simple.Build.PathsModule @@ -32,6 +31,7 @@ , getCurrentDirectory, removeDirectoryRecursive ) import System.FilePath ( (), (<.>) ) import System.IO ( stdout, stderr ) +import System.Process ( createPipe ) import qualified Data.ByteString.Lazy as LBS @@ -53,7 +53,7 @@ testName' <.> exeExtension (LBI.hostPlatform lbi) -- Check that the test executable exists. exists <- doesFileExist cmd - unless exists $ die' verbosity $ "Error: Could not find test program \"" ++ cmd + unless exists $ die' verbosity $ "Could not find test program \"" ++ cmd ++ "\". Did you build the package first?" -- Remove old .tix files if appropriate. @@ -118,7 +118,7 @@ let suiteLog = buildLog exit -- Write summary notice to log file indicating start of test suite - appendFile (logFile suiteLog) $ summarizeSuiteStart $ testName' + appendFile (logFile suiteLog) $ summarizeSuiteStart testName' -- Append contents of temporary log file to the final human- -- readable log file @@ -144,7 +144,7 @@ when isCoverageEnabled $ case PD.library pkg_descr of Nothing -> - die' verbosity $ "Error: test coverage is only supported for packages with a library component" + die' verbosity "Test coverage is only supported for packages with a library component." Just library -> markupTest verbosity lbi distPref (prettyShow $ PD.package pkg_descr) suite library diff --git a/src/Distribution/Simple/Test/LibV09.hs b/src/Distribution/Simple/Test/LibV09.hs --- a/src/Distribution/Simple/Test/LibV09.hs +++ b/src/Distribution/Simple/Test/LibV09.hs @@ -13,7 +13,6 @@ import Distribution.Compat.Prelude import Distribution.Types.UnqualComponentName -import Distribution.Compat.CreatePipe import Distribution.Compat.Environment import Distribution.Compat.Internal.TempFile import Distribution.ModuleName @@ -42,7 +41,7 @@ , setCurrentDirectory ) import System.FilePath ( (), (<.>) ) import System.IO ( hClose, hPutStr ) -import System.Process (StdStream(..), waitForProcess) +import System.Process (StdStream(..), createPipe, waitForProcess) runTest :: PD.PackageDescription -> LBI.LocalBuildInfo @@ -62,7 +61,7 @@ -- Check that the test executable exists. exists <- doesFileExist cmd unless exists $ - die' verbosity $ "Error: Could not find test program \"" ++ cmd + die' verbosity $ "Could not find test program \"" ++ cmd ++ "\". Did you build the package first?" -- Remove old .tix files if appropriate. @@ -158,12 +157,11 @@ notice verbosity $ summarizeSuiteFinish suiteLog when isCoverageEnabled $ - case PD.library pkg_descr of - Nothing -> - die' verbosity $ "Error: test coverage is only supported for packages with a library component" - - Just library -> - markupTest verbosity lbi distPref (prettyShow $ PD.package pkg_descr) suite library + case PD.library pkg_descr of + Nothing -> + die' verbosity "Test coverage is only supported for packages with a library component." + Just library -> + markupTest verbosity lbi distPref (prettyShow $ PD.package pkg_descr) suite library return suiteLog where diff --git a/src/Distribution/Simple/UHC.hs b/src/Distribution/Simple/UHC.hs --- a/src/Distribution/Simple/UHC.hs +++ b/src/Distribution/Simple/UHC.hs @@ -121,7 +121,7 @@ let pkgdir = trimEnd output return pkgdir where - trimEnd = reverse . dropWhile isSpace . reverse + trimEnd = dropWhileEnd isSpace getUserPackageDir :: IO FilePath getUserPackageDir = do diff --git a/src/Distribution/Simple/Utils.hs b/src/Distribution/Simple/Utils.hs --- a/src/Distribution/Simple/Utils.hs +++ b/src/Distribution/Simple/Utils.hs @@ -5,6 +5,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} ----------------------------------------------------------------------------- -- | @@ -42,6 +43,7 @@ -- * exceptions handleDoesNotExist, + ignoreSigPipe, -- * running programs rawSystemExit, @@ -59,7 +61,7 @@ -- ** 'IOData' re-export -- -- These types are re-exported from - -- "Distribution.Utils.IOData" for convience as they're + -- "Distribution.Utils.IOData" for convenience as they're -- exposed in the API of 'rawSystemStdInOut' IOData(..), KnownIODataMode (..), @@ -170,11 +172,6 @@ -- * FilePath stuff isAbsoluteOnAnyPlatform, isRelativeOnAnyPlatform, - - -- * Deprecated functions - findFile, - findModuleFile, - findModuleFiles, ) where import Prelude () @@ -188,21 +185,16 @@ import Distribution.Version import Distribution.Compat.Async import Distribution.Compat.CopyFile -import Distribution.Compat.Internal.TempFile import Distribution.Compat.FilePath as FilePath +import Distribution.Compat.Internal.TempFile +import Distribution.Compat.Lens (Lens', over) import Distribution.Compat.Stack import Distribution.Verbosity import Distribution.Types.PackageId -#if __GLASGOW_HASKELL__ < 711 -#ifdef VERSION_base -#define BOOTSTRAPPED_CABAL 1 -#endif -#else #ifdef CURRENT_PACKAGE_KEY #define BOOTSTRAPPED_CABAL 1 #endif -#endif #ifdef BOOTSTRAPPED_CABAL import qualified Paths_Cabal (version) @@ -328,13 +320,8 @@ verbatimUserError = ioeSetVerbatim . userError dieWithLocation' :: Verbosity -> FilePath -> Maybe Int -> String -> IO a -dieWithLocation' verbosity filename mb_lineno msg = withFrozenCallStack $ do - ts <- getPOSIXTime - pname <- getProgName - ioError . verbatimUserError - . withMetadata ts AlwaysMark VerboseTrace verbosity - . wrapTextVerbosity verbosity - $ pname ++ ": " ++ +dieWithLocation' verbosity filename mb_lineno msg = + die' verbosity $ filename ++ (case mb_lineno of Just lineno -> ":" ++ show lineno Nothing -> "") ++ @@ -342,21 +329,46 @@ die' :: Verbosity -> String -> IO a die' verbosity msg = withFrozenCallStack $ do - ts <- getPOSIXTime - pname <- getProgName ioError . verbatimUserError - . withMetadata ts AlwaysMark VerboseTrace verbosity - . wrapTextVerbosity verbosity - $ pname ++ ": " ++ msg + =<< annotateErrorString verbosity + =<< pure . wrapTextVerbosity verbosity + =<< pure . addErrorPrefix + =<< prefixWithProgName msg dieNoWrap :: Verbosity -> String -> IO a dieNoWrap verbosity msg = withFrozenCallStack $ do -- TODO: should this have program name or not? - ts <- getPOSIXTime ioError . verbatimUserError - . withMetadata ts AlwaysMark VerboseTrace verbosity - $ msg + =<< annotateErrorString verbosity + (addErrorPrefix msg) +-- | Prefixing a message to indicate that it is a fatal error, +-- if the 'errorPrefix' is not already present. +addErrorPrefix :: String -> String +addErrorPrefix msg + | errorPrefix `isPrefixOf` msg = msg + -- Backpack prefixes its errors already with "Error:", see + -- 'Distribution.Utils.LogProgress.dieProgress'. + -- Taking it away there destroys the layout, so we rather + -- check here whether the prefix is already present. + | otherwise = unwords [errorPrefix, msg] + +-- | A prefix indicating that a message is a fatal error. +errorPrefix :: String +errorPrefix = "Error:" + +-- | Prefix an error string with program name from 'getProgName' +prefixWithProgName :: String -> IO String +prefixWithProgName msg = do + pname <- getProgName + return $ pname ++ ": " ++ msg + +-- | Annotate an error string with timestamp and 'withMetadata'. +annotateErrorString :: Verbosity -> String -> IO String +annotateErrorString verbosity msg = do + ts <- getPOSIXTime + return $ withMetadata ts AlwaysMark VerboseTrace verbosity msg + -- | Given a block of IO code that may raise an exception, annotate -- it with the metadata from the current scope. Use this as close -- to external code that raises IO exceptions as possible, since @@ -365,13 +377,18 @@ annotateIO :: Verbosity -> IO a -> IO a annotateIO verbosity act = do ts <- getPOSIXTime - modifyIOError (f ts) act - where - f ts ioe = ioeSetErrorString ioe - . withMetadata ts NeverMark VerboseTrace verbosity - $ ioeGetErrorString ioe + flip modifyIOError act $ + ioeModifyErrorString $ withMetadata ts NeverMark VerboseTrace verbosity +-- | A semantic editor for the error message inside an 'IOError'. +ioeModifyErrorString :: (String -> String) -> IOError -> IOError +ioeModifyErrorString = over ioeErrorString +-- | A lens for the error message inside an 'IOError'. +ioeErrorString :: Lens' IOError String +ioeErrorString f ioe = ioeSetErrorString ioe <$> f (ioeGetErrorString ioe) + + {-# NOINLINE topHandlerWith #-} topHandlerWith :: forall a. (Exception.SomeException -> IO a) -> IO a -> IO a topHandlerWith cont prog = do @@ -415,22 +432,18 @@ l@(n:_) | isDigit n -> ':' : l _ -> "" detail = ioeGetErrorString ioe - in wrapText (pname ++ ": " ++ file ++ detail) + in wrapText $ addErrorPrefix $ pname ++ ": " ++ file ++ detail _ -> displaySomeException se ++ "\n" -- | BC wrapper around 'Exception.displayException'. displaySomeException :: Exception.Exception e => e -> String -displaySomeException se = -#if __GLASGOW_HASKELL__ < 710 - show se -#else - Exception.displayException se -#endif +displaySomeException se = Exception.displayException se topHandler :: IO a -> IO a topHandler prog = topHandlerWith (const $ exitWith (ExitFailure 1)) prog +-- | Depending on 'isVerboseStderr', set the output handle to 'stderr' or 'stdout'. verbosityHandle :: Verbosity -> Handle verbosityHandle verbosity | isVerboseStderr verbosity = stderr @@ -442,7 +455,7 @@ -- warn :: Verbosity -> String -> IO () warn verbosity msg = withFrozenCallStack $ do - when (verbosity >= normal) $ do + when ((verbosity >= normal) && not (isVerboseNoWarn verbosity)) $ do ts <- getPOSIXTime hFlush stdout hPutStr stderr . withMetadata ts NormalMark FlagTrace verbosity @@ -750,13 +763,7 @@ hFlush stdout (_,_,_,ph) <- createProcess $ (Process.proc path args) { Process.env = (Just env) -#ifdef MIN_VERSION_process -#if MIN_VERSION_process(1,2,0) --- delegate_ctlc has been added in process 1.2, and we still want to be able to --- bootstrap GHC on systems not having that version , Process.delegate_ctlc = True -#endif -#endif } exitcode <- waitForProcess ph unless (exitcode == ExitSuccess) $ do @@ -829,13 +836,7 @@ , Process.std_in = inp , Process.std_out = out , Process.std_err = err -#ifdef MIN_VERSION_process -#if MIN_VERSION_process(1,2,0) --- delegate_ctlc has been added in process 1.2, and we still want to be able to --- bootstrap GHC on systems not having that version , Process.delegate_ctlc = True -#endif -#endif } return (inp', out', err', ph) @@ -917,11 +918,13 @@ Just ioe -> throwIO (ioeSetFileName ioe ("output of " ++ path)) Nothing -> throwIO exc - ignoreSigPipe :: IO () -> IO () - ignoreSigPipe = Exception.handle $ \e -> case e of - GHC.IOError { GHC.ioe_type = GHC.ResourceVanished, GHC.ioe_errno = Just ioe } - | Errno ioe == ePIPE -> return () - _ -> throwIO e +-- | Ignore SIGPIPE in a subcomputation. +-- +ignoreSigPipe :: IO () -> IO () +ignoreSigPipe = Exception.handle $ \case + GHC.IOError { GHC.ioe_type = GHC.ResourceVanished, GHC.ioe_errno = Just ioe } + | Errno ioe == ePIPE -> return () + e -> throwIO e -- | Look for a program and try to find it's version number. It can accept -- either an absolute path or the name of a program binary, in which case we @@ -979,12 +982,6 @@ -- Finding files -{-# DEPRECATED findFile "Use findFileEx instead. This symbol will be removed in Cabal 3.2 (est. December 2019)" #-} -findFile :: [FilePath] -- ^search locations - -> FilePath -- ^File Name - -> IO FilePath -findFile = findFileEx normal - -- | Find a file by looking in a search path. The file path must match exactly. -- -- @since 3.4.0.0 @@ -1087,13 +1084,6 @@ findAllFiles file = filterM (doesFileExist . file) -{-# DEPRECATED findModuleFiles "Use findModuleFilesEx instead. This symbol will be removed in Cabal 3.2 (est. December 2019)" #-} -findModuleFiles :: [FilePath] -- ^ build prefix (location of objects) - -> [String] -- ^ search suffixes - -> [ModuleName] -- ^ modules - -> IO [(FilePath, FilePath)] -findModuleFiles = findModuleFilesEx normal - -- | Finds the files corresponding to a list of Haskell module names. -- -- As 'findModuleFile' but for a list of module names. @@ -1106,13 +1096,6 @@ findModuleFilesEx verbosity searchPath extensions moduleNames = traverse (findModuleFileEx verbosity searchPath extensions) moduleNames -{-# DEPRECATED findModuleFile "Use findModuleFileEx instead. This symbol will be removed in Cabal 3.2 (est. December 2019)" #-} -findModuleFile :: [FilePath] -- ^ build prefix (location of objects) - -> [String] -- ^ search suffixes - -> ModuleName -- ^ module - -> IO (FilePath, FilePath) -findModuleFile = findModuleFileEx normal - -- | Find the file corresponding to a Haskell module name. -- -- This is similar to 'findFileWithExtension'' but specialised to a module @@ -1129,7 +1112,7 @@ (ModuleName.toFilePath mod_name) where notFound = die' verbosity $ - "Error: Could not find module: " ++ prettyShow mod_name + "Could not find module: " ++ prettyShow mod_name ++ " with any suffix: " ++ show extensions ++ " in the search path: " ++ show searchPath diff --git a/src/Distribution/Simple/Utils/Json.hs b/src/Distribution/Simple/Utils/Json.hs deleted file mode 100644 --- a/src/Distribution/Simple/Utils/Json.hs +++ /dev/null @@ -1,46 +0,0 @@ --- | Utility json lib for Cabal --- TODO: Remove it again. -module Distribution.Simple.Utils.Json - ( Json(..) - , renderJson - ) where - -data Json = JsonArray [Json] - | JsonBool !Bool - | JsonNull - | JsonNumber !Int - | JsonObject [(String, Json)] - | JsonString !String - -renderJson :: Json -> ShowS -renderJson (JsonArray objs) = - surround "[" "]" $ intercalate "," $ map renderJson objs -renderJson (JsonBool True) = showString "true" -renderJson (JsonBool False) = showString "false" -renderJson JsonNull = showString "null" -renderJson (JsonNumber n) = shows n -renderJson (JsonObject attrs) = - surround "{" "}" $ intercalate "," $ map render attrs - where - render (k,v) = (surround "\"" "\"" $ showString' k) . showString ":" . renderJson v -renderJson (JsonString s) = surround "\"" "\"" $ showString' s - -surround :: String -> String -> ShowS -> ShowS -surround begin end middle = showString begin . middle . showString end - -showString' :: String -> ShowS -showString' xs = showStringWorker xs - where - showStringWorker :: String -> ShowS - showStringWorker ('\"':as) = showString "\\\"" . showStringWorker as - showStringWorker ('\\':as) = showString "\\\\" . showStringWorker as - showStringWorker ('\'':as) = showString "\\\'" . showStringWorker as - showStringWorker (x:as) = showString [x] . showStringWorker as - showStringWorker [] = showString "" - -intercalate :: String -> [ShowS] -> ShowS -intercalate sep = go - where - go [] = id - go [x] = x - go (x:xs) = x . showString' sep . go xs diff --git a/src/Distribution/System.hs b/src/Distribution/System.hs deleted file mode 100644 --- a/src/Distribution/System.hs +++ /dev/null @@ -1,275 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} - ------------------------------------------------------------------------------ --- | --- Module : Distribution.System --- Copyright : Duncan Coutts 2007-2008 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- Cabal often needs to do slightly different things on specific platforms. You --- probably know about the 'System.Info.os' however using that is very --- inconvenient because it is a string and different Haskell implementations --- do not agree on using the same strings for the same platforms! (In --- particular see the controversy over \"windows\" vs \"mingw32\"). So to make it --- more consistent and easy to use we have an 'OS' enumeration. --- -module Distribution.System ( - -- * Operating System - OS(..), - buildOS, - - -- * Machine Architecture - Arch(..), - buildArch, - - -- * Platform is a pair of arch and OS - Platform(..), - buildPlatform, - platformFromTriple, - - -- * Internal - knownOSs, - knownArches, - - -- * Classification - ClassificationStrictness (..), - classifyOS, - classifyArch, - ) where - -import Prelude () -import Distribution.Compat.Prelude -import Control.Applicative (liftA2) - -import qualified System.Info (os, arch) -import Distribution.Utils.Generic (lowercase) - -import Distribution.Parsec -import Distribution.Pretty - -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp - --- | How strict to be when classifying strings into the 'OS' and 'Arch' enums. --- --- The reason we have multiple ways to do the classification is because there --- are two situations where we need to do it. --- --- For parsing OS and arch names in .cabal files we really want everyone to be --- referring to the same or arch by the same name. Variety is not a virtue --- in this case. We don't mind about case though. --- --- For the System.Info.os\/arch different Haskell implementations use different --- names for the same or\/arch. Also they tend to distinguish versions of an --- OS\/arch which we just don't care about. --- --- The 'Compat' classification allows us to recognise aliases that are already --- in common use but it allows us to distinguish them from the canonical name --- which enables us to warn about such deprecated aliases. --- -data ClassificationStrictness = Permissive | Compat | Strict - --- ------------------------------------------------------------ --- * Operating System --- ------------------------------------------------------------ - --- | These are the known OS names: Linux, Windows, OSX --- ,FreeBSD, OpenBSD, NetBSD, DragonFly --- ,Solaris, AIX, HPUX, IRIX --- ,HaLVM ,Hurd ,IOS, Android,Ghcjs --- --- The following aliases can also be used:, --- * Windows aliases: mingw32, win32, cygwin32 --- * OSX alias: darwin --- * Hurd alias: gnu --- * FreeBSD alias: kfreebsdgnu --- * Solaris alias: solaris2 --- -data OS = Linux | Windows | OSX -- tier 1 desktop OSs - | FreeBSD | OpenBSD | NetBSD -- other free Unix OSs - | DragonFly - | Solaris | AIX | HPUX | IRIX -- ageing Unix OSs - | HaLVM -- bare metal / VMs / hypervisors - | Hurd -- GNU's microkernel - | IOS | Android -- mobile OSs - | Ghcjs - | OtherOS String - deriving (Eq, Generic, Ord, Show, Read, Typeable, Data) - -instance Binary OS -instance Structured OS -instance NFData OS where rnf = genericRnf - -knownOSs :: [OS] -knownOSs = [Linux, Windows, OSX - ,FreeBSD, OpenBSD, NetBSD, DragonFly - ,Solaris, AIX, HPUX, IRIX - ,HaLVM - ,Hurd - ,IOS, Android - ,Ghcjs] - -osAliases :: ClassificationStrictness -> OS -> [String] -osAliases Permissive Windows = ["mingw32", "win32", "cygwin32"] -osAliases Compat Windows = ["mingw32", "win32"] -osAliases _ OSX = ["darwin"] -osAliases _ Hurd = ["gnu"] -osAliases Permissive FreeBSD = ["kfreebsdgnu"] -osAliases Compat FreeBSD = ["kfreebsdgnu"] -osAliases Permissive Solaris = ["solaris2"] -osAliases Compat Solaris = ["solaris2"] -osAliases Permissive Android = ["linux-android", "linux-androideabi", "linux-androideabihf"] -osAliases Compat Android = ["linux-android"] -osAliases _ _ = [] - -instance Pretty OS where - pretty (OtherOS name) = Disp.text name - pretty other = Disp.text (lowercase (show other)) - -instance Parsec OS where - parsec = classifyOS Compat <$> parsecIdent - - - -classifyOS :: ClassificationStrictness -> String -> OS -classifyOS strictness s = - fromMaybe (OtherOS s) $ lookup (lowercase s) osMap - where - osMap = [ (name, os) - | os <- knownOSs - , name <- prettyShow os : osAliases strictness os ] - -buildOS :: OS -buildOS = classifyOS Permissive System.Info.os - --- ------------------------------------------------------------ --- * Machine Architecture --- ------------------------------------------------------------ - --- | These are the known Arches: I386, X86_64, PPC, PPC64, Sparc, --- Arm, AArch64, Mips, SH, IA64, S39, Alpha, Hppa, Rs6000, M68k, --- Vax, and JavaScript. --- --- The following aliases can also be used: --- * PPC alias: powerpc --- * PPC64 alias : powerpc64, powerpc64le --- * Sparc aliases: sparc64, sun4 --- * Mips aliases: mipsel, mipseb --- * Arm aliases: armeb, armel --- * AArch64 aliases: arm64 --- -data Arch = I386 | X86_64 | PPC | PPC64 | Sparc - | Arm | AArch64 | Mips | SH - | IA64 | S390 - | Alpha | Hppa | Rs6000 - | M68k | Vax - | JavaScript - | OtherArch String - deriving (Eq, Generic, Ord, Show, Read, Typeable, Data) - -instance Binary Arch -instance Structured Arch -instance NFData Arch where rnf = genericRnf - -knownArches :: [Arch] -knownArches = [I386, X86_64, PPC, PPC64, Sparc - ,Arm, AArch64, Mips, SH - ,IA64, S390 - ,Alpha, Hppa, Rs6000 - ,M68k, Vax - ,JavaScript] - -archAliases :: ClassificationStrictness -> Arch -> [String] -archAliases Strict _ = [] -archAliases Compat _ = [] -archAliases _ PPC = ["powerpc"] -archAliases _ PPC64 = ["powerpc64", "powerpc64le"] -archAliases _ Sparc = ["sparc64", "sun4"] -archAliases _ Mips = ["mipsel", "mipseb"] -archAliases _ Arm = ["armeb", "armel"] -archAliases _ AArch64 = ["arm64"] -archAliases _ _ = [] - -instance Pretty Arch where - pretty (OtherArch name) = Disp.text name - pretty other = Disp.text (lowercase (show other)) - -instance Parsec Arch where - parsec = classifyArch Strict <$> parsecIdent - -classifyArch :: ClassificationStrictness -> String -> Arch -classifyArch strictness s = - fromMaybe (OtherArch s) $ lookup (lowercase s) archMap - where - archMap = [ (name, arch) - | arch <- knownArches - , name <- prettyShow arch : archAliases strictness arch ] - -buildArch :: Arch -buildArch = classifyArch Permissive System.Info.arch - --- ------------------------------------------------------------ --- * Platform --- ------------------------------------------------------------ - -data Platform = Platform Arch OS - deriving (Eq, Generic, Ord, Show, Read, Typeable, Data) - -instance Binary Platform -instance Structured Platform -instance NFData Platform where rnf = genericRnf - -instance Pretty Platform where - pretty (Platform arch os) = pretty arch <<>> Disp.char '-' <<>> pretty os - -instance Parsec Platform where - -- TODO: there are ambigious platforms like: `arch-word-os` - -- which could be parsed as - -- * Platform "arch-word" "os" - -- * Platform "arch" "word-os" - -- We could support that preferring variants 'OtherOS' or 'OtherArch' - -- - -- For now we split into arch and os parts on the first dash. - parsec = do - arch <- parsecDashlessArch - _ <- P.char '-' - os <- parsec - return (Platform arch os) - where - parsecDashlessArch = classifyArch Strict <$> dashlessIdent - - dashlessIdent = liftA2 (:) firstChar rest - where - firstChar = P.satisfy isAlpha - rest = P.munch (\c -> isAlphaNum c || c == '_') - --- | The platform Cabal was compiled on. In most cases, --- @LocalBuildInfo.hostPlatform@ should be used instead (the platform we're --- targeting). -buildPlatform :: Platform -buildPlatform = Platform buildArch buildOS - --- Utils: - -parsecIdent :: CabalParsing m => m String -parsecIdent = (:) <$> firstChar <*> rest - where - firstChar = P.satisfy isAlpha - rest = P.munch (\c -> isAlphaNum c || c == '_' || c == '-') - -platformFromTriple :: String -> Maybe Platform -platformFromTriple triple = - either (const Nothing) Just $ explicitEitherParsec parseTriple triple - where parseWord = P.munch1 (\c -> isAlphaNum c || c == '_') - parseTriple = do - arch <- fmap (classifyArch Permissive) parseWord - _ <- P.char '-' - _ <- parseWord -- Skip vendor - _ <- P.char '-' - os <- fmap (classifyOS Permissive) parsecIdent -- OS may have hyphens, like - -- 'nto-qnx' - return $ Platform arch os diff --git a/src/Distribution/Text.hs b/src/Distribution/Text.hs deleted file mode 100644 --- a/src/Distribution/Text.hs +++ /dev/null @@ -1,12 +0,0 @@ --- Since @3.0@ this is a compat module. -module Distribution.Text (display, simpleParse) where -{- {-# DEPRECATED "Use Distribution.Parsec or Distribution.Pretty" #-} -} - -import Distribution.Pretty -import Distribution.Parsec - -display :: Pretty a => a -> String -display = prettyShow - -simpleParse :: Parsec a => String -> Maybe a -simpleParse = simpleParsec diff --git a/src/Distribution/Types/AbiDependency.hs b/src/Distribution/Types/AbiDependency.hs deleted file mode 100644 --- a/src/Distribution/Types/AbiDependency.hs +++ /dev/null @@ -1,44 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Types.AbiDependency where - -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Parsec -import Distribution.Pretty - -import qualified Distribution.Compat.CharParsing as P -import qualified Distribution.Package as Package -import qualified Text.PrettyPrint as Disp - --- | An ABI dependency is a dependency on a library which also --- records the ABI hash ('abiHash') of the library it depends --- on. --- --- The primary utility of this is to enable an extra sanity when --- GHC loads libraries: it can check if the dependency has a matching --- ABI and if not, refuse to load this library. This information --- is critical if we are shadowing libraries; differences in the --- ABI hash let us know what packages get shadowed by the new version --- of a package. -data AbiDependency = AbiDependency { - depUnitId :: Package.UnitId, - depAbiHash :: Package.AbiHash - } - deriving (Eq, Generic, Read, Show, Typeable) - -instance Pretty AbiDependency where - pretty (AbiDependency uid abi) = - pretty uid <<>> Disp.char '=' <<>> pretty abi - -instance Parsec AbiDependency where - parsec = do - uid <- parsec - _ <- P.char '=' - abi <- parsec - return (AbiDependency uid abi) - -instance Binary AbiDependency -instance Structured AbiDependency -instance NFData AbiDependency where rnf = genericRnf diff --git a/src/Distribution/Types/AbiHash.hs b/src/Distribution/Types/AbiHash.hs deleted file mode 100644 --- a/src/Distribution/Types/AbiHash.hs +++ /dev/null @@ -1,61 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -module Distribution.Types.AbiHash - ( AbiHash, unAbiHash, mkAbiHash - ) where - -import Prelude () -import Distribution.Compat.Prelude -import Distribution.Utils.ShortText - -import qualified Distribution.Compat.CharParsing as P -import Distribution.Pretty -import Distribution.Parsec - -import Text.PrettyPrint (text) - --- | ABI Hashes --- --- Use 'mkAbiHash' and 'unAbiHash' to convert from/to a --- 'String'. --- --- This type is opaque since @Cabal-2.0@ --- --- @since 2.0.0.2 -newtype AbiHash = AbiHash ShortText - deriving (Eq, Show, Read, Generic, Typeable) - --- | Construct a 'AbiHash' from a 'String' --- --- 'mkAbiHash' is the inverse to 'unAbiHash' --- --- Note: No validations are performed to ensure that the resulting --- 'AbiHash' is valid --- --- @since 2.0.0.2 -unAbiHash :: AbiHash -> String -unAbiHash (AbiHash h) = fromShortText h - --- | Convert 'AbiHash' to 'String' --- --- @since 2.0.0.2 -mkAbiHash :: String -> AbiHash -mkAbiHash = AbiHash . toShortText - --- | 'mkAbiHash' --- --- @since 2.0.0.2 -instance IsString AbiHash where - fromString = mkAbiHash - -instance Binary AbiHash -instance Structured AbiHash -instance NFData AbiHash where rnf = genericRnf - -instance Pretty AbiHash where - pretty = text . unAbiHash - -instance Parsec AbiHash where - parsec = fmap mkAbiHash (P.munch isAlphaNum) diff --git a/src/Distribution/Types/Benchmark.hs b/src/Distribution/Types/Benchmark.hs deleted file mode 100644 --- a/src/Distribution/Types/Benchmark.hs +++ /dev/null @@ -1,77 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} - -module Distribution.Types.Benchmark ( - Benchmark(..), - emptyBenchmark, - benchmarkType, - benchmarkModules, - benchmarkModulesAutogen -) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Types.BuildInfo -import Distribution.Types.BenchmarkType -import Distribution.Types.BenchmarkInterface -import Distribution.Types.UnqualComponentName - -import Distribution.ModuleName - -import qualified Distribution.Types.BuildInfo.Lens as L - --- | A \"benchmark\" stanza in a cabal file. --- -data Benchmark = Benchmark { - benchmarkName :: UnqualComponentName, - benchmarkInterface :: BenchmarkInterface, - benchmarkBuildInfo :: BuildInfo - } - deriving (Generic, Show, Read, Eq, Typeable, Data) - -instance Binary Benchmark -instance Structured Benchmark -instance NFData Benchmark where rnf = genericRnf - -instance L.HasBuildInfo Benchmark where - buildInfo f (Benchmark x1 x2 x3) = fmap (\y1 -> Benchmark x1 x2 y1) (f x3) - -instance Monoid Benchmark where - mempty = Benchmark { - benchmarkName = mempty, - benchmarkInterface = mempty, - benchmarkBuildInfo = mempty - } - mappend = (<>) - -instance Semigroup Benchmark where - a <> b = Benchmark { - benchmarkName = combine' benchmarkName, - benchmarkInterface = combine benchmarkInterface, - benchmarkBuildInfo = combine benchmarkBuildInfo - } - where combine field = field a `mappend` field b - combine' field = case ( unUnqualComponentName $ field a - , unUnqualComponentName $ field b) of - ("", _) -> field b - (_, "") -> field a - (x, y) -> error $ "Ambiguous values for test field: '" - ++ x ++ "' and '" ++ y ++ "'" - -emptyBenchmark :: Benchmark -emptyBenchmark = mempty - -benchmarkType :: Benchmark -> BenchmarkType -benchmarkType benchmark = case benchmarkInterface benchmark of - BenchmarkExeV10 ver _ -> BenchmarkTypeExe ver - BenchmarkUnsupported benchmarktype -> benchmarktype - --- | Get all the module names from a benchmark. -benchmarkModules :: Benchmark -> [ModuleName] -benchmarkModules benchmark = otherModules (benchmarkBuildInfo benchmark) - --- | Get all the auto generated module names from a benchmark. --- This are a subset of 'benchmarkModules'. -benchmarkModulesAutogen :: Benchmark -> [ModuleName] -benchmarkModulesAutogen benchmark = autogenModules (benchmarkBuildInfo benchmark) diff --git a/src/Distribution/Types/Benchmark/Lens.hs b/src/Distribution/Types/Benchmark/Lens.hs deleted file mode 100644 --- a/src/Distribution/Types/Benchmark/Lens.hs +++ /dev/null @@ -1,27 +0,0 @@ -module Distribution.Types.Benchmark.Lens ( - Benchmark, - module Distribution.Types.Benchmark.Lens, - ) where - -import Distribution.Compat.Lens -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Types.Benchmark (Benchmark) -import Distribution.Types.BenchmarkInterface (BenchmarkInterface) -import Distribution.Types.BuildInfo (BuildInfo) -import Distribution.Types.UnqualComponentName (UnqualComponentName) - -import qualified Distribution.Types.Benchmark as T - -benchmarkName :: Lens' Benchmark UnqualComponentName -benchmarkName f s = fmap (\x -> s { T.benchmarkName = x }) (f (T.benchmarkName s)) -{-# INLINE benchmarkName #-} - -benchmarkInterface :: Lens' Benchmark BenchmarkInterface -benchmarkInterface f s = fmap (\x -> s { T.benchmarkInterface = x }) (f (T.benchmarkInterface s)) -{-# INLINE benchmarkInterface #-} - -benchmarkBuildInfo :: Lens' Benchmark BuildInfo -benchmarkBuildInfo f s = fmap (\x -> s { T.benchmarkBuildInfo = x }) (f (T.benchmarkBuildInfo s)) -{-# INLINE benchmarkBuildInfo #-} diff --git a/src/Distribution/Types/BenchmarkInterface.hs b/src/Distribution/Types/BenchmarkInterface.hs deleted file mode 100644 --- a/src/Distribution/Types/BenchmarkInterface.hs +++ /dev/null @@ -1,46 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} - -module Distribution.Types.BenchmarkInterface ( - BenchmarkInterface(..), -) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Types.BenchmarkType -import Distribution.Version - --- | The benchmark interfaces that are currently defined. Each --- benchmark must specify which interface it supports. --- --- More interfaces may be defined in future, either new revisions or --- totally new interfaces. --- -data BenchmarkInterface = - - -- | Benchmark interface \"exitcode-stdio-1.0\". The benchmark - -- takes the form of an executable. It returns a zero exit code - -- for success, non-zero for failure. The stdout and stderr - -- channels may be logged. It takes no command line parameters - -- and nothing on stdin. - -- - BenchmarkExeV10 Version FilePath - - -- | A benchmark that does not conform to one of the above - -- interfaces for the given reason (e.g. unknown benchmark type). - -- - | BenchmarkUnsupported BenchmarkType - deriving (Eq, Generic, Read, Show, Typeable, Data) - -instance Binary BenchmarkInterface -instance Structured BenchmarkInterface -instance NFData BenchmarkInterface where rnf = genericRnf - -instance Monoid BenchmarkInterface where - mempty = BenchmarkUnsupported (BenchmarkTypeUnknown mempty nullVersion) - mappend = (<>) - -instance Semigroup BenchmarkInterface where - a <> (BenchmarkUnsupported _) = a - _ <> b = b diff --git a/src/Distribution/Types/BenchmarkType.hs b/src/Distribution/Types/BenchmarkType.hs deleted file mode 100644 --- a/src/Distribution/Types/BenchmarkType.hs +++ /dev/null @@ -1,40 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} - -module Distribution.Types.BenchmarkType ( - BenchmarkType(..), - knownBenchmarkTypes, -) where - -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Parsec -import Distribution.Pretty -import Distribution.Version -import Text.PrettyPrint (char, text) - --- | The \"benchmark-type\" field in the benchmark stanza. --- -data BenchmarkType = BenchmarkTypeExe Version - -- ^ \"type: exitcode-stdio-x.y\" - | BenchmarkTypeUnknown String Version - -- ^ Some unknown benchmark type e.g. \"type: foo\" - deriving (Generic, Show, Read, Eq, Typeable, Data) - -instance Binary BenchmarkType -instance Structured BenchmarkType -instance NFData BenchmarkType where rnf = genericRnf - -knownBenchmarkTypes :: [BenchmarkType] -knownBenchmarkTypes = [ BenchmarkTypeExe (mkVersion [1,0]) ] - -instance Pretty BenchmarkType where - pretty (BenchmarkTypeExe ver) = text "exitcode-stdio-" <<>> pretty ver - pretty (BenchmarkTypeUnknown name ver) = text name <<>> char '-' <<>> pretty ver - -instance Parsec BenchmarkType where - parsec = parsecStandard $ \ver name -> case name of - "exitcode-stdio" -> BenchmarkTypeExe ver - _ -> BenchmarkTypeUnknown name ver diff --git a/src/Distribution/Types/BuildInfo.hs b/src/Distribution/Types/BuildInfo.hs deleted file mode 100644 --- a/src/Distribution/Types/BuildInfo.hs +++ /dev/null @@ -1,266 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} - -module Distribution.Types.BuildInfo ( - BuildInfo(..), - - emptyBuildInfo, - allLanguages, - allExtensions, - usedExtensions, - usesTemplateHaskellOrQQ, - - hcOptions, - hcProfOptions, - hcSharedOptions, - hcStaticOptions, -) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Types.Mixin -import Distribution.Types.Dependency -import Distribution.Types.ExeDependency -import Distribution.Types.LegacyExeDependency -import Distribution.Types.PkgconfigDependency -import Distribution.Utils.Path - -import Distribution.ModuleName -import Distribution.Compiler -import Language.Haskell.Extension - --- Consider refactoring into executable and library versions. -data BuildInfo = BuildInfo { - -- | component is buildable here - buildable :: Bool, - -- | Tools needed to build this bit. - -- - -- This is a legacy field that 'buildToolDepends' largely supersedes. - -- - -- Unless use are very sure what you are doing, use the functions in - -- "Distribution.Simple.BuildToolDepends" rather than accessing this - -- field directly. - buildTools :: [LegacyExeDependency], - -- | Haskell tools needed to build this bit - -- - -- This field is better than 'buildTools' because it allows one to - -- precisely specify an executable in a package. - -- - -- Unless use are very sure what you are doing, use the functions in - -- "Distribution.Simple.BuildToolDepends" rather than accessing this - -- field directly. - buildToolDepends :: [ExeDependency], - cppOptions :: [String], -- ^ options for pre-processing Haskell code - asmOptions :: [String], -- ^ options for assmebler - cmmOptions :: [String], -- ^ options for C-- compiler - ccOptions :: [String], -- ^ options for C compiler - cxxOptions :: [String], -- ^ options for C++ compiler - ldOptions :: [String], -- ^ options for linker - hsc2hsOptions :: [String], -- ^ options for hsc2hs - pkgconfigDepends :: [PkgconfigDependency], -- ^ pkg-config packages that are used - frameworks :: [String], -- ^support frameworks for Mac OS X - extraFrameworkDirs:: [String], -- ^ extra locations to find frameworks. - asmSources :: [FilePath], -- ^ Assembly files. - cmmSources :: [FilePath], -- ^ C-- files. - cSources :: [FilePath], - cxxSources :: [FilePath], - jsSources :: [FilePath], - hsSourceDirs :: [SymbolicPath PackageDir SourceDir], -- ^ where to look for the Haskell module hierarchy - otherModules :: [ModuleName], -- ^ non-exposed or non-main modules - virtualModules :: [ModuleName], -- ^ exposed modules that do not have a source file (e.g. @GHC.Prim@ from @ghc-prim@ package) - autogenModules :: [ModuleName], -- ^ not present on sdist, Paths_* or user-generated with a custom Setup.hs - - defaultLanguage :: Maybe Language,-- ^ language used when not explicitly specified - otherLanguages :: [Language], -- ^ other languages used within the package - defaultExtensions :: [Extension], -- ^ language extensions used by all modules - otherExtensions :: [Extension], -- ^ other language extensions used within the package - oldExtensions :: [Extension], -- ^ the old extensions field, treated same as 'defaultExtensions' - - extraLibs :: [String], -- ^ what libraries to link with when compiling a program that uses your package - extraGHCiLibs :: [String], -- ^ if present, overrides extraLibs when package is loaded with GHCi. - extraBundledLibs :: [String], -- ^ if present, adds libs to hs-libraries, which become part of the package. - -- Example: the Cffi library shipping with the rts, alognside the HSrts-1.0.a,.o,... - -- Example 2: a library that is being built by a foreing tool (e.g. rust) - -- and copied and registered together with this library. The - -- logic on how this library is built will have to be encoded in a - -- custom Setup for now. Otherwise cabal would need to lear how to - -- call arbitrary library builders. - extraLibFlavours :: [String], -- ^ Hidden Flag. This set of strings, will be appended to all libraries when - -- copying. E.g. [libHS_ | flavour <- extraLibFlavours]. This - -- should only be needed in very specific cases, e.g. the `rts` package, where - -- there are multiple copies of slightly differently built libs. - extraDynLibFlavours :: [String], -- ^ Hidden Flag. This set of strings will be appended to all /dynamic/ - -- libraries when copying. This is particularly useful with the `rts` package, - -- where we want different dynamic flavours of the RTS library to be installed. - extraLibDirs :: [String], - includeDirs :: [FilePath], -- ^directories to find .h files - includes :: [FilePath], -- ^ The .h files to be found in includeDirs - autogenIncludes :: [FilePath], -- ^ The .h files to be generated (e.g. by @autoconf@) - installIncludes :: [FilePath], -- ^ .h files to install with the package - options :: PerCompilerFlavor [String], - profOptions :: PerCompilerFlavor [String], - sharedOptions :: PerCompilerFlavor [String], - staticOptions :: PerCompilerFlavor [String], - customFieldsBI :: [(String,String)], -- ^Custom fields starting - -- with x-, stored in a - -- simple assoc-list. - targetBuildDepends :: [Dependency], -- ^ Dependencies specific to a library or executable target - mixins :: [Mixin] - } - deriving (Generic, Show, Read, Eq, Typeable, Data) - -instance Binary BuildInfo -instance Structured BuildInfo -instance NFData BuildInfo where rnf = genericRnf - -instance Monoid BuildInfo where - mempty = BuildInfo { - buildable = True, - buildTools = [], - buildToolDepends = [], - cppOptions = [], - asmOptions = [], - cmmOptions = [], - ccOptions = [], - cxxOptions = [], - ldOptions = [], - hsc2hsOptions = [], - pkgconfigDepends = [], - frameworks = [], - extraFrameworkDirs = [], - asmSources = [], - cmmSources = [], - cSources = [], - cxxSources = [], - jsSources = [], - hsSourceDirs = [], - otherModules = [], - virtualModules = [], - autogenModules = [], - defaultLanguage = Nothing, - otherLanguages = [], - defaultExtensions = [], - otherExtensions = [], - oldExtensions = [], - extraLibs = [], - extraGHCiLibs = [], - extraBundledLibs = [], - extraLibFlavours = [], - extraDynLibFlavours = [], - extraLibDirs = [], - includeDirs = [], - includes = [], - autogenIncludes = [], - installIncludes = [], - options = mempty, - profOptions = mempty, - sharedOptions = mempty, - staticOptions = mempty, - customFieldsBI = [], - targetBuildDepends = [], - mixins = [] - } - mappend = (<>) - -instance Semigroup BuildInfo where - a <> b = BuildInfo { - buildable = buildable a && buildable b, - buildTools = combine buildTools, - buildToolDepends = combine buildToolDepends, - cppOptions = combine cppOptions, - asmOptions = combine asmOptions, - cmmOptions = combine cmmOptions, - ccOptions = combine ccOptions, - cxxOptions = combine cxxOptions, - ldOptions = combine ldOptions, - hsc2hsOptions = combine hsc2hsOptions, - pkgconfigDepends = combine pkgconfigDepends, - frameworks = combineNub frameworks, - extraFrameworkDirs = combineNub extraFrameworkDirs, - asmSources = combineNub asmSources, - cmmSources = combineNub cmmSources, - cSources = combineNub cSources, - cxxSources = combineNub cxxSources, - jsSources = combineNub jsSources, - hsSourceDirs = combineNub hsSourceDirs, - otherModules = combineNub otherModules, - virtualModules = combineNub virtualModules, - autogenModules = combineNub autogenModules, - defaultLanguage = combineMby defaultLanguage, - otherLanguages = combineNub otherLanguages, - defaultExtensions = combineNub defaultExtensions, - otherExtensions = combineNub otherExtensions, - oldExtensions = combineNub oldExtensions, - extraLibs = combine extraLibs, - extraGHCiLibs = combine extraGHCiLibs, - extraBundledLibs = combine extraBundledLibs, - extraLibFlavours = combine extraLibFlavours, - extraDynLibFlavours = combine extraDynLibFlavours, - extraLibDirs = combineNub extraLibDirs, - includeDirs = combineNub includeDirs, - includes = combineNub includes, - autogenIncludes = combineNub autogenIncludes, - installIncludes = combineNub installIncludes, - options = combine options, - profOptions = combine profOptions, - sharedOptions = combine sharedOptions, - staticOptions = combine staticOptions, - customFieldsBI = combine customFieldsBI, - targetBuildDepends = combineNub targetBuildDepends, - mixins = combine mixins - } - where - combine field = field a `mappend` field b - combineNub field = nub (combine field) - combineMby field = field b `mplus` field a - -emptyBuildInfo :: BuildInfo -emptyBuildInfo = mempty - --- | The 'Language's used by this component --- -allLanguages :: BuildInfo -> [Language] -allLanguages bi = maybeToList (defaultLanguage bi) - ++ otherLanguages bi - --- | The 'Extension's that are used somewhere by this component --- -allExtensions :: BuildInfo -> [Extension] -allExtensions bi = usedExtensions bi - ++ otherExtensions bi - --- | The 'Extensions' that are used by all modules in this component --- -usedExtensions :: BuildInfo -> [Extension] -usedExtensions bi = oldExtensions bi - ++ defaultExtensions bi - --- | Whether any modules in this component use Template Haskell or --- Quasi Quotes -usesTemplateHaskellOrQQ :: BuildInfo -> Bool -usesTemplateHaskellOrQQ bi = any p (allExtensions bi) - where - p ex = ex `elem` - [EnableExtension TemplateHaskell, EnableExtension QuasiQuotes] - --- |Select options for a particular Haskell compiler. -hcOptions :: CompilerFlavor -> BuildInfo -> [String] -hcOptions = lookupHcOptions options - -hcProfOptions :: CompilerFlavor -> BuildInfo -> [String] -hcProfOptions = lookupHcOptions profOptions - -hcSharedOptions :: CompilerFlavor -> BuildInfo -> [String] -hcSharedOptions = lookupHcOptions sharedOptions - -hcStaticOptions :: CompilerFlavor -> BuildInfo -> [String] -hcStaticOptions = lookupHcOptions staticOptions - -lookupHcOptions :: (BuildInfo -> PerCompilerFlavor [String]) - -> CompilerFlavor -> BuildInfo -> [String] -lookupHcOptions f hc bi = case f bi of - PerCompilerFlavor ghc ghcjs - | hc == GHC -> ghc - | hc == GHCJS -> ghcjs - | otherwise -> mempty diff --git a/src/Distribution/Types/BuildInfo/Lens.hs b/src/Distribution/Types/BuildInfo/Lens.hs deleted file mode 100644 --- a/src/Distribution/Types/BuildInfo/Lens.hs +++ /dev/null @@ -1,342 +0,0 @@ -module Distribution.Types.BuildInfo.Lens ( - BuildInfo, - HasBuildInfo (..), - HasBuildInfos (..), - ) where - -import Distribution.Compat.Lens -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Compiler (PerCompilerFlavor) -import Distribution.ModuleName (ModuleName) -import Distribution.Types.BuildInfo (BuildInfo) -import Distribution.Types.Dependency (Dependency) -import Distribution.Types.ExeDependency (ExeDependency) -import Distribution.Types.LegacyExeDependency (LegacyExeDependency) -import Distribution.Types.Mixin (Mixin) -import Distribution.Types.PkgconfigDependency (PkgconfigDependency) -import Distribution.Utils.Path -import Language.Haskell.Extension (Extension, Language) - -import qualified Distribution.Types.BuildInfo as T - --- | Classy lenses for 'BuildInfo'. -class HasBuildInfo a where - buildInfo :: Lens' a BuildInfo - - buildable :: Lens' a Bool - buildable = buildInfo . buildable - {-# INLINE buildable #-} - - buildTools :: Lens' a [LegacyExeDependency] - buildTools = buildInfo . buildTools - {-# INLINE buildTools #-} - - buildToolDepends :: Lens' a [ExeDependency] - buildToolDepends = buildInfo . buildToolDepends - {-# INLINE buildToolDepends #-} - - cppOptions :: Lens' a [String] - cppOptions = buildInfo . cppOptions - {-# INLINE cppOptions #-} - - asmOptions :: Lens' a [String] - asmOptions = buildInfo . asmOptions - {-# INLINE asmOptions #-} - - cmmOptions :: Lens' a [String] - cmmOptions = buildInfo . cmmOptions - {-# INLINE cmmOptions #-} - - ccOptions :: Lens' a [String] - ccOptions = buildInfo . ccOptions - {-# INLINE ccOptions #-} - - cxxOptions :: Lens' a [String] - cxxOptions = buildInfo . cxxOptions - {-# INLINE cxxOptions #-} - - ldOptions :: Lens' a [String] - ldOptions = buildInfo . ldOptions - {-# INLINE ldOptions #-} - - hsc2hsOptions :: Lens' a [String] - hsc2hsOptions = buildInfo . hsc2hsOptions - {-# INLINE hsc2hsOptions #-} - - pkgconfigDepends :: Lens' a [PkgconfigDependency] - pkgconfigDepends = buildInfo . pkgconfigDepends - {-# INLINE pkgconfigDepends #-} - - frameworks :: Lens' a [String] - frameworks = buildInfo . frameworks - {-# INLINE frameworks #-} - - extraFrameworkDirs :: Lens' a [String] - extraFrameworkDirs = buildInfo . extraFrameworkDirs - {-# INLINE extraFrameworkDirs #-} - - asmSources :: Lens' a [FilePath] - asmSources = buildInfo . asmSources - {-# INLINE asmSources #-} - - cmmSources :: Lens' a [FilePath] - cmmSources = buildInfo . cmmSources - {-# INLINE cmmSources #-} - - cSources :: Lens' a [FilePath] - cSources = buildInfo . cSources - {-# INLINE cSources #-} - - cxxSources :: Lens' a [FilePath] - cxxSources = buildInfo . cxxSources - {-# INLINE cxxSources #-} - - jsSources :: Lens' a [FilePath] - jsSources = buildInfo . jsSources - {-# INLINE jsSources #-} - - hsSourceDirs :: Lens' a [SymbolicPath PackageDir SourceDir] - hsSourceDirs = buildInfo . hsSourceDirs - {-# INLINE hsSourceDirs #-} - - otherModules :: Lens' a [ModuleName] - otherModules = buildInfo . otherModules - {-# INLINE otherModules #-} - - virtualModules :: Lens' a [ModuleName] - virtualModules = buildInfo . virtualModules - {-# INLINE virtualModules #-} - - autogenModules :: Lens' a [ModuleName] - autogenModules = buildInfo . autogenModules - {-# INLINE autogenModules #-} - - defaultLanguage :: Lens' a (Maybe Language) - defaultLanguage = buildInfo . defaultLanguage - {-# INLINE defaultLanguage #-} - - otherLanguages :: Lens' a [Language] - otherLanguages = buildInfo . otherLanguages - {-# INLINE otherLanguages #-} - - defaultExtensions :: Lens' a [Extension] - defaultExtensions = buildInfo . defaultExtensions - {-# INLINE defaultExtensions #-} - - otherExtensions :: Lens' a [Extension] - otherExtensions = buildInfo . otherExtensions - {-# INLINE otherExtensions #-} - - oldExtensions :: Lens' a [Extension] - oldExtensions = buildInfo . oldExtensions - {-# INLINE oldExtensions #-} - - extraLibs :: Lens' a [String] - extraLibs = buildInfo . extraLibs - {-# INLINE extraLibs #-} - - extraGHCiLibs :: Lens' a [String] - extraGHCiLibs = buildInfo . extraGHCiLibs - {-# INLINE extraGHCiLibs #-} - - extraBundledLibs :: Lens' a [String] - extraBundledLibs = buildInfo . extraBundledLibs - {-# INLINE extraBundledLibs #-} - - extraLibFlavours :: Lens' a [String] - extraLibFlavours = buildInfo . extraLibFlavours - {-# INLINE extraLibFlavours #-} - - extraDynLibFlavours :: Lens' a [String] - extraDynLibFlavours = buildInfo . extraDynLibFlavours - {-# INLINE extraDynLibFlavours #-} - - extraLibDirs :: Lens' a [String] - extraLibDirs = buildInfo . extraLibDirs - {-# INLINE extraLibDirs #-} - - includeDirs :: Lens' a [FilePath] - includeDirs = buildInfo . includeDirs - {-# INLINE includeDirs #-} - - includes :: Lens' a [FilePath] - includes = buildInfo . includes - {-# INLINE includes #-} - - autogenIncludes :: Lens' a [FilePath] - autogenIncludes = buildInfo . autogenIncludes - {-# INLINE autogenIncludes #-} - - installIncludes :: Lens' a [FilePath] - installIncludes = buildInfo . installIncludes - {-# INLINE installIncludes #-} - - options :: Lens' a (PerCompilerFlavor [String]) - options = buildInfo . options - {-# INLINE options #-} - - profOptions :: Lens' a (PerCompilerFlavor [String]) - profOptions = buildInfo . profOptions - {-# INLINE profOptions #-} - - sharedOptions :: Lens' a (PerCompilerFlavor [String]) - sharedOptions = buildInfo . sharedOptions - {-# INLINE sharedOptions #-} - - staticOptions :: Lens' a (PerCompilerFlavor [String]) - staticOptions = buildInfo . staticOptions - {-# INLINE staticOptions #-} - - customFieldsBI :: Lens' a [(String,String)] - customFieldsBI = buildInfo . customFieldsBI - {-# INLINE customFieldsBI #-} - - targetBuildDepends :: Lens' a [Dependency] - targetBuildDepends = buildInfo . targetBuildDepends - {-# INLINE targetBuildDepends #-} - - mixins :: Lens' a [Mixin] - mixins = buildInfo . mixins - {-# INLINE mixins #-} - - -instance HasBuildInfo BuildInfo where - buildInfo = id - {-# INLINE buildInfo #-} - - buildable f s = fmap (\x -> s { T.buildable = x }) (f (T.buildable s)) - {-# INLINE buildable #-} - - buildTools f s = fmap (\x -> s { T.buildTools = x }) (f (T.buildTools s)) - {-# INLINE buildTools #-} - - buildToolDepends f s = fmap (\x -> s { T.buildToolDepends = x }) (f (T.buildToolDepends s)) - {-# INLINE buildToolDepends #-} - - cppOptions f s = fmap (\x -> s { T.cppOptions = x }) (f (T.cppOptions s)) - {-# INLINE cppOptions #-} - - asmOptions f s = fmap (\x -> s { T.asmOptions = x }) (f (T.asmOptions s)) - {-# INLINE asmOptions #-} - - cmmOptions f s = fmap (\x -> s { T.cmmOptions = x }) (f (T.cmmOptions s)) - {-# INLINE cmmOptions #-} - - ccOptions f s = fmap (\x -> s { T.ccOptions = x }) (f (T.ccOptions s)) - {-# INLINE ccOptions #-} - - cxxOptions f s = fmap (\x -> s { T.cxxOptions = x }) (f (T.cxxOptions s)) - {-# INLINE cxxOptions #-} - - ldOptions f s = fmap (\x -> s { T.ldOptions = x }) (f (T.ldOptions s)) - {-# INLINE ldOptions #-} - - hsc2hsOptions f s = fmap (\x -> s { T.hsc2hsOptions = x }) (f (T.hsc2hsOptions s)) - {-# INLINE hsc2hsOptions #-} - - pkgconfigDepends f s = fmap (\x -> s { T.pkgconfigDepends = x }) (f (T.pkgconfigDepends s)) - {-# INLINE pkgconfigDepends #-} - - frameworks f s = fmap (\x -> s { T.frameworks = x }) (f (T.frameworks s)) - {-# INLINE frameworks #-} - - extraFrameworkDirs f s = fmap (\x -> s { T.extraFrameworkDirs = x }) (f (T.extraFrameworkDirs s)) - {-# INLINE extraFrameworkDirs #-} - - asmSources f s = fmap (\x -> s { T.asmSources = x }) (f (T.asmSources s)) - {-# INLINE asmSources #-} - - cmmSources f s = fmap (\x -> s { T.cmmSources = x }) (f (T.cmmSources s)) - {-# INLINE cmmSources #-} - - cSources f s = fmap (\x -> s { T.cSources = x }) (f (T.cSources s)) - {-# INLINE cSources #-} - - cxxSources f s = fmap (\x -> s { T.cSources = x }) (f (T.cxxSources s)) - {-# INLINE cxxSources #-} - - jsSources f s = fmap (\x -> s { T.jsSources = x }) (f (T.jsSources s)) - {-# INLINE jsSources #-} - - hsSourceDirs f s = fmap (\x -> s { T.hsSourceDirs = x }) (f (T.hsSourceDirs s)) - {-# INLINE hsSourceDirs #-} - - otherModules f s = fmap (\x -> s { T.otherModules = x }) (f (T.otherModules s)) - {-# INLINE otherModules #-} - - virtualModules f s = fmap (\x -> s { T.virtualModules = x }) (f (T.virtualModules s)) - {-# INLINE virtualModules #-} - - autogenModules f s = fmap (\x -> s { T.autogenModules = x }) (f (T.autogenModules s)) - {-# INLINE autogenModules #-} - - defaultLanguage f s = fmap (\x -> s { T.defaultLanguage = x }) (f (T.defaultLanguage s)) - {-# INLINE defaultLanguage #-} - - otherLanguages f s = fmap (\x -> s { T.otherLanguages = x }) (f (T.otherLanguages s)) - {-# INLINE otherLanguages #-} - - defaultExtensions f s = fmap (\x -> s { T.defaultExtensions = x }) (f (T.defaultExtensions s)) - {-# INLINE defaultExtensions #-} - - otherExtensions f s = fmap (\x -> s { T.otherExtensions = x }) (f (T.otherExtensions s)) - {-# INLINE otherExtensions #-} - - oldExtensions f s = fmap (\x -> s { T.oldExtensions = x }) (f (T.oldExtensions s)) - {-# INLINE oldExtensions #-} - - extraLibs f s = fmap (\x -> s { T.extraLibs = x }) (f (T.extraLibs s)) - {-# INLINE extraLibs #-} - - extraGHCiLibs f s = fmap (\x -> s { T.extraGHCiLibs = x }) (f (T.extraGHCiLibs s)) - {-# INLINE extraGHCiLibs #-} - - extraBundledLibs f s = fmap (\x -> s { T.extraBundledLibs = x }) (f (T.extraBundledLibs s)) - {-# INLINE extraBundledLibs #-} - - extraLibFlavours f s = fmap (\x -> s { T.extraLibFlavours = x }) (f (T.extraLibFlavours s)) - {-# INLINE extraLibFlavours #-} - - extraDynLibFlavours f s = fmap (\x -> s { T.extraDynLibFlavours = x}) (f (T.extraDynLibFlavours s)) - {-# INLINE extraDynLibFlavours #-} - - extraLibDirs f s = fmap (\x -> s { T.extraLibDirs = x }) (f (T.extraLibDirs s)) - {-# INLINE extraLibDirs #-} - - includeDirs f s = fmap (\x -> s { T.includeDirs = x }) (f (T.includeDirs s)) - {-# INLINE includeDirs #-} - - includes f s = fmap (\x -> s { T.includes = x }) (f (T.includes s)) - {-# INLINE includes #-} - - autogenIncludes f s = fmap (\x -> s { T.autogenIncludes = x }) (f (T.autogenIncludes s)) - {-# INLINE autogenIncludes #-} - - installIncludes f s = fmap (\x -> s { T.installIncludes = x }) (f (T.installIncludes s)) - {-# INLINE installIncludes #-} - - options f s = fmap (\x -> s { T.options = x }) (f (T.options s)) - {-# INLINE options #-} - - profOptions f s = fmap (\x -> s { T.profOptions = x }) (f (T.profOptions s)) - {-# INLINE profOptions #-} - - sharedOptions f s = fmap (\x -> s { T.sharedOptions = x }) (f (T.sharedOptions s)) - {-# INLINE sharedOptions #-} - - staticOptions f s = fmap (\x -> s { T.staticOptions = x }) (f (T.staticOptions s)) - {-# INLINE staticOptions #-} - - customFieldsBI f s = fmap (\x -> s { T.customFieldsBI = x }) (f (T.customFieldsBI s)) - {-# INLINE customFieldsBI #-} - - targetBuildDepends f s = fmap (\x -> s { T.targetBuildDepends = x }) (f (T.targetBuildDepends s)) - {-# INLINE targetBuildDepends #-} - - mixins f s = fmap (\x -> s { T.mixins = x }) (f (T.mixins s)) - {-# INLINE mixins #-} - -class HasBuildInfos a where - traverseBuildInfos :: Traversal' a BuildInfo diff --git a/src/Distribution/Types/BuildType.hs b/src/Distribution/Types/BuildType.hs deleted file mode 100644 --- a/src/Distribution/Types/BuildType.hs +++ /dev/null @@ -1,55 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} - -module Distribution.Types.BuildType ( - BuildType(..), - knownBuildTypes, -) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.CabalSpecVersion (CabalSpecVersion (..)) -import Distribution.Pretty -import Distribution.Parsec - -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp - --- | The type of build system used by this package. -data BuildType - = Simple -- ^ calls @Distribution.Simple.defaultMain@ - | Configure -- ^ calls @Distribution.Simple.defaultMainWithHooks defaultUserHooks@, - -- which invokes @configure@ to generate additional build - -- information used by later phases. - | Make -- ^ calls @Distribution.Make.defaultMain@ - | Custom -- ^ uses user-supplied @Setup.hs@ or @Setup.lhs@ (default) - deriving (Generic, Show, Read, Eq, Typeable, Data) - -instance Binary BuildType -instance Structured BuildType -instance NFData BuildType where rnf = genericRnf - -knownBuildTypes :: [BuildType] -knownBuildTypes = [Simple, Configure, Make, Custom] - -instance Pretty BuildType where - pretty = Disp.text . show - -instance Parsec BuildType where - parsec = do - name <- P.munch1 isAlphaNum - case name of - "Simple" -> return Simple - "Configure" -> return Configure - "Custom" -> return Custom - "Make" -> return Make - "Default" -> do - v <- askCabalSpecVersion - if v <= CabalSpecV1_18 -- oldest version needing this, based on hackage-tests - then do - parsecWarning PWTBuildTypeDefault "build-type: Default is parsed as Custom for legacy reasons. See https://github.com/haskell/cabal/issues/5020" - return Custom - else fail ("unknown build-type: '" ++ name ++ "'") - _ -> fail ("unknown build-type: '" ++ name ++ "'") diff --git a/src/Distribution/Types/Component.hs b/src/Distribution/Types/Component.hs deleted file mode 100644 --- a/src/Distribution/Types/Component.hs +++ /dev/null @@ -1,91 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Distribution.Types.Component ( - Component(..), - foldComponent, - componentBuildInfo, - componentBuildable, - componentName, - partitionComponents, -) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Types.Library -import Distribution.Types.ForeignLib -import Distribution.Types.Executable -import Distribution.Types.TestSuite -import Distribution.Types.Benchmark - -import Distribution.Types.ComponentName -import Distribution.Types.BuildInfo - -import qualified Distribution.Types.BuildInfo.Lens as L - -data Component = CLib Library - | CFLib ForeignLib - | CExe Executable - | CTest TestSuite - | CBench Benchmark - deriving (Show, Eq, Read) - -instance Semigroup Component where - CLib l <> CLib l' = CLib (l <> l') - CFLib l <> CFLib l' = CFLib (l <> l') - CExe e <> CExe e' = CExe (e <> e') - CTest t <> CTest t' = CTest (t <> t') - CBench b <> CBench b' = CBench (b <> b') - _ <> _ = error "Cannot merge Component" - -instance L.HasBuildInfo Component where - buildInfo f (CLib l) = CLib <$> L.buildInfo f l - buildInfo f (CFLib l) = CFLib <$> L.buildInfo f l - buildInfo f (CExe e) = CExe <$> L.buildInfo f e - buildInfo f (CTest t) = CTest <$> L.buildInfo f t - buildInfo f (CBench b) = CBench <$> L.buildInfo f b - -foldComponent :: (Library -> a) - -> (ForeignLib -> a) - -> (Executable -> a) - -> (TestSuite -> a) - -> (Benchmark -> a) - -> Component - -> a -foldComponent f _ _ _ _ (CLib lib) = f lib -foldComponent _ f _ _ _ (CFLib flib)= f flib -foldComponent _ _ f _ _ (CExe exe) = f exe -foldComponent _ _ _ f _ (CTest tst) = f tst -foldComponent _ _ _ _ f (CBench bch) = f bch - -componentBuildInfo :: Component -> BuildInfo -componentBuildInfo = - foldComponent libBuildInfo foreignLibBuildInfo buildInfo testBuildInfo benchmarkBuildInfo - --- | Is a component buildable (i.e., not marked with @buildable: False@)? --- See also this note in --- "Distribution.Types.ComponentRequestedSpec#buildable_vs_enabled_components". --- --- @since 2.0.0.2 --- -componentBuildable :: Component -> Bool -componentBuildable = buildable . componentBuildInfo - -componentName :: Component -> ComponentName -componentName = - foldComponent (CLibName . libName) - (CFLibName . foreignLibName) - (CExeName . exeName) - (CTestName . testName) - (CBenchName . benchmarkName) - -partitionComponents - :: [Component] - -> ([Library], [ForeignLib], [Executable], [TestSuite], [Benchmark]) -partitionComponents = foldr (foldComponent fa fb fc fd fe) ([],[],[],[],[]) - where - fa x ~(a,b,c,d,e) = (x:a,b,c,d,e) - fb x ~(a,b,c,d,e) = (a,x:b,c,d,e) - fc x ~(a,b,c,d,e) = (a,b,x:c,d,e) - fd x ~(a,b,c,d,e) = (a,b,c,x:d,e) - fe x ~(a,b,c,d,e) = (a,b,c,d,x:e) diff --git a/src/Distribution/Types/ComponentId.hs b/src/Distribution/Types/ComponentId.hs deleted file mode 100644 --- a/src/Distribution/Types/ComponentId.hs +++ /dev/null @@ -1,69 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -module Distribution.Types.ComponentId - ( ComponentId, unComponentId, mkComponentId - ) where - -import Prelude () -import Distribution.Compat.Prelude -import Distribution.Utils.ShortText - -import Distribution.Pretty -import Distribution.Parsec - -import qualified Distribution.Compat.CharParsing as P -import Text.PrettyPrint (text) - --- | A 'ComponentId' uniquely identifies the transitive source --- code closure of a component (i.e. libraries, executables). --- --- For non-Backpack components, this corresponds one to one with --- the 'UnitId', which serves as the basis for install paths, --- linker symbols, etc. --- --- Use 'mkComponentId' and 'unComponentId' to convert from/to a --- 'String'. --- --- This type is opaque since @Cabal-2.0@ --- --- @since 2.0.0.2 -newtype ComponentId = ComponentId ShortText - deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) - --- | Construct a 'ComponentId' from a 'String' --- --- 'mkComponentId' is the inverse to 'unComponentId' --- --- Note: No validations are performed to ensure that the resulting --- 'ComponentId' is valid --- --- @since 2.0.0.2 -mkComponentId :: String -> ComponentId -mkComponentId = ComponentId . toShortText - --- | Convert 'ComponentId' to 'String' --- --- @since 2.0.0.2 -unComponentId :: ComponentId -> String -unComponentId (ComponentId s) = fromShortText s - --- | 'mkComponentId' --- --- @since 2.0.0.2 -instance IsString ComponentId where - fromString = mkComponentId - -instance Binary ComponentId -instance Structured ComponentId - -instance Pretty ComponentId where - pretty = text . unComponentId - -instance Parsec ComponentId where - parsec = mkComponentId `fmap` P.munch1 abi_char - where abi_char c = isAlphaNum c || c `elem` "-_." - -instance NFData ComponentId where - rnf = rnf . unComponentId diff --git a/src/Distribution/Types/ComponentName.hs b/src/Distribution/Types/ComponentName.hs deleted file mode 100644 --- a/src/Distribution/Types/ComponentName.hs +++ /dev/null @@ -1,78 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} - -module Distribution.Types.ComponentName ( - ComponentName(..), - showComponentName, - componentNameStanza, - componentNameString, - ) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Types.UnqualComponentName -import Distribution.Types.LibraryName -import Distribution.Pretty -import Distribution.Parsec - -import qualified Text.PrettyPrint as Disp -import qualified Distribution.Compat.CharParsing as P - --- Libraries live in a separate namespace, so must distinguish -data ComponentName = CLibName LibraryName - | CFLibName UnqualComponentName - | CExeName UnqualComponentName - | CTestName UnqualComponentName - | CBenchName UnqualComponentName - deriving (Eq, Generic, Ord, Read, Show, Typeable) - -instance Binary ComponentName -instance Structured ComponentName - --- Build-target-ish syntax -instance Pretty ComponentName where - pretty (CLibName lib) = prettyLibraryNameComponent lib - pretty (CFLibName str) = Disp.text "flib:" <<>> pretty str - pretty (CExeName str) = Disp.text "exe:" <<>> pretty str - pretty (CTestName str) = Disp.text "test:" <<>> pretty str - pretty (CBenchName str) = Disp.text "bench:" <<>> pretty str - -instance Parsec ComponentName where - -- note: this works as lib/flib/... all start with different character! - parsec = parseComposite <|> parseLib - where - parseLib = CLibName <$> parsecLibraryNameComponent - parseComposite = do - ctor <- P.choice - [ P.string "flib:" >> return CFLibName - , P.string "exe:" >> return CExeName - , P.string "bench:" >> return CBenchName - , P.string "test:" >> return CTestName - ] - ctor <$> parsec - -showComponentName :: ComponentName -> String -showComponentName (CLibName lib) = showLibraryName lib -showComponentName (CFLibName name) = "foreign library '" ++ prettyShow name ++ "'" -showComponentName (CExeName name) = "executable '" ++ prettyShow name ++ "'" -showComponentName (CTestName name) = "test suite '" ++ prettyShow name ++ "'" -showComponentName (CBenchName name) = "benchmark '" ++ prettyShow name ++ "'" - -componentNameStanza :: ComponentName -> String -componentNameStanza (CLibName lib) = libraryNameStanza lib -componentNameStanza (CFLibName name) = "foreign-library " ++ prettyShow name -componentNameStanza (CExeName name) = "executable " ++ prettyShow name -componentNameStanza (CTestName name) = "test-suite " ++ prettyShow name -componentNameStanza (CBenchName name) = "benchmark " ++ prettyShow name - --- | This gets the underlying unqualified component name. In fact, it is --- guaranteed to uniquely identify a component, returning --- @Nothing@ if the 'ComponentName' was for the public --- library. -componentNameString :: ComponentName -> Maybe UnqualComponentName -componentNameString (CLibName lib) = libraryNameString lib -componentNameString (CFLibName n) = Just n -componentNameString (CExeName n) = Just n -componentNameString (CTestName n) = Just n -componentNameString (CBenchName n) = Just n diff --git a/src/Distribution/Types/ComponentRequestedSpec.hs b/src/Distribution/Types/ComponentRequestedSpec.hs deleted file mode 100644 --- a/src/Distribution/Types/ComponentRequestedSpec.hs +++ /dev/null @@ -1,127 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Types.ComponentRequestedSpec ( - -- $buildable_vs_enabled_components - - ComponentRequestedSpec(..), - ComponentDisabledReason(..), - - defaultComponentRequestedSpec, - componentNameRequested, - - componentEnabled, - componentDisabledReason, -) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Types.Component -- TODO: maybe remove me? -import Distribution.Types.ComponentName - -import Distribution.Pretty (prettyShow) - --- $buildable_vs_enabled_components --- #buildable_vs_enabled_components# --- --- = Note: Buildable versus requested versus enabled components --- What's the difference between a buildable component (ala --- 'componentBuildable'), a requested component --- (ala 'componentNameRequested'), and an enabled component (ala --- 'componentEnabled')? --- --- A component is __buildable__ if, after resolving flags and --- conditionals, there is no @buildable: False@ property in it. --- This is a /static/ property that arises from the --- Cabal file and the package description flattening; once we have --- a 'PackageDescription' buildability is known. --- --- A component is __requested__ if a user specified, via a --- the flags and arguments passed to configure, that it should be --- built. E.g., @--enable-tests@ or @--enable-benchmarks@ request --- all tests and benchmarks, if they are provided. What is requested --- can be read off directly from 'ComponentRequestedSpec'. A requested --- component is not always buildable; e.g., a user may @--enable-tests@ --- but one of the test suites may have @buildable: False@. --- --- A component is __enabled__ if it is BOTH buildable --- and requested. Once we have a 'LocalBuildInfo', whether or not a --- component is enabled is known. --- --- Generally speaking, most Cabal API code cares if a component --- is enabled. (For example, if you want to run a preprocessor on each --- component prior to building them, you want to run this on each --- /enabled/ component.) --- --- Note that post-configuration, you will generally not see a --- non-buildable 'Component'. This is because 'flattenPD' will drop --- any such components from 'PackageDescription'. See #3858 for --- an example where this causes problems. - --- | Describes what components are enabled by user-interaction. --- See also this note in --- "Distribution.Types.ComponentRequestedSpec#buildable_vs_enabled_components". --- --- @since 2.0.0.2 -data ComponentRequestedSpec - = ComponentRequestedSpec { testsRequested :: Bool - , benchmarksRequested :: Bool } - | OneComponentRequestedSpec ComponentName - deriving (Generic, Read, Show, Eq, Typeable) - -instance Binary ComponentRequestedSpec -instance Structured ComponentRequestedSpec - --- | The default set of enabled components. Historically tests and --- benchmarks are NOT enabled by default. --- --- @since 2.0.0.2 -defaultComponentRequestedSpec :: ComponentRequestedSpec -defaultComponentRequestedSpec = ComponentRequestedSpec False False - --- | Is this component enabled? See also this note in --- "Distribution.Types.ComponentRequestedSpec#buildable_vs_enabled_components". --- --- @since 2.0.0.2 -componentEnabled :: ComponentRequestedSpec -> Component -> Bool -componentEnabled enabled = isNothing . componentDisabledReason enabled - --- | Is this component name enabled? See also this note in --- "Distribution.Types.ComponentRequestedSpec#buildable_vs_enabled_components". --- --- @since 2.0.0.2 -componentNameRequested :: ComponentRequestedSpec -> ComponentName -> Bool -componentNameRequested enabled = isNothing . componentNameNotRequestedReason enabled - --- | Is this component disabled, and if so, why? --- --- @since 2.0.0.2 -componentDisabledReason :: ComponentRequestedSpec -> Component - -> Maybe ComponentDisabledReason -componentDisabledReason enabled comp - | not (componentBuildable comp) = Just DisabledComponent - | otherwise = componentNameNotRequestedReason enabled (componentName comp) - --- | Is this component name disabled, and if so, why? --- --- @since 2.0.0.2 -componentNameNotRequestedReason :: ComponentRequestedSpec -> ComponentName - -> Maybe ComponentDisabledReason -componentNameNotRequestedReason - ComponentRequestedSpec{ testsRequested = False } (CTestName _) - = Just DisabledAllTests -componentNameNotRequestedReason - ComponentRequestedSpec{ benchmarksRequested = False } (CBenchName _) - = Just DisabledAllBenchmarks -componentNameNotRequestedReason ComponentRequestedSpec{} _ = Nothing -componentNameNotRequestedReason (OneComponentRequestedSpec cname) c - | c == cname = Nothing - | otherwise = Just (DisabledAllButOne (prettyShow cname)) - --- | A reason explaining why a component is disabled. --- --- @since 2.0.0.2 -data ComponentDisabledReason = DisabledComponent - | DisabledAllTests - | DisabledAllBenchmarks - | DisabledAllButOne String diff --git a/src/Distribution/Types/CondTree.hs b/src/Distribution/Types/CondTree.hs deleted file mode 100644 --- a/src/Distribution/Types/CondTree.hs +++ /dev/null @@ -1,181 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Distribution.Types.CondTree ( - CondTree(..), - CondBranch(..), - condIfThen, - condIfThenElse, - mapCondTree, - mapTreeConstrs, - mapTreeConds, - mapTreeData, - traverseCondTreeV, - traverseCondBranchV, - traverseCondTreeC, - traverseCondBranchC, - extractCondition, - simplifyCondTree, - ignoreConditions, -) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Types.Condition - -import qualified Distribution.Compat.Lens as L - - --- | A 'CondTree' is used to represent the conditional structure of --- a Cabal file, reflecting a syntax element subject to constraints, --- and then any number of sub-elements which may be enabled subject --- to some condition. Both @a@ and @c@ are usually 'Monoid's. --- --- To be more concrete, consider the following fragment of a @Cabal@ --- file: --- --- @ --- build-depends: base >= 4.0 --- if flag(extra) --- build-depends: base >= 4.2 --- @ --- --- One way to represent this is to have @'CondTree' 'ConfVar' --- ['Dependency'] 'BuildInfo'@. Here, 'condTreeData' represents --- the actual fields which are not behind any conditional, while --- 'condTreeComponents' recursively records any further fields --- which are behind a conditional. 'condTreeConstraints' records --- the constraints (in this case, @base >= 4.0@) which would --- be applied if you use this syntax; in general, this is --- derived off of 'targetBuildInfo' (perhaps a good refactoring --- would be to convert this into an opaque type, with a smart --- constructor that pre-computes the dependencies.) --- -data CondTree v c a = CondNode - { condTreeData :: a - , condTreeConstraints :: c - , condTreeComponents :: [CondBranch v c a] - } - deriving (Show, Eq, Typeable, Data, Generic, Functor, Foldable, Traversable) - -instance (Binary v, Binary c, Binary a) => Binary (CondTree v c a) -instance (Structured v, Structured c, Structured a) => Structured (CondTree v c a) -instance (NFData v, NFData c, NFData a) => NFData (CondTree v c a) where rnf = genericRnf - --- | A 'CondBranch' represents a conditional branch, e.g., @if --- flag(foo)@ on some syntax @a@. It also has an optional false --- branch. --- -data CondBranch v c a = CondBranch - { condBranchCondition :: Condition v - , condBranchIfTrue :: CondTree v c a - , condBranchIfFalse :: Maybe (CondTree v c a) - } - deriving (Show, Eq, Typeable, Data, Generic, Functor, Traversable) - --- This instance is written by hand because GHC 8.0.1/8.0.2 infinite --- loops when trying to derive it with optimizations. See --- https://gitlab.haskell.org/ghc/ghc/-/issues/13056 -instance Foldable (CondBranch v c) where - foldMap f (CondBranch _ c Nothing) = foldMap f c - foldMap f (CondBranch _ c (Just a)) = foldMap f c `mappend` foldMap f a - -instance (Binary v, Binary c, Binary a) => Binary (CondBranch v c a) -instance (Structured v, Structured c, Structured a) => Structured (CondBranch v c a) -instance (NFData v, NFData c, NFData a) => NFData (CondBranch v c a) where rnf = genericRnf - -condIfThen :: Condition v -> CondTree v c a -> CondBranch v c a -condIfThen c t = CondBranch c t Nothing - -condIfThenElse :: Condition v -> CondTree v c a -> CondTree v c a -> CondBranch v c a -condIfThenElse c t e = CondBranch c t (Just e) - -mapCondTree :: (a -> b) -> (c -> d) -> (Condition v -> Condition w) - -> CondTree v c a -> CondTree w d b -mapCondTree fa fc fcnd (CondNode a c ifs) = - CondNode (fa a) (fc c) (map g ifs) - where - g (CondBranch cnd t me) - = CondBranch (fcnd cnd) - (mapCondTree fa fc fcnd t) - (fmap (mapCondTree fa fc fcnd) me) - -mapTreeConstrs :: (c -> d) -> CondTree v c a -> CondTree v d a -mapTreeConstrs f = mapCondTree id f id - -mapTreeConds :: (Condition v -> Condition w) -> CondTree v c a -> CondTree w c a -mapTreeConds f = mapCondTree id id f - -mapTreeData :: (a -> b) -> CondTree v c a -> CondTree v c b -mapTreeData f = mapCondTree f id id - --- | @@Traversal@@ for the variables -traverseCondTreeV :: L.Traversal (CondTree v c a) (CondTree w c a) v w -traverseCondTreeV f (CondNode a c ifs) = - CondNode a c <$> traverse (traverseCondBranchV f) ifs - --- | @@Traversal@@ for the variables -traverseCondBranchV :: L.Traversal (CondBranch v c a) (CondBranch w c a) v w -traverseCondBranchV f (CondBranch cnd t me) = CondBranch - <$> traverse f cnd - <*> traverseCondTreeV f t - <*> traverse (traverseCondTreeV f) me - --- | @@Traversal@@ for the aggregated constraints -traverseCondTreeC :: L.Traversal (CondTree v c a) (CondTree v d a) c d -traverseCondTreeC f (CondNode a c ifs) = - CondNode a <$> f c <*> traverse (traverseCondBranchC f) ifs - --- | @@Traversal@@ for the aggregated constraints -traverseCondBranchC :: L.Traversal (CondBranch v c a) (CondBranch v d a) c d -traverseCondBranchC f (CondBranch cnd t me) = CondBranch cnd - <$> traverseCondTreeC f t - <*> traverse (traverseCondTreeC f) me - - --- | Extract the condition matched by the given predicate from a cond tree. --- --- We use this mainly for extracting buildable conditions (see the Note in --- Distribution.PackageDescription.Configuration), but the function is in fact --- more general. -extractCondition :: Eq v => (a -> Bool) -> CondTree v c a -> Condition v -extractCondition p = go - where - go (CondNode x _ cs) | not (p x) = Lit False - | otherwise = goList cs - - goList [] = Lit True - goList (CondBranch c t e : cs) = - let - ct = go t - ce = maybe (Lit True) go e - in - ((c `cAnd` ct) `cOr` (CNot c `cAnd` ce)) `cAnd` goList cs - --- | Flattens a CondTree using a partial flag assignment. When a condition --- cannot be evaluated, both branches are ignored. -simplifyCondTree :: (Semigroup a, Semigroup d) => - (v -> Either v Bool) - -> CondTree v d a - -> (d, a) -simplifyCondTree env (CondNode a d ifs) = - foldl (<>) (d, a) $ mapMaybe simplifyIf ifs - where - simplifyIf (CondBranch cnd t me) = - case simplifyCondition cnd env of - (Lit True, _) -> Just $ simplifyCondTree env t - (Lit False, _) -> fmap (simplifyCondTree env) me - _ -> Nothing - --- | Flatten a CondTree. This will resolve the CondTree by taking all --- possible paths into account. Note that since branches represent exclusive --- choices this may not result in a \"sane\" result. -ignoreConditions :: (Semigroup a, Semigroup c) => CondTree v c a -> (a, c) -ignoreConditions (CondNode a c ifs) = foldl (<>) (a, c) $ concatMap f ifs - where f (CondBranch _ t me) = ignoreConditions t - : maybeToList (fmap ignoreConditions me) diff --git a/src/Distribution/Types/Condition.hs b/src/Distribution/Types/Condition.hs deleted file mode 100644 --- a/src/Distribution/Types/Condition.hs +++ /dev/null @@ -1,135 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} - -module Distribution.Types.Condition ( - Condition(..), - cNot, - cAnd, - cOr, - simplifyCondition, -) where - -import Prelude () -import Distribution.Compat.Prelude - --- | A boolean expression parameterized over the variable type used. -data Condition c = Var c - | Lit Bool - | CNot (Condition c) - | COr (Condition c) (Condition c) - | CAnd (Condition c) (Condition c) - deriving (Show, Eq, Typeable, Data, Generic) - --- | Boolean negation of a 'Condition' value. -cNot :: Condition a -> Condition a -cNot (Lit b) = Lit (not b) -cNot (CNot c) = c -cNot c = CNot c - --- | Boolean AND of two 'Condtion' values. -cAnd :: Condition a -> Condition a -> Condition a -cAnd (Lit False) _ = Lit False -cAnd _ (Lit False) = Lit False -cAnd (Lit True) x = x -cAnd x (Lit True) = x -cAnd x y = CAnd x y - --- | Boolean OR of two 'Condition' values. -cOr :: Eq v => Condition v -> Condition v -> Condition v -cOr (Lit True) _ = Lit True -cOr _ (Lit True) = Lit True -cOr (Lit False) x = x -cOr x (Lit False) = x -cOr c (CNot d) - | c == d = Lit True -cOr (CNot c) d - | c == d = Lit True -cOr x y = COr x y - -instance Functor Condition where - f `fmap` Var c = Var (f c) - _ `fmap` Lit c = Lit c - f `fmap` CNot c = CNot (fmap f c) - f `fmap` COr c d = COr (fmap f c) (fmap f d) - f `fmap` CAnd c d = CAnd (fmap f c) (fmap f d) - -instance Foldable Condition where - f `foldMap` Var c = f c - _ `foldMap` Lit _ = mempty - f `foldMap` CNot c = foldMap f c - f `foldMap` COr c d = foldMap f c `mappend` foldMap f d - f `foldMap` CAnd c d = foldMap f c `mappend` foldMap f d - -instance Traversable Condition where - f `traverse` Var c = Var `fmap` f c - _ `traverse` Lit c = pure $ Lit c - f `traverse` CNot c = CNot `fmap` traverse f c - f `traverse` COr c d = COr `fmap` traverse f c <*> traverse f d - f `traverse` CAnd c d = CAnd `fmap` traverse f c <*> traverse f d - -instance Applicative Condition where - pure = Var - (<*>) = ap - -instance Monad Condition where - return = pure - -- Terminating cases - (>>=) (Lit x) _ = Lit x - (>>=) (Var x) f = f x - -- Recursing cases - (>>=) (CNot x ) f = CNot (x >>= f) - (>>=) (COr x y) f = COr (x >>= f) (y >>= f) - (>>=) (CAnd x y) f = CAnd (x >>= f) (y >>= f) - -instance Monoid (Condition a) where - mempty = Lit False - mappend = (<>) - -instance Semigroup (Condition a) where - (<>) = COr - -instance Alternative Condition where - empty = mempty - (<|>) = mappend - -instance MonadPlus Condition where - mzero = mempty - mplus = mappend - -instance Binary c => Binary (Condition c) -instance Structured c => Structured (Condition c) -instance NFData c => NFData (Condition c) where rnf = genericRnf - --- | Simplify the condition and return its free variables. -simplifyCondition :: Condition c - -> (c -> Either d Bool) -- ^ (partial) variable assignment - -> (Condition d, [d]) -simplifyCondition cond i = fv . walk $ cond - where - walk cnd = case cnd of - Var v -> either Var Lit (i v) - Lit b -> Lit b - CNot c -> case walk c of - Lit True -> Lit False - Lit False -> Lit True - c' -> CNot c' - COr c d -> case (walk c, walk d) of - (Lit False, d') -> d' - (Lit True, _) -> Lit True - (c', Lit False) -> c' - (_, Lit True) -> Lit True - (c',d') -> COr c' d' - CAnd c d -> case (walk c, walk d) of - (Lit False, _) -> Lit False - (Lit True, d') -> d' - (_, Lit False) -> Lit False - (c', Lit True) -> c' - (c',d') -> CAnd c' d' - -- gather free vars - fv c = (c, fv' c) - fv' c = case c of - Var v -> [v] - Lit _ -> [] - CNot c' -> fv' c' - COr c1 c2 -> fv' c1 ++ fv' c2 - CAnd c1 c2 -> fv' c1 ++ fv' c2 diff --git a/src/Distribution/Types/ConfVar.hs b/src/Distribution/Types/ConfVar.hs deleted file mode 100644 --- a/src/Distribution/Types/ConfVar.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Types.ConfVar ( - ConfVar(..), - ) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Types.Flag -import Distribution.Types.VersionRange -import Distribution.Compiler -import Distribution.System - --- | A @ConfVar@ represents the variable type used. -data ConfVar = OS OS - | Arch Arch - | PackageFlag FlagName - | Impl CompilerFlavor VersionRange - deriving (Eq, Show, Typeable, Data, Generic) - -instance Binary ConfVar -instance Structured ConfVar - -instance NFData ConfVar where rnf = genericRnf diff --git a/src/Distribution/Types/Dependency.hs b/src/Distribution/Types/Dependency.hs deleted file mode 100644 --- a/src/Distribution/Types/Dependency.hs +++ /dev/null @@ -1,179 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Types.Dependency - ( Dependency(..) - , mkDependency - , depPkgName - , depVerRange - , depLibraries - , simplifyDependency - , mainLibSet - ) where - -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Types.VersionRange (isAnyVersionLight) -import Distribution.Version (VersionRange, anyVersion, simplifyVersionRange) - -import Distribution.CabalSpecVersion -import Distribution.Compat.CharParsing (char, spaces) -import Distribution.Compat.Parsing (between, option) -import Distribution.Parsec -import Distribution.Pretty -import Distribution.Types.LibraryName -import Distribution.Types.PackageName -import Distribution.Types.UnqualComponentName - -import qualified Distribution.Compat.NonEmptySet as NES -import qualified Text.PrettyPrint as PP - --- | Describes a dependency on a source package (API) --- --- /Invariant:/ package name does not appear as 'LSubLibName' in --- set of library names. --- -data Dependency = Dependency - PackageName - VersionRange - (NonEmptySet LibraryName) - -- ^ The set of libraries required from the package. - -- Only the selected libraries will be built. - -- It does not affect the cabal-install solver yet. - deriving (Generic, Read, Show, Eq, Typeable, Data) - -depPkgName :: Dependency -> PackageName -depPkgName (Dependency pn _ _) = pn - -depVerRange :: Dependency -> VersionRange -depVerRange (Dependency _ vr _) = vr - -depLibraries :: Dependency -> NonEmptySet LibraryName -depLibraries (Dependency _ _ cs) = cs - --- | Smart constructor of 'Dependency'. --- --- If 'PackageName' is appears as 'LSubLibName' in a set of sublibraries, --- it is automatically converted to 'LMainLibName'. --- --- @since 3.4.0.0 --- -mkDependency :: PackageName -> VersionRange -> NonEmptySet LibraryName -> Dependency -mkDependency pn vr lb = Dependency pn vr (NES.map conv lb) - where - pn' = packageNameToUnqualComponentName pn - - conv l@LMainLibName = l - conv l@(LSubLibName ln) | ln == pn' = LMainLibName - | otherwise = l - -instance Binary Dependency -instance Structured Dependency -instance NFData Dependency where rnf = genericRnf - --- | --- --- >>> prettyShow $ Dependency "pkg" anyVersion mainLibSet --- "pkg" --- --- >>> prettyShow $ Dependency "pkg" anyVersion $ NES.insert (LSubLibName "sublib") mainLibSet --- "pkg:{pkg, sublib}" --- --- >>> prettyShow $ Dependency "pkg" anyVersion $ NES.singleton (LSubLibName "sublib") --- "pkg:sublib" --- --- >>> prettyShow $ Dependency "pkg" anyVersion $ NES.insert (LSubLibName "sublib-b") $ NES.singleton (LSubLibName "sublib-a") --- "pkg:{sublib-a, sublib-b}" --- -instance Pretty Dependency where - pretty (Dependency name ver sublibs) = withSubLibs (pretty name) <+> pver - where - -- TODO: change to isAnyVersion after #6736 - pver | isAnyVersionLight ver = PP.empty - | otherwise = pretty ver - - withSubLibs doc = case NES.toList sublibs of - [LMainLibName] -> doc - [LSubLibName uq] -> doc <<>> PP.colon <<>> pretty uq - _ -> doc <<>> PP.colon <<>> PP.braces prettySublibs - - prettySublibs = PP.hsep $ PP.punctuate PP.comma $ prettySublib <$> NES.toList sublibs - - prettySublib LMainLibName = PP.text $ unPackageName name - prettySublib (LSubLibName un) = PP.text $ unUnqualComponentName un - --- | --- --- >>> simpleParsec "mylib:sub" :: Maybe Dependency --- Just (Dependency (PackageName "mylib") (OrLaterVersion (mkVersion [0])) (fromNonEmpty (LSubLibName (UnqualComponentName "sub") :| []))) --- --- >>> simpleParsec "mylib:{sub1,sub2}" :: Maybe Dependency --- Just (Dependency (PackageName "mylib") (OrLaterVersion (mkVersion [0])) (fromNonEmpty (LSubLibName (UnqualComponentName "sub1") :| [LSubLibName (UnqualComponentName "sub2")]))) --- --- >>> simpleParsec "mylib:{ sub1 , sub2 }" :: Maybe Dependency --- Just (Dependency (PackageName "mylib") (OrLaterVersion (mkVersion [0])) (fromNonEmpty (LSubLibName (UnqualComponentName "sub1") :| [LSubLibName (UnqualComponentName "sub2")]))) --- --- >>> simpleParsec "mylib:{ sub1 , sub2 } ^>= 42" :: Maybe Dependency --- Just (Dependency (PackageName "mylib") (MajorBoundVersion (mkVersion [42])) (fromNonEmpty (LSubLibName (UnqualComponentName "sub1") :| [LSubLibName (UnqualComponentName "sub2")]))) --- --- >>> simpleParsec "mylib:{ } ^>= 42" :: Maybe Dependency --- Nothing --- --- >>> traverse_ print (map simpleParsec ["mylib:mylib", "mylib:{mylib}", "mylib:{mylib,sublib}" ] :: [Maybe Dependency]) --- Just (Dependency (PackageName "mylib") (OrLaterVersion (mkVersion [0])) (fromNonEmpty (LMainLibName :| []))) --- Just (Dependency (PackageName "mylib") (OrLaterVersion (mkVersion [0])) (fromNonEmpty (LMainLibName :| []))) --- Just (Dependency (PackageName "mylib") (OrLaterVersion (mkVersion [0])) (fromNonEmpty (LMainLibName :| [LSubLibName (UnqualComponentName "sublib")]))) --- --- Spaces around colon are not allowed: --- --- >>> map simpleParsec ["mylib: sub", "mylib :sub", "mylib: {sub1,sub2}", "mylib :{sub1,sub2}"] :: [Maybe Dependency] --- [Nothing,Nothing,Nothing,Nothing] --- --- Sublibrary syntax is accepted since @cabal-version: 3.0@ --- --- >>> map (`simpleParsec'` "mylib:sub") [CabalSpecV2_4, CabalSpecV3_0] :: [Maybe Dependency] --- [Nothing,Just (Dependency (PackageName "mylib") (OrLaterVersion (mkVersion [0])) (fromNonEmpty (LSubLibName (UnqualComponentName "sub") :| [])))] --- -instance Parsec Dependency where - parsec = do - name <- parsec - - libs <- option mainLibSet $ do - _ <- char ':' - versionGuardMultilibs - parsecWarning PWTExperimental "colon specifier is experimental feature (issue #5660)" - NES.singleton <$> parseLib <|> parseMultipleLibs - - spaces -- https://github.com/haskell/cabal/issues/5846 - - ver <- parsec <|> pure anyVersion - return $ mkDependency name ver libs - where - parseLib = LSubLibName <$> parsec - parseMultipleLibs = between - (char '{' *> spaces) - (spaces *> char '}') - (NES.fromNonEmpty <$> parsecCommaNonEmpty parseLib) - -versionGuardMultilibs :: CabalParsing m => m () -versionGuardMultilibs = do - csv <- askCabalSpecVersion - when (csv < CabalSpecV3_0) $ fail $ unwords - [ "Sublibrary dependency syntax used." - , "To use this syntax the package needs to specify at least 'cabal-version: 3.0'." - , "Alternatively, if you are depending on an internal library, you can write" - , "directly the library name as it were a package." - ] - --- | Library set with main library. --- --- @since 3.4.0.0 -mainLibSet :: NonEmptySet LibraryName -mainLibSet = NES.singleton LMainLibName - --- | Simplify the 'VersionRange' expression in a 'Dependency'. --- See 'simplifyVersionRange'. --- -simplifyDependency :: Dependency -> Dependency -simplifyDependency (Dependency name range comps) = - Dependency name (simplifyVersionRange range) comps diff --git a/src/Distribution/Types/DependencyMap.hs b/src/Distribution/Types/DependencyMap.hs deleted file mode 100644 --- a/src/Distribution/Types/DependencyMap.hs +++ /dev/null @@ -1,57 +0,0 @@ -module Distribution.Types.DependencyMap ( - DependencyMap, - toDepMap, - fromDepMap, - constrainBy, -) where - -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Types.Dependency -import Distribution.Types.LibraryName -import Distribution.Types.PackageName -import Distribution.Types.PackageVersionConstraint -import Distribution.Version - -import qualified Data.Map.Lazy as Map - --- | A map of dependencies. Newtyped since the default monoid instance is not --- appropriate. The monoid instance uses 'intersectVersionRanges'. -newtype DependencyMap = DependencyMap { unDependencyMap :: Map PackageName (VersionRange, NonEmptySet LibraryName) } - deriving (Show, Read) - -instance Monoid DependencyMap where - mempty = DependencyMap Map.empty - mappend = (<>) - -instance Semigroup DependencyMap where - (DependencyMap a) <> (DependencyMap b) = - DependencyMap (Map.unionWith intersectVersionRangesAndJoinComponents a b) - -intersectVersionRangesAndJoinComponents :: (VersionRange, NonEmptySet LibraryName) - -> (VersionRange, NonEmptySet LibraryName) - -> (VersionRange, NonEmptySet LibraryName) -intersectVersionRangesAndJoinComponents (va, ca) (vb, cb) = - (intersectVersionRanges va vb, ca <> cb) - -toDepMap :: [Dependency] -> DependencyMap -toDepMap ds = - DependencyMap $ Map.fromListWith intersectVersionRangesAndJoinComponents [ (p,(vr,cs)) | Dependency p vr cs <- ds ] - -fromDepMap :: DependencyMap -> [Dependency] -fromDepMap m = [ Dependency p vr cs | (p,(vr,cs)) <- Map.toList (unDependencyMap m) ] - --- Apply extra constraints to a dependency map. --- Combines dependencies where the result will only contain keys from the left --- (first) map. If a key also exists in the right map, both constraints will --- be intersected. -constrainBy - :: DependencyMap - -> [PackageVersionConstraint] - -> DependencyMap -constrainBy = foldl' tightenConstraint where - tightenConstraint (DependencyMap l) (PackageVersionConstraint pn vr) = DependencyMap $ - case Map.lookup pn l of - Nothing -> l - Just (vr', cs) -> Map.insert pn (intersectVersionRanges vr' vr, cs) l diff --git a/src/Distribution/Types/DumpBuildInfo.hs b/src/Distribution/Types/DumpBuildInfo.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Types/DumpBuildInfo.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +module Distribution.Types.DumpBuildInfo + ( DumpBuildInfo(..) + ) where + +import Distribution.Compat.Prelude + +data DumpBuildInfo + = NoDumpBuildInfo + | DumpBuildInfo + deriving (Read, Show, Eq, Ord, Enum, Bounded, Generic, Typeable) + +instance Binary DumpBuildInfo +instance Structured DumpBuildInfo diff --git a/src/Distribution/Types/ExeDependency.hs b/src/Distribution/Types/ExeDependency.hs deleted file mode 100644 --- a/src/Distribution/Types/ExeDependency.hs +++ /dev/null @@ -1,71 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Types.ExeDependency - ( ExeDependency(..) - , qualifiedExeName - ) where - -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Parsec -import Distribution.Pretty -import Distribution.Types.ComponentName -import Distribution.Types.PackageName -import Distribution.Types.UnqualComponentName -import Distribution.Version (VersionRange, anyVersion, isAnyVersion) - -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as PP - --- | Describes a dependency on an executable from a package --- -data ExeDependency = ExeDependency - PackageName - UnqualComponentName -- name of executable component of package - VersionRange - deriving (Generic, Read, Show, Eq, Typeable, Data) - -instance Binary ExeDependency -instance Structured ExeDependency -instance NFData ExeDependency where rnf = genericRnf - -instance Pretty ExeDependency where - pretty (ExeDependency name exe ver) = - pretty name <<>> PP.colon <<>> pretty exe PP.<+> pver - where - pver | isAnyVersion ver = PP.empty - | otherwise = pretty ver - --- | --- --- Examples --- --- >>> simpleParsec "happy:happy" :: Maybe ExeDependency --- Just (ExeDependency (PackageName "happy") (UnqualComponentName "happy") (OrLaterVersion (mkVersion [0]))) --- --- >>> simpleParsec "happy:happy >= 1.19.12" :: Maybe ExeDependency --- Just (ExeDependency (PackageName "happy") (UnqualComponentName "happy") (OrLaterVersion (mkVersion [1,19,12]))) --- --- >>> simpleParsec "happy:happy>=1.19.12" :: Maybe ExeDependency --- Just (ExeDependency (PackageName "happy") (UnqualComponentName "happy") (OrLaterVersion (mkVersion [1,19,12]))) --- --- >>> simpleParsec "happy : happy >= 1.19.12" :: Maybe ExeDependency --- Nothing --- --- >>> simpleParsec "happy: happy >= 1.19.12" :: Maybe ExeDependency --- Nothing --- --- >>> simpleParsec "happy :happy >= 1.19.12" :: Maybe ExeDependency --- Nothing --- -instance Parsec ExeDependency where - parsec = do - name <- parsec - _ <- P.char ':' - exe <- lexemeParsec - ver <- parsec <|> pure anyVersion - return (ExeDependency name exe ver) - -qualifiedExeName :: ExeDependency -> ComponentName -qualifiedExeName (ExeDependency _ ucn _) = CExeName ucn diff --git a/src/Distribution/Types/Executable.hs b/src/Distribution/Types/Executable.hs deleted file mode 100644 --- a/src/Distribution/Types/Executable.hs +++ /dev/null @@ -1,65 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} - -module Distribution.Types.Executable ( - Executable(..), - emptyExecutable, - exeModules, - exeModulesAutogen -) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Types.BuildInfo -import Distribution.Types.UnqualComponentName -import Distribution.Types.ExecutableScope -import Distribution.ModuleName - -import qualified Distribution.Types.BuildInfo.Lens as L - -data Executable = Executable { - exeName :: UnqualComponentName, - modulePath :: FilePath, - exeScope :: ExecutableScope, - buildInfo :: BuildInfo - } - deriving (Generic, Show, Read, Eq, Typeable, Data) - -instance L.HasBuildInfo Executable where - buildInfo f l = (\x -> l { buildInfo = x }) <$> f (buildInfo l) - -instance Binary Executable -instance Structured Executable -instance NFData Executable where rnf = genericRnf - -instance Monoid Executable where - mempty = gmempty - mappend = (<>) - -instance Semigroup Executable where - a <> b = Executable{ - exeName = combine' exeName, - modulePath = combine modulePath, - exeScope = combine exeScope, - buildInfo = combine buildInfo - } - where combine field = field a `mappend` field b - combine' field = case ( unUnqualComponentName $ field a - , unUnqualComponentName $ field b) of - ("", _) -> field b - (_, "") -> field a - (x, y) -> error $ "Ambiguous values for executable field: '" - ++ x ++ "' and '" ++ y ++ "'" - -emptyExecutable :: Executable -emptyExecutable = mempty - --- | Get all the module names from an exe -exeModules :: Executable -> [ModuleName] -exeModules exe = otherModules (buildInfo exe) - --- | Get all the auto generated module names from an exe --- This are a subset of 'exeModules'. -exeModulesAutogen :: Executable -> [ModuleName] -exeModulesAutogen exe = autogenModules (buildInfo exe) diff --git a/src/Distribution/Types/Executable/Lens.hs b/src/Distribution/Types/Executable/Lens.hs deleted file mode 100644 --- a/src/Distribution/Types/Executable/Lens.hs +++ /dev/null @@ -1,31 +0,0 @@ -module Distribution.Types.Executable.Lens ( - Executable, - module Distribution.Types.Executable.Lens, - ) where - -import Distribution.Compat.Lens -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Types.BuildInfo (BuildInfo) -import Distribution.Types.Executable (Executable) -import Distribution.Types.ExecutableScope (ExecutableScope) -import Distribution.Types.UnqualComponentName (UnqualComponentName) - -import qualified Distribution.Types.Executable as T - -exeName :: Lens' Executable UnqualComponentName -exeName f s = fmap (\x -> s { T.exeName = x }) (f (T.exeName s)) -{-# INLINE exeName #-} - -modulePath :: Lens' Executable String -modulePath f s = fmap (\x -> s { T.modulePath = x }) (f (T.modulePath s)) -{-# INLINE modulePath #-} - -exeScope :: Lens' Executable ExecutableScope -exeScope f s = fmap (\x -> s { T.exeScope = x }) (f (T.exeScope s)) -{-# INLINE exeScope #-} - -exeBuildInfo :: Lens' Executable BuildInfo -exeBuildInfo f s = fmap (\x -> s { T.buildInfo = x }) (f (T.buildInfo s)) -{-# INLINE exeBuildInfo #-} diff --git a/src/Distribution/Types/ExecutableScope.hs b/src/Distribution/Types/ExecutableScope.hs deleted file mode 100644 --- a/src/Distribution/Types/ExecutableScope.hs +++ /dev/null @@ -1,43 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} - -module Distribution.Types.ExecutableScope ( - ExecutableScope(..), -) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Pretty -import Distribution.Parsec - -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp - -data ExecutableScope = ExecutablePublic - | ExecutablePrivate - deriving (Generic, Show, Read, Eq, Typeable, Data) - -instance Pretty ExecutableScope where - pretty ExecutablePublic = Disp.text "public" - pretty ExecutablePrivate = Disp.text "private" - -instance Parsec ExecutableScope where - parsec = P.try pub <|> pri where - pub = ExecutablePublic <$ P.string "public" - pri = ExecutablePrivate <$ P.string "private" - -instance Binary ExecutableScope -instance Structured ExecutableScope -instance NFData ExecutableScope where rnf = genericRnf - --- | 'Any' like semigroup, where 'ExecutablePrivate' is 'Any True' -instance Semigroup ExecutableScope where - ExecutablePublic <> x = x - x@ExecutablePrivate <> _ = x - --- | 'mempty' = 'ExecutablePublic' -instance Monoid ExecutableScope where - mempty = ExecutablePublic - mappend = (<>) diff --git a/src/Distribution/Types/ExposedModule.hs b/src/Distribution/Types/ExposedModule.hs deleted file mode 100644 --- a/src/Distribution/Types/ExposedModule.hs +++ /dev/null @@ -1,45 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Types.ExposedModule where - -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Backpack -import Distribution.ModuleName -import Distribution.Parsec -import Distribution.Pretty - -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp - -data ExposedModule - = ExposedModule { - exposedName :: ModuleName, - exposedReexport :: Maybe OpenModule - } - deriving (Eq, Generic, Read, Show, Typeable) - -instance Pretty ExposedModule where - pretty (ExposedModule m reexport) = - Disp.hsep [ pretty m - , case reexport of - Just m' -> Disp.hsep [Disp.text "from", pretty m'] - Nothing -> Disp.empty - ] - -instance Parsec ExposedModule where - parsec = do - m <- parsecMaybeQuoted parsec - P.spaces - - reexport <- P.optional $ do - _ <- P.string "from" - P.skipSpaces1 - parsec - - return (ExposedModule m reexport) - -instance Binary ExposedModule -instance Structured ExposedModule -instance NFData ExposedModule where rnf = genericRnf diff --git a/src/Distribution/Types/Flag.hs b/src/Distribution/Types/Flag.hs deleted file mode 100644 --- a/src/Distribution/Types/Flag.hs +++ /dev/null @@ -1,346 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -module Distribution.Types.Flag ( - -- * Package flag - PackageFlag(..), - emptyFlag, - -- * Flag name - FlagName, - mkFlagName, - unFlagName, - -- * Flag assignment - FlagAssignment, - mkFlagAssignment, - unFlagAssignment, - lookupFlagAssignment, - insertFlagAssignment, - diffFlagAssignment, - findDuplicateFlagAssignments, - nullFlagAssignment, - showFlagValue, - dispFlagAssignment, - showFlagAssignment, - parsecFlagAssignment, - parsecFlagAssignmentNonEmpty, - -- ** Legacy formats - legacyShowFlagAssignment, - legacyShowFlagAssignment', - legacyParsecFlagAssignment, - ) where - -import Prelude () -import Distribution.Compat.Prelude -import Distribution.Utils.ShortText -import Distribution.Utils.Generic (lowercase) - -import Distribution.Parsec -import Distribution.Pretty - -import qualified Data.Map as Map -import qualified Text.PrettyPrint as Disp -import qualified Distribution.Compat.CharParsing as P - --- ----------------------------------------------------------------------------- --- The Flag' type - --- | A flag can represent a feature to be included, or a way of linking --- a target against its dependencies, or in fact whatever you can think of. -data PackageFlag = MkPackageFlag - { flagName :: FlagName - , flagDescription :: String - , flagDefault :: Bool - , flagManual :: Bool - } - deriving (Show, Eq, Typeable, Data, Generic) - -instance Binary PackageFlag -instance Structured PackageFlag -instance NFData PackageFlag where rnf = genericRnf - --- | A 'PackageFlag' initialized with default parameters. -emptyFlag :: FlagName -> PackageFlag -emptyFlag name = MkPackageFlag - { flagName = name - , flagDescription = "" - , flagDefault = True - , flagManual = False - } - --- | A 'FlagName' is the name of a user-defined configuration flag --- --- Use 'mkFlagName' and 'unFlagName' to convert from/to a 'String'. --- --- This type is opaque since @Cabal-2.0@ --- --- @since 2.0.0.2 -newtype FlagName = FlagName ShortText - deriving (Eq, Generic, Ord, Show, Read, Typeable, Data, NFData) - --- | Construct a 'FlagName' from a 'String' --- --- 'mkFlagName' is the inverse to 'unFlagName' --- --- Note: No validations are performed to ensure that the resulting --- 'FlagName' is valid --- --- @since 2.0.0.2 -mkFlagName :: String -> FlagName -mkFlagName = FlagName . toShortText - --- | 'mkFlagName' --- --- @since 2.0.0.2 -instance IsString FlagName where - fromString = mkFlagName - --- | Convert 'FlagName' to 'String' --- --- @since 2.0.0.2 -unFlagName :: FlagName -> String -unFlagName (FlagName s) = fromShortText s - -instance Binary FlagName -instance Structured FlagName - -instance Pretty FlagName where - pretty = Disp.text . unFlagName - -instance Parsec FlagName where - -- Note: we don't check that FlagName doesn't have leading dash, - -- cabal check will do that. - parsec = mkFlagName . lowercase <$> parsec' - where - parsec' = (:) <$> lead <*> rest - lead = P.satisfy (\c -> isAlphaNum c || c == '_') - rest = P.munch (\c -> isAlphaNum c || c == '_' || c == '-') - --- | A 'FlagAssignment' is a total or partial mapping of 'FlagName's to --- 'Bool' flag values. It represents the flags chosen by the user or --- discovered during configuration. For example @--flags=foo --flags=-bar@ --- becomes @[("foo", True), ("bar", False)]@ --- --- TODO: Why we record the multiplicity of the flag? --- -newtype FlagAssignment - = FlagAssignment { getFlagAssignment :: Map.Map FlagName (Int, Bool) } - deriving (Binary, Generic, NFData, Typeable) - -instance Structured FlagAssignment - -instance Eq FlagAssignment where - (==) (FlagAssignment m1) (FlagAssignment m2) - = fmap snd m1 == fmap snd m2 - -instance Ord FlagAssignment where - compare (FlagAssignment m1) (FlagAssignment m2) - = fmap snd m1 `compare` fmap snd m2 - --- | Combines pairs of values contained in the 'FlagAssignment' Map. --- --- The last flag specified takes precedence, and we record the number --- of times we have seen the flag. --- -combineFlagValues :: (Int, Bool) -> (Int, Bool) -> (Int, Bool) -combineFlagValues (c1, _) (c2, b2) = (c1 + c2, b2) - --- The 'Semigroup' instance currently is right-biased. --- --- If duplicate flags are specified, we want the last flag specified to --- take precedence and we want to know how many times the flag has been --- specified so that we have the option of warning the user about --- supplying duplicate flags. -instance Semigroup FlagAssignment where - (<>) (FlagAssignment m1) (FlagAssignment m2) - = FlagAssignment (Map.unionWith combineFlagValues m1 m2) - -instance Monoid FlagAssignment where - mempty = FlagAssignment Map.empty - mappend = (<>) - --- | Construct a 'FlagAssignment' from a list of flag/value pairs. --- --- If duplicate flags occur in the input list, the later entries --- in the list will take precedence. --- --- @since 2.2.0 -mkFlagAssignment :: [(FlagName, Bool)] -> FlagAssignment -mkFlagAssignment = - FlagAssignment . - Map.fromListWith (flip combineFlagValues) . fmap (fmap (\b -> (1, b))) - --- | Deconstruct a 'FlagAssignment' into a list of flag/value pairs. --- --- @ 'null' ('findDuplicateFlagAssignments' fa) ==> ('mkFlagAssignment' . 'unFlagAssignment') fa == fa @ --- --- @since 2.2.0 -unFlagAssignment :: FlagAssignment -> [(FlagName, Bool)] -unFlagAssignment = fmap (fmap snd) . Map.toList . getFlagAssignment - --- | Test whether 'FlagAssignment' is empty. --- --- @since 2.2.0 -nullFlagAssignment :: FlagAssignment -> Bool -nullFlagAssignment = Map.null . getFlagAssignment - --- | Lookup the value for a flag --- --- Returns 'Nothing' if the flag isn't contained in the 'FlagAssignment'. --- --- @since 2.2.0 -lookupFlagAssignment :: FlagName -> FlagAssignment -> Maybe Bool -lookupFlagAssignment fn = fmap snd . Map.lookup fn . getFlagAssignment - --- | Insert or update the boolean value of a flag. --- --- If the flag is already present in the 'FlagAssigment', the --- value will be updated and the fact that multiple values have --- been provided for that flag will be recorded so that a --- warning can be generated later on. --- --- @since 2.2.0 -insertFlagAssignment :: FlagName -> Bool -> FlagAssignment -> FlagAssignment --- TODO: this currently just shadows prior values for an existing --- flag; rather than enforcing uniqueness at construction, it's --- verified later on via `D.C.Dependency.configuredPackageProblems` -insertFlagAssignment flag val = - FlagAssignment . - Map.insertWith (flip combineFlagValues) flag (1, val) . getFlagAssignment - --- | Remove all flag-assignments from the first 'FlagAssignment' that --- are contained in the second 'FlagAssignment' --- --- NB/TODO: This currently only removes flag assignments which also --- match the value assignment! We should review the code which uses --- this operation to figure out if this it's not enough to only --- compare the flagnames without the values. --- --- @since 2.2.0 -diffFlagAssignment :: FlagAssignment -> FlagAssignment -> FlagAssignment -diffFlagAssignment fa1 fa2 = FlagAssignment - (Map.difference (getFlagAssignment fa1) (getFlagAssignment fa2)) - --- | Find the 'FlagName's that have been listed more than once. --- --- @since 2.2.0 -findDuplicateFlagAssignments :: FlagAssignment -> [FlagName] -findDuplicateFlagAssignments = - Map.keys . Map.filter ((> 1) . fst) . getFlagAssignment - --- | @since 2.2.0 -instance Read FlagAssignment where - readsPrec p s = [ (FlagAssignment x, rest) | (x,rest) <- readsPrec p s ] - --- | @since 2.2.0 -instance Show FlagAssignment where - showsPrec p (FlagAssignment xs) = showsPrec p xs - --- | String representation of a flag-value pair. -showFlagValue :: (FlagName, Bool) -> String -showFlagValue (f, True) = '+' : unFlagName f -showFlagValue (f, False) = '-' : unFlagName f - --- | @since 3.4.0.0 -instance Pretty FlagAssignment where - pretty = dispFlagAssignment - --- | --- --- >>> simpleParsec "" :: Maybe FlagAssignment --- Just (fromList []) --- --- >>> simpleParsec "+foo -bar" :: Maybe FlagAssignment --- Just (fromList [(FlagName "bar",(1,False)),(FlagName "foo",(1,True))]) --- --- >>> simpleParsec "-none -any" :: Maybe FlagAssignment --- Just (fromList [(FlagName "any",(1,False)),(FlagName "none",(1,False))]) --- --- >>> simpleParsec "+foo -foo +foo +foo" :: Maybe FlagAssignment --- Just (fromList [(FlagName "foo",(4,True))]) --- --- >>> simpleParsec "+foo -bar baz" :: Maybe FlagAssignment --- Nothing --- --- @since 3.4.0.0 --- -instance Parsec FlagAssignment where - parsec = parsecFlagAssignment - --- | Pretty-prints a flag assignment. -dispFlagAssignment :: FlagAssignment -> Disp.Doc -dispFlagAssignment = Disp.hsep . map (Disp.text . showFlagValue) . unFlagAssignment - --- | Parses a flag assignment. -parsecFlagAssignment :: CabalParsing m => m FlagAssignment -parsecFlagAssignment = mkFlagAssignment <$> - P.sepBy (onFlag <|> offFlag) P.skipSpaces1 - where - onFlag = do - _ <- P.char '+' - f <- parsec - return (f, True) - offFlag = do - _ <- P.char '-' - f <- parsec - return (f, False) - --- | Parse a non-empty flag assignment --- --- The flags have to explicitly start with minus or plus. --- --- @since 3.4.0.0 -parsecFlagAssignmentNonEmpty :: CabalParsing m => m FlagAssignment -parsecFlagAssignmentNonEmpty = mkFlagAssignment . toList <$> - P.sepByNonEmpty (onFlag <|> offFlag) P.skipSpaces1 - where - onFlag = do - _ <- P.char '+' - f <- parsec - return (f, True) - offFlag = do - _ <- P.char '-' - f <- parsec - return (f, False) - --- | Show flag assignment. --- --- @since 3.4.0.0 -showFlagAssignment :: FlagAssignment -> String -showFlagAssignment = prettyShow . dispFlagAssignment - -------------------------------------------------------------------------------- --- Legacy: without requiring + -------------------------------------------------------------------------------- - --- | We need this as far as we support custom setups older than 2.2.0.0 --- --- @since 3.4.0.0 -legacyShowFlagAssignment :: FlagAssignment -> String -legacyShowFlagAssignment = - prettyShow . Disp.hsep . map Disp.text . legacyShowFlagAssignment' - --- | @since 3.4.0.0 -legacyShowFlagAssignment' :: FlagAssignment -> [String] -legacyShowFlagAssignment' = map legacyShowFlagValue . unFlagAssignment - --- | @since 3.4.0.0 -legacyShowFlagValue :: (FlagName, Bool) -> String -legacyShowFlagValue (f, True) = unFlagName f -legacyShowFlagValue (f, False) = '-' : unFlagName f - --- | --- We need this as far as we support custom setups older than 2.2.0.0 --- --- @since 3.4.0.0 -legacyParsecFlagAssignment :: CabalParsing m => m FlagAssignment -legacyParsecFlagAssignment = mkFlagAssignment <$> - P.sepBy (onFlag <|> offFlag) P.skipSpaces1 - where - onFlag = do - _ <- P.optional (P.char '+') - f <- parsec - return (f, True) - offFlag = do - _ <- P.char '-' - f <- parsec - return (f, False) diff --git a/src/Distribution/Types/ForeignLib.hs b/src/Distribution/Types/ForeignLib.hs deleted file mode 100644 --- a/src/Distribution/Types/ForeignLib.hs +++ /dev/null @@ -1,199 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} - -module Distribution.Types.ForeignLib( - ForeignLib(..), - emptyForeignLib, - foreignLibModules, - foreignLibIsShared, - foreignLibVersion, - - LibVersionInfo, - mkLibVersionInfo, - libVersionInfoCRA, - libVersionNumber, - libVersionNumberShow, - libVersionMajor -) where - -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.ModuleName -import Distribution.Parsec -import Distribution.Pretty -import Distribution.System -import Distribution.Types.BuildInfo -import Distribution.Types.ForeignLibOption -import Distribution.Types.ForeignLibType -import Distribution.Types.UnqualComponentName -import Distribution.Version - -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp -import qualified Text.Read as Read - -import qualified Distribution.Types.BuildInfo.Lens as L - --- | A foreign library stanza is like a library stanza, except that --- the built code is intended for consumption by a non-Haskell client. -data ForeignLib = ForeignLib { - -- | Name of the foreign library - foreignLibName :: UnqualComponentName - -- | What kind of foreign library is this (static or dynamic). - , foreignLibType :: ForeignLibType - -- | What options apply to this foreign library (e.g., are we - -- merging in all foreign dependencies.) - , foreignLibOptions :: [ForeignLibOption] - -- | Build information for this foreign library. - , foreignLibBuildInfo :: BuildInfo - -- | Libtool-style version-info data to compute library version. - -- Refer to the libtool documentation on the - -- current:revision:age versioning scheme. - , foreignLibVersionInfo :: Maybe LibVersionInfo - -- | Linux library version - , foreignLibVersionLinux :: Maybe Version - - -- | (Windows-specific) module definition files - -- - -- This is a list rather than a maybe field so that we can flatten - -- the condition trees (for instance, when creating an sdist) - , foreignLibModDefFile :: [FilePath] - } - deriving (Generic, Show, Read, Eq, Typeable, Data) - -data LibVersionInfo = LibVersionInfo Int Int Int deriving (Data, Eq, Generic, Typeable) - -instance Ord LibVersionInfo where - LibVersionInfo c r _ `compare` LibVersionInfo c' r' _ = - case c `compare` c' of - EQ -> r `compare` r' - e -> e - -instance Show LibVersionInfo where - showsPrec d (LibVersionInfo c r a) = showParen (d > 10) - $ showString "mkLibVersionInfo " - . showsPrec 11 (c,r,a) - -instance Read LibVersionInfo where - readPrec = Read.parens $ do - Read.Ident "mkLibVersionInfo" <- Read.lexP - t <- Read.step Read.readPrec - return (mkLibVersionInfo t) - -instance Binary LibVersionInfo -instance Structured LibVersionInfo -instance NFData LibVersionInfo where rnf = genericRnf - -instance Pretty LibVersionInfo where - pretty (LibVersionInfo c r a) - = Disp.hcat $ Disp.punctuate (Disp.char ':') $ map Disp.int [c,r,a] - -instance Parsec LibVersionInfo where - parsec = do - c <- P.integral - (r, a) <- P.option (0,0) $ do - _ <- P.char ':' - r <- P.integral - a <- P.option 0 $ do - _ <- P.char ':' - P.integral - return (r,a) - return $ mkLibVersionInfo (c,r,a) - --- | Construct 'LibVersionInfo' from @(current, revision, age)@ --- numbers. --- --- For instance, @mkLibVersionInfo (3,0,0)@ constructs a --- 'LibVersionInfo' representing the version-info @3:0:0@. --- --- All version components must be non-negative. -mkLibVersionInfo :: (Int, Int, Int) -> LibVersionInfo -mkLibVersionInfo (c,r,a) = LibVersionInfo c r a - --- | From a given 'LibVersionInfo', extract the @(current, revision, --- age)@ numbers. -libVersionInfoCRA :: LibVersionInfo -> (Int, Int, Int) -libVersionInfoCRA (LibVersionInfo c r a) = (c,r,a) - --- | Given a version-info field, produce a @major.minor.build@ version -libVersionNumber :: LibVersionInfo -> (Int, Int, Int) -libVersionNumber (LibVersionInfo c r a) = (c-a , a , r) - --- | Given a version-info field, return @"major.minor.build"@ as a --- 'String' -libVersionNumberShow :: LibVersionInfo -> String -libVersionNumberShow v = - let (major, minor, build) = libVersionNumber v - in show major ++ "." ++ show minor ++ "." ++ show build - --- | Return the @major@ version of a version-info field. -libVersionMajor :: LibVersionInfo -> Int -libVersionMajor (LibVersionInfo c _ a) = c-a - -instance L.HasBuildInfo ForeignLib where - buildInfo f l = (\x -> l { foreignLibBuildInfo = x }) <$> f (foreignLibBuildInfo l) - -instance Binary ForeignLib -instance Structured ForeignLib -instance NFData ForeignLib where rnf = genericRnf - -instance Semigroup ForeignLib where - a <> b = ForeignLib { - foreignLibName = combine' foreignLibName - , foreignLibType = combine foreignLibType - , foreignLibOptions = combine foreignLibOptions - , foreignLibBuildInfo = combine foreignLibBuildInfo - , foreignLibVersionInfo = combine'' foreignLibVersionInfo - , foreignLibVersionLinux = combine'' foreignLibVersionLinux - , foreignLibModDefFile = combine foreignLibModDefFile - } - where combine field = field a `mappend` field b - combine' field = case ( unUnqualComponentName $ field a - , unUnqualComponentName $ field b) of - ("", _) -> field b - (_, "") -> field a - (x, y) -> error $ "Ambiguous values for executable field: '" - ++ x ++ "' and '" ++ y ++ "'" - combine'' field = field b - -instance Monoid ForeignLib where - mempty = ForeignLib { - foreignLibName = mempty - , foreignLibType = ForeignLibTypeUnknown - , foreignLibOptions = [] - , foreignLibBuildInfo = mempty - , foreignLibVersionInfo = Nothing - , foreignLibVersionLinux = Nothing - , foreignLibModDefFile = [] - } - mappend = (<>) - --- | An empty foreign library. -emptyForeignLib :: ForeignLib -emptyForeignLib = mempty - --- | Modules defined by a foreign library. -foreignLibModules :: ForeignLib -> [ModuleName] -foreignLibModules = otherModules . foreignLibBuildInfo - --- | Is the foreign library shared? -foreignLibIsShared :: ForeignLib -> Bool -foreignLibIsShared = foreignLibTypeIsShared . foreignLibType - --- | Get a version number for a foreign library. --- If we're on Linux, and a Linux version is specified, use that. --- If we're on Linux, and libtool-style version-info is specified, translate --- that field into appropriate version numbers. --- Otherwise, this feature is unsupported so we don't return any version data. -foreignLibVersion :: ForeignLib -> OS -> [Int] -foreignLibVersion flib Linux = - case foreignLibVersionLinux flib of - Just v -> versionNumbers v - Nothing -> - case foreignLibVersionInfo flib of - Just v' -> - let (major, minor, build) = libVersionNumber v' - in [major, minor, build] - Nothing -> [] -foreignLibVersion _ _ = [] diff --git a/src/Distribution/Types/ForeignLib/Lens.hs b/src/Distribution/Types/ForeignLib/Lens.hs deleted file mode 100644 --- a/src/Distribution/Types/ForeignLib/Lens.hs +++ /dev/null @@ -1,45 +0,0 @@ -module Distribution.Types.ForeignLib.Lens ( - ForeignLib, - module Distribution.Types.ForeignLib.Lens, - ) where - -import Distribution.Compat.Lens -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Types.BuildInfo (BuildInfo) -import Distribution.Types.ForeignLib (ForeignLib, LibVersionInfo) -import Distribution.Types.ForeignLibOption (ForeignLibOption) -import Distribution.Types.ForeignLibType (ForeignLibType) -import Distribution.Types.UnqualComponentName (UnqualComponentName) -import Distribution.Version (Version) - -import qualified Distribution.Types.ForeignLib as T - -foreignLibName :: Lens' ForeignLib UnqualComponentName -foreignLibName f s = fmap (\x -> s { T.foreignLibName = x }) (f (T.foreignLibName s)) -{-# INLINE foreignLibName #-} - -foreignLibType :: Lens' ForeignLib ForeignLibType -foreignLibType f s = fmap (\x -> s { T.foreignLibType = x }) (f (T.foreignLibType s)) -{-# INLINE foreignLibType #-} - -foreignLibOptions :: Lens' ForeignLib [ForeignLibOption] -foreignLibOptions f s = fmap (\x -> s { T.foreignLibOptions = x }) (f (T.foreignLibOptions s)) -{-# INLINE foreignLibOptions #-} - -foreignLibBuildInfo :: Lens' ForeignLib BuildInfo -foreignLibBuildInfo f s = fmap (\x -> s { T.foreignLibBuildInfo = x }) (f (T.foreignLibBuildInfo s)) -{-# INLINE foreignLibBuildInfo #-} - -foreignLibVersionInfo :: Lens' ForeignLib (Maybe LibVersionInfo) -foreignLibVersionInfo f s = fmap (\x -> s { T.foreignLibVersionInfo = x }) (f (T.foreignLibVersionInfo s)) -{-# INLINE foreignLibVersionInfo #-} - -foreignLibVersionLinux :: Lens' ForeignLib (Maybe Version) -foreignLibVersionLinux f s = fmap (\x -> s { T.foreignLibVersionLinux = x }) (f (T.foreignLibVersionLinux s)) -{-# INLINE foreignLibVersionLinux #-} - -foreignLibModDefFile :: Lens' ForeignLib [FilePath] -foreignLibModDefFile f s = fmap (\x -> s { T.foreignLibModDefFile = x }) (f (T.foreignLibModDefFile s)) -{-# INLINE foreignLibModDefFile #-} diff --git a/src/Distribution/Types/ForeignLibOption.hs b/src/Distribution/Types/ForeignLibOption.hs deleted file mode 100644 --- a/src/Distribution/Types/ForeignLibOption.hs +++ /dev/null @@ -1,39 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} - -module Distribution.Types.ForeignLibOption( - ForeignLibOption(..) -) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Pretty -import Distribution.Parsec - -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp - -data ForeignLibOption = - -- | Merge in all dependent libraries (i.e., use - -- @ghc -shared -static@ rather than just record - -- the dependencies, ala @ghc -shared -dynamic@). - -- This option is compulsory on Windows and unsupported - -- on other platforms. - ForeignLibStandalone - deriving (Generic, Show, Read, Eq, Typeable, Data) - -instance Pretty ForeignLibOption where - pretty ForeignLibStandalone = Disp.text "standalone" - -instance Parsec ForeignLibOption where - parsec = do - name <- P.munch1 (\c -> isAlphaNum c || c == '-') - case name of - "standalone" -> return ForeignLibStandalone - _ -> fail "unrecognized foreign-library option" - -instance Binary ForeignLibOption -instance Structured ForeignLibOption -instance NFData ForeignLibOption where rnf = genericRnf diff --git a/src/Distribution/Types/ForeignLibType.hs b/src/Distribution/Types/ForeignLibType.hs deleted file mode 100644 --- a/src/Distribution/Types/ForeignLibType.hs +++ /dev/null @@ -1,69 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} - -module Distribution.Types.ForeignLibType( - ForeignLibType(..), - knownForeignLibTypes, - foreignLibTypeIsShared, -) where - -import Prelude () -import Distribution.Compat.Prelude -import Distribution.PackageDescription.Utils - -import Distribution.Pretty -import Distribution.Parsec - -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp - --- | What kind of foreign library is to be built? -data ForeignLibType = - -- | A native shared library (@.so@ on Linux, @.dylib@ on OSX, or - -- @.dll@ on Windows). - ForeignLibNativeShared - -- | A native static library (not currently supported.) - | ForeignLibNativeStatic - -- TODO: Maybe this should record a string? - | ForeignLibTypeUnknown - deriving (Generic, Show, Read, Eq, Typeable, Data) - -instance Pretty ForeignLibType where - pretty ForeignLibNativeShared = Disp.text "native-shared" - pretty ForeignLibNativeStatic = Disp.text "native-static" - pretty ForeignLibTypeUnknown = Disp.text "unknown" - -instance Parsec ForeignLibType where - parsec = do - name <- P.munch1 (\c -> isAlphaNum c || c == '-') - return $ case name of - "native-shared" -> ForeignLibNativeShared - "native-static" -> ForeignLibNativeStatic - _ -> ForeignLibTypeUnknown - -instance Binary ForeignLibType -instance Structured ForeignLibType -instance NFData ForeignLibType where rnf = genericRnf - -instance Semigroup ForeignLibType where - ForeignLibTypeUnknown <> b = b - a <> ForeignLibTypeUnknown = a - _ <> _ = error "Ambiguous foreign library type" - -instance Monoid ForeignLibType where - mempty = ForeignLibTypeUnknown - mappend = (<>) - -knownForeignLibTypes :: [ForeignLibType] -knownForeignLibTypes = [ - ForeignLibNativeShared - , ForeignLibNativeStatic - ] - -foreignLibTypeIsShared :: ForeignLibType -> Bool -foreignLibTypeIsShared t = - case t of - ForeignLibNativeShared -> True - ForeignLibNativeStatic -> False - ForeignLibTypeUnknown -> cabalBug "Unknown foreign library type" diff --git a/src/Distribution/Types/GenericPackageDescription.hs b/src/Distribution/Types/GenericPackageDescription.hs deleted file mode 100644 --- a/src/Distribution/Types/GenericPackageDescription.hs +++ /dev/null @@ -1,105 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Distribution.Types.GenericPackageDescription ( - GenericPackageDescription(..), - emptyGenericPackageDescription, -) where - -import Prelude () -import Distribution.Compat.Prelude - --- lens -import Distribution.Compat.Lens as L -import qualified Distribution.Types.BuildInfo.Lens as L - -import Distribution.Types.PackageDescription - -import Distribution.Types.Benchmark -import Distribution.Types.CondTree -import Distribution.Types.ConfVar -import Distribution.Types.Dependency -import Distribution.Types.Executable -import Distribution.Types.Flag -import Distribution.Types.ForeignLib -import Distribution.Types.Library -import Distribution.Types.TestSuite -import Distribution.Types.UnqualComponentName -import Distribution.Package -import Distribution.Version - --- --------------------------------------------------------------------------- --- The 'GenericPackageDescription' type - -data GenericPackageDescription = - GenericPackageDescription - { packageDescription :: PackageDescription - , gpdScannedVersion :: Maybe Version - -- ^ This is a version as specified in source. - -- We populate this field in index reading for dummy GPDs, - -- only when GPD reading failed, but scanning haven't. - -- - -- Cabal-the-library never produces GPDs with Just as gpdScannedVersion. - -- - -- Perfectly, PackageIndex should have sum type, so we don't need to - -- have dummy GPDs. - , genPackageFlags :: [PackageFlag] - , condLibrary :: Maybe (CondTree ConfVar [Dependency] Library) - , condSubLibraries :: [( UnqualComponentName - , CondTree ConfVar [Dependency] Library )] - , condForeignLibs :: [( UnqualComponentName - , CondTree ConfVar [Dependency] ForeignLib )] - , condExecutables :: [( UnqualComponentName - , CondTree ConfVar [Dependency] Executable )] - , condTestSuites :: [( UnqualComponentName - , CondTree ConfVar [Dependency] TestSuite )] - , condBenchmarks :: [( UnqualComponentName - , CondTree ConfVar [Dependency] Benchmark )] - } - deriving (Show, Eq, Typeable, Data, Generic) - -instance Package GenericPackageDescription where - packageId = packageId . packageDescription - -instance Binary GenericPackageDescription -instance Structured GenericPackageDescription -instance NFData GenericPackageDescription where rnf = genericRnf - -emptyGenericPackageDescription :: GenericPackageDescription -emptyGenericPackageDescription = GenericPackageDescription emptyPackageDescription Nothing [] Nothing [] [] [] [] [] - --- ----------------------------------------------------------------------------- --- Traversal Instances - -instance L.HasBuildInfos GenericPackageDescription where - traverseBuildInfos f (GenericPackageDescription p v a1 x1 x2 x3 x4 x5 x6) = - GenericPackageDescription - <$> L.traverseBuildInfos f p - <*> pure v - <*> pure a1 - <*> (traverse . traverseCondTreeBuildInfo) f x1 - <*> (traverse . L._2 . traverseCondTreeBuildInfo) f x2 - <*> (traverse . L._2 . traverseCondTreeBuildInfo) f x3 - <*> (traverse . L._2 . traverseCondTreeBuildInfo) f x4 - <*> (traverse . L._2 . traverseCondTreeBuildInfo) f x5 - <*> (traverse . L._2 . traverseCondTreeBuildInfo) f x6 - where - --- We use this traversal to keep [Dependency] field in CondTree up to date. -traverseCondTreeBuildInfo - :: forall f comp v. (Applicative f, L.HasBuildInfo comp) - => LensLike' f (CondTree v [Dependency] comp) L.BuildInfo -traverseCondTreeBuildInfo g = node where - mkCondNode :: comp -> [CondBranch v [Dependency] comp] -> CondTree v [Dependency] comp - mkCondNode comp branches = CondNode comp (view L.targetBuildDepends comp) branches - - node (CondNode comp _ branches) = mkCondNode - <$> L.buildInfo g comp - <*> traverse branch branches - - branch (CondBranch v x y) = CondBranch v - <$> node x - <*> traverse node y diff --git a/src/Distribution/Types/GenericPackageDescription/Lens.hs b/src/Distribution/Types/GenericPackageDescription/Lens.hs deleted file mode 100644 --- a/src/Distribution/Types/GenericPackageDescription/Lens.hs +++ /dev/null @@ -1,131 +0,0 @@ -{-# LANGUAGE Rank2Types #-} -module Distribution.Types.GenericPackageDescription.Lens ( - GenericPackageDescription, - PackageFlag, - FlagName, - ConfVar (..), - module Distribution.Types.GenericPackageDescription.Lens, - ) where - -import Prelude() -import Distribution.Compat.Prelude -import Distribution.Compat.Lens - -import qualified Distribution.Types.GenericPackageDescription as T - --- We import types from their packages, so we can remove unused imports --- and have wider inter-module dependency graph -import Distribution.Types.CondTree (CondTree) -import Distribution.Types.Dependency (Dependency) -import Distribution.Types.Executable (Executable) -import Distribution.Types.PackageDescription (PackageDescription) -import Distribution.Types.Benchmark (Benchmark) -import Distribution.Types.ForeignLib (ForeignLib) -import Distribution.Types.GenericPackageDescription (GenericPackageDescription(GenericPackageDescription) ) -import Distribution.Types.Flag (PackageFlag(MkPackageFlag), FlagName) -import Distribution.Types.ConfVar (ConfVar (..)) -import Distribution.Types.Library (Library) -import Distribution.Types.TestSuite (TestSuite) -import Distribution.Types.UnqualComponentName (UnqualComponentName) -import Distribution.System (Arch, OS) -import Distribution.Compiler (CompilerFlavor) -import Distribution.Version (Version, VersionRange) - -------------------------------------------------------------------------------- --- GenericPackageDescription -------------------------------------------------------------------------------- - -packageDescription :: Lens' GenericPackageDescription PackageDescription -packageDescription f s = fmap (\x -> s { T.packageDescription = x }) (f (T.packageDescription s)) -{-# INLINE packageDescription #-} - -gpdScannedVersion :: Lens' GenericPackageDescription (Maybe Version) -gpdScannedVersion f s = fmap (\x -> s { T.gpdScannedVersion = x }) (f (T.gpdScannedVersion s)) -{-# INLINE gpdScannedVersion #-} - -genPackageFlags :: Lens' GenericPackageDescription [PackageFlag] -genPackageFlags f s = fmap (\x -> s { T.genPackageFlags = x }) (f (T.genPackageFlags s)) -{-# INLINE genPackageFlags #-} - -condLibrary :: Lens' GenericPackageDescription (Maybe (CondTree ConfVar [Dependency] Library)) -condLibrary f s = fmap (\x -> s { T.condLibrary = x }) (f (T.condLibrary s)) -{-# INLINE condLibrary #-} - -condSubLibraries :: Lens' GenericPackageDescription [(UnqualComponentName,(CondTree ConfVar [Dependency] Library))] -condSubLibraries f s = fmap (\x -> s { T.condSubLibraries = x }) (f (T.condSubLibraries s)) -{-# INLINE condSubLibraries #-} - -condForeignLibs :: Lens' GenericPackageDescription [(UnqualComponentName,(CondTree ConfVar [Dependency] ForeignLib))] -condForeignLibs f s = fmap (\x -> s { T.condForeignLibs = x }) (f (T.condForeignLibs s)) -{-# INLINE condForeignLibs #-} - -condExecutables :: Lens' GenericPackageDescription [(UnqualComponentName,(CondTree ConfVar [Dependency] Executable))] -condExecutables f s = fmap (\x -> s { T.condExecutables = x }) (f (T.condExecutables s)) -{-# INLINE condExecutables #-} - -condTestSuites :: Lens' GenericPackageDescription [(UnqualComponentName,(CondTree ConfVar [Dependency] TestSuite))] -condTestSuites f s = fmap (\x -> s { T.condTestSuites = x }) (f (T.condTestSuites s)) -{-# INLINE condTestSuites #-} - -condBenchmarks :: Lens' GenericPackageDescription [(UnqualComponentName,(CondTree ConfVar [Dependency] Benchmark))] -condBenchmarks f s = fmap (\x -> s { T.condBenchmarks = x }) (f (T.condBenchmarks s)) -{-# INLINE condBenchmarks #-} - -allCondTrees - :: Applicative f - => (forall a. CondTree ConfVar [Dependency] a - -> f (CondTree ConfVar [Dependency] a)) - -> GenericPackageDescription - -> f GenericPackageDescription -allCondTrees f (GenericPackageDescription p v a1 x1 x2 x3 x4 x5 x6) = - GenericPackageDescription - <$> pure p - <*> pure v - <*> pure a1 - <*> traverse f x1 - <*> (traverse . _2) f x2 - <*> (traverse . _2) f x3 - <*> (traverse . _2) f x4 - <*> (traverse . _2) f x5 - <*> (traverse . _2) f x6 - - -------------------------------------------------------------------------------- --- Flag -------------------------------------------------------------------------------- - -flagName :: Lens' PackageFlag FlagName -flagName f (MkPackageFlag x1 x2 x3 x4) = fmap (\y1 -> MkPackageFlag y1 x2 x3 x4) (f x1) -{-# INLINE flagName #-} - -flagDescription :: Lens' PackageFlag String -flagDescription f (MkPackageFlag x1 x2 x3 x4) = fmap (\y1 -> MkPackageFlag x1 y1 x3 x4) (f x2) -{-# INLINE flagDescription #-} - -flagDefault :: Lens' PackageFlag Bool -flagDefault f (MkPackageFlag x1 x2 x3 x4) = fmap (\y1 -> MkPackageFlag x1 x2 y1 x4) (f x3) -{-# INLINE flagDefault #-} - -flagManual :: Lens' PackageFlag Bool -flagManual f (MkPackageFlag x1 x2 x3 x4) = fmap (\y1 -> MkPackageFlag x1 x2 x3 y1) (f x4) -{-# INLINE flagManual #-} - -------------------------------------------------------------------------------- --- ConfVar -------------------------------------------------------------------------------- - -_OS :: Traversal' ConfVar OS -_OS f (OS os) = OS <$> f os -_OS _ x = pure x - -_Arch :: Traversal' ConfVar Arch -_Arch f (Arch arch) = Arch <$> f arch -_Arch _ x = pure x - -_PackageFlag :: Traversal' ConfVar FlagName -_PackageFlag f (PackageFlag flag) = PackageFlag <$> f flag -_PackageFlag _ x = pure x - -_Impl :: Traversal' ConfVar (CompilerFlavor, VersionRange) -_Impl f (Impl cf vr) = uncurry Impl <$> f (cf, vr) -_Impl _ x = pure x diff --git a/src/Distribution/Types/HookedBuildInfo.hs b/src/Distribution/Types/HookedBuildInfo.hs deleted file mode 100644 --- a/src/Distribution/Types/HookedBuildInfo.hs +++ /dev/null @@ -1,66 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} - -module Distribution.Types.HookedBuildInfo ( - HookedBuildInfo, - emptyHookedBuildInfo, - ) where - --- import Distribution.Compat.Prelude -import Distribution.Types.BuildInfo -import Distribution.Types.UnqualComponentName - --- | 'HookedBuildInfo' is mechanism that hooks can use to --- override the 'BuildInfo's inside packages. One example --- use-case (which is used in core libraries today) is as --- a way of passing flags which are computed by a configure --- script into Cabal. In this case, the autoconf build type adds --- hooks to read in a textual 'HookedBuildInfo' format prior --- to doing any operations. --- --- Quite honestly, this mechanism is a massive hack since we shouldn't --- be editing the 'PackageDescription' data structure (it's easy --- to assume that this data structure shouldn't change and --- run into bugs, see for example 1c20a6328579af9e37677d507e2e9836ef70ab9d). --- But it's a bit convenient, because there isn't another data --- structure that allows adding extra 'BuildInfo' style things. --- --- In any case, a lot of care has to be taken to make sure the --- 'HookedBuildInfo' is applied to the 'PackageDescription'. In --- general this process occurs in "Distribution.Simple", which is --- responsible for orchestrating the hooks mechanism. The --- general strategy: --- --- 1. We run the pre-hook, which produces a 'HookedBuildInfo' --- (e.g., in the Autoconf case, it reads it out from a file). --- 2. We sanity-check the hooked build info with --- 'sanityCheckHookedBuildInfo'. --- 3. We update our 'PackageDescription' (either freshly read --- or cached from 'LocalBuildInfo') with 'updatePackageDescription'. --- --- In principle, we are also supposed to update the copy of --- the 'PackageDescription' stored in 'LocalBuildInfo' --- at 'localPkgDescr'. Unfortunately, in practice, there --- are lots of Custom setup scripts which fail to update --- 'localPkgDescr' so you really shouldn't rely on it. --- It's not DEPRECATED because there are legitimate uses --- for it, but... yeah. Sharp knife. See --- --- for more information on the issue. --- --- It is not well-specified whether or not a 'HookedBuildInfo' applied --- at configure time is persistent to the 'LocalBuildInfo'. The --- fact that 'HookedBuildInfo' is passed to 'confHook' MIGHT SUGGEST --- that the 'HookedBuildInfo' is applied at this time, but actually --- since 9317b67e6122ab14e53f81b573bd0ecb388eca5a it has been ONLY used --- to create a modified package description that we check for problems: --- it is never actually saved to the LBI. Since 'HookedBuildInfo' is --- applied monoidally to the existing build infos (and it is not an --- idempotent monoid), it could break things to save it, since we --- are obligated to apply any new 'HookedBuildInfo' and then we'd --- get the effect twice. But this does mean we have to re-apply --- it every time. Hey, it's more flexibility. -type HookedBuildInfo = (Maybe BuildInfo, [(UnqualComponentName, BuildInfo)]) - -emptyHookedBuildInfo :: HookedBuildInfo -emptyHookedBuildInfo = (Nothing, []) diff --git a/src/Distribution/Types/IncludeRenaming.hs b/src/Distribution/Types/IncludeRenaming.hs deleted file mode 100644 --- a/src/Distribution/Types/IncludeRenaming.hs +++ /dev/null @@ -1,68 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} - -module Distribution.Types.IncludeRenaming ( - IncludeRenaming(..), - defaultIncludeRenaming, - isDefaultIncludeRenaming, -) where - -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Types.ModuleRenaming - -import qualified Distribution.Compat.CharParsing as P -import Distribution.Parsec -import Distribution.Pretty -import Text.PrettyPrint (text) -import qualified Text.PrettyPrint as Disp - --- --------------------------------------------------------------------------- --- Module renaming - --- | A renaming on an include: (provides renaming, requires renaming) -data IncludeRenaming - = IncludeRenaming { - includeProvidesRn :: ModuleRenaming, - includeRequiresRn :: ModuleRenaming - } - deriving (Show, Read, Eq, Ord, Typeable, Data, Generic) - -instance Binary IncludeRenaming -instance Structured IncludeRenaming - -instance NFData IncludeRenaming where rnf = genericRnf - --- | The 'defaultIncludeRenaming' applied when you only @build-depends@ --- on a package. -defaultIncludeRenaming :: IncludeRenaming -defaultIncludeRenaming = IncludeRenaming defaultRenaming defaultRenaming - --- | Is an 'IncludeRenaming' the default one? -isDefaultIncludeRenaming :: IncludeRenaming -> Bool -isDefaultIncludeRenaming (IncludeRenaming p r) = isDefaultRenaming p && isDefaultRenaming r - -instance Pretty IncludeRenaming where - pretty (IncludeRenaming prov_rn req_rn) = - pretty prov_rn - <+> (if isDefaultRenaming req_rn - then Disp.empty - else text "requires" <+> pretty req_rn) - -instance Parsec IncludeRenaming where - parsec = do - prov_rn <- parsec - req_rn <- P.option defaultRenaming $ P.try $ do - P.spaces -- no need to be space - _ <- P.string "requires" - P.spaces - parsec - -- Requirements don't really care if they're mentioned - -- or not (since you can't thin a requirement.) But - -- we have a little hack in Configure to combine - -- the provisions and requirements together before passing - -- them to GHC, and so the most neutral choice for a requirement - -- is for the "with" field to be False, so we correctly - -- thin provisions. - return (IncludeRenaming prov_rn req_rn) diff --git a/src/Distribution/Types/InstalledPackageInfo.hs b/src/Distribution/Types/InstalledPackageInfo.hs deleted file mode 100644 --- a/src/Distribution/Types/InstalledPackageInfo.hs +++ /dev/null @@ -1,173 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE OverloadedStrings #-} -module Distribution.Types.InstalledPackageInfo ( - InstalledPackageInfo (..), - emptyInstalledPackageInfo, - mungedPackageId, - mungedPackageName, - AbiDependency (..), - ExposedModule (..), - ) where - -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Backpack -import Distribution.Compat.Graph (IsNode (..)) -import Distribution.License -import Distribution.ModuleName -import Distribution.Package hiding (installedUnitId) -import Distribution.Types.AbiDependency -import Distribution.Types.ExposedModule -import Distribution.Types.LibraryName -import Distribution.Types.LibraryVisibility -import Distribution.Types.MungedPackageId -import Distribution.Types.MungedPackageName -import Distribution.Version (nullVersion) -import Distribution.Utils.ShortText (ShortText) - -import qualified Distribution.Package as Package -import qualified Distribution.SPDX as SPDX - --- ----------------------------------------------------------------------------- --- The InstalledPackageInfo type - --- For BC reasons, we continue to name this record an InstalledPackageInfo; --- but it would more accurately be called an InstalledUnitInfo with Backpack -data InstalledPackageInfo - = InstalledPackageInfo { - -- these parts (sourcePackageId, installedUnitId) are - -- exactly the same as PackageDescription - sourcePackageId :: PackageId, - sourceLibName :: LibraryName, - installedComponentId_ :: ComponentId, - libVisibility :: LibraryVisibility, - installedUnitId :: UnitId, - -- INVARIANT: if this package is definite, OpenModule's - -- OpenUnitId directly records UnitId. If it is - -- indefinite, OpenModule is always an OpenModuleVar - -- with the same ModuleName as the key. - instantiatedWith :: [(ModuleName, OpenModule)], - compatPackageKey :: String, - license :: Either SPDX.License License, - copyright :: !ShortText, - maintainer :: !ShortText, - author :: !ShortText, - stability :: !ShortText, - homepage :: !ShortText, - pkgUrl :: !ShortText, - synopsis :: !ShortText, - description :: !ShortText, - category :: !ShortText, - -- these parts are required by an installed package only: - abiHash :: AbiHash, - indefinite :: Bool, - exposed :: Bool, - -- INVARIANT: if the package is definite, OpenModule's - -- OpenUnitId directly records UnitId. - exposedModules :: [ExposedModule], - hiddenModules :: [ModuleName], - trusted :: Bool, - importDirs :: [FilePath], - libraryDirs :: [FilePath], - libraryDynDirs :: [FilePath], -- ^ overrides 'libraryDirs' - dataDir :: FilePath, - hsLibraries :: [String], - extraLibraries :: [String], - extraGHCiLibraries:: [String], -- overrides extraLibraries for GHCi - includeDirs :: [FilePath], - includes :: [String], - -- INVARIANT: if the package is definite, UnitId is NOT - -- a ComponentId of an indefinite package - depends :: [UnitId], - abiDepends :: [AbiDependency], - ccOptions :: [String], - cxxOptions :: [String], - ldOptions :: [String], - frameworkDirs :: [FilePath], - frameworks :: [String], - haddockInterfaces :: [FilePath], - haddockHTMLs :: [FilePath], - pkgRoot :: Maybe FilePath - } - deriving (Eq, Generic, Typeable, Read, Show) - -instance Binary InstalledPackageInfo -instance Structured InstalledPackageInfo - -instance NFData InstalledPackageInfo where rnf = genericRnf - -instance Package.HasMungedPackageId InstalledPackageInfo where - mungedId = mungedPackageId - -instance Package.Package InstalledPackageInfo where - packageId = sourcePackageId - -instance Package.HasUnitId InstalledPackageInfo where - installedUnitId = installedUnitId - -instance Package.PackageInstalled InstalledPackageInfo where - installedDepends = depends - -instance IsNode InstalledPackageInfo where - type Key InstalledPackageInfo = UnitId - nodeKey = installedUnitId - nodeNeighbors = depends - -mungedPackageId :: InstalledPackageInfo -> MungedPackageId -mungedPackageId ipi = - MungedPackageId (mungedPackageName ipi) (packageVersion ipi) - --- | Returns the munged package name, which we write into @name@ for --- compatibility with old versions of GHC. -mungedPackageName :: InstalledPackageInfo -> MungedPackageName -mungedPackageName ipi = MungedPackageName (packageName ipi) (sourceLibName ipi) - -emptyInstalledPackageInfo :: InstalledPackageInfo -emptyInstalledPackageInfo - = InstalledPackageInfo { - sourcePackageId = PackageIdentifier (mkPackageName "") nullVersion, - sourceLibName = LMainLibName, - installedComponentId_ = mkComponentId "", - installedUnitId = mkUnitId "", - instantiatedWith = [], - compatPackageKey = "", - license = Left SPDX.NONE, - copyright = "", - maintainer = "", - author = "", - stability = "", - homepage = "", - pkgUrl = "", - synopsis = "", - description = "", - category = "", - abiHash = mkAbiHash "", - indefinite = False, - exposed = False, - exposedModules = [], - hiddenModules = [], - trusted = False, - importDirs = [], - libraryDirs = [], - libraryDynDirs = [], - dataDir = "", - hsLibraries = [], - extraLibraries = [], - extraGHCiLibraries= [], - includeDirs = [], - includes = [], - depends = [], - abiDepends = [], - ccOptions = [], - cxxOptions = [], - ldOptions = [], - frameworkDirs = [], - frameworks = [], - haddockInterfaces = [], - haddockHTMLs = [], - pkgRoot = Nothing, - libVisibility = LibraryVisibilityPrivate - } diff --git a/src/Distribution/Types/InstalledPackageInfo/FieldGrammar.hs b/src/Distribution/Types/InstalledPackageInfo/FieldGrammar.hs deleted file mode 100644 --- a/src/Distribution/Types/InstalledPackageInfo/FieldGrammar.hs +++ /dev/null @@ -1,317 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -module Distribution.Types.InstalledPackageInfo.FieldGrammar ( - ipiFieldGrammar, - ) where - -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Backpack -import Distribution.CabalSpecVersion -import Distribution.Compat.Lens (Lens', (&), (.~)) -import Distribution.Compat.Newtype -import Distribution.FieldGrammar -import Distribution.FieldGrammar.FieldDescrs -import Distribution.License -import Distribution.ModuleName -import Distribution.Package -import Distribution.Parsec -import Distribution.Pretty -import Distribution.Types.LibraryName -import Distribution.Types.LibraryVisibility -import Distribution.Types.MungedPackageName -import Distribution.Types.UnqualComponentName -import Distribution.Version - -import qualified Data.Char as Char -import qualified Data.Map as Map -import qualified Distribution.Compat.CharParsing as P -import qualified Distribution.SPDX as SPDX -import qualified Text.PrettyPrint as Disp - -import Distribution.Types.InstalledPackageInfo - -import qualified Distribution.Types.InstalledPackageInfo.Lens as L -import qualified Distribution.Types.PackageId.Lens as L - --- Note: GHC goes nuts and inlines everything, --- One can see e.g. in -ddump-simpl-stats: --- --- 34886 KnownBranch --- 8197 wild1_ixF0 --- --- https://gitlab.haskell.org/ghc/ghc/-/issues/13253 might be the cause. --- --- The workaround is to prevent GHC optimising the code: -infixl 4 <@> -(<@>) :: Applicative f => f (a -> b) -> f a -> f b -f <@> x = f <*> x -{-# NOINLINE (<@>) #-} - -ipiFieldGrammar - :: ( FieldGrammar c g, Applicative (g InstalledPackageInfo), Applicative (g Basic) - , c (Identity AbiHash) - , c (Identity LibraryVisibility) - , c (Identity PackageName) - , c (Identity UnitId) - , c (Identity UnqualComponentName) - , c (List FSep (Identity AbiDependency) AbiDependency) - , c (List FSep (Identity UnitId) UnitId) - , c (List FSep (MQuoted ModuleName) ModuleName) - , c (List FSep FilePathNT String) - , c (List FSep Token String) - , c (MQuoted MungedPackageName) - , c (MQuoted Version) - , c CompatPackageKey - , c ExposedModules - , c InstWith - , c SpecLicenseLenient - ) - => g InstalledPackageInfo InstalledPackageInfo -ipiFieldGrammar = mkInstalledPackageInfo - -- Deprecated fields - <$> monoidalFieldAla "hugs-options" (alaList' FSep Token) unitedList - --- https://github.com/haskell/cabal/commit/40f3601e17024f07e0da8e64d3dd390177ce908b - ^^^ deprecatedSince CabalSpecV1_22 "hugs isn't supported anymore" - -- Very basic fields: name, version, package-name, lib-name and visibility - <@> blurFieldGrammar basic basicFieldGrammar - -- Basic fields - <@> optionalFieldDef "id" L.installedUnitId (mkUnitId "") - <@> optionalFieldDefAla "instantiated-with" InstWith L.instantiatedWith [] - <@> optionalFieldDefAla "key" CompatPackageKey L.compatPackageKey "" - <@> optionalFieldDefAla "license" SpecLicenseLenient L.license (Left SPDX.NONE) - <@> freeTextFieldDefST "copyright" L.copyright - <@> freeTextFieldDefST "maintainer" L.maintainer - <@> freeTextFieldDefST "author" L.author - <@> freeTextFieldDefST "stability" L.stability - <@> freeTextFieldDefST "homepage" L.homepage - <@> freeTextFieldDefST "package-url" L.pkgUrl - <@> freeTextFieldDefST "synopsis" L.synopsis - <@> freeTextFieldDefST "description" L.description - <@> freeTextFieldDefST "category" L.category - -- Installed fields - <@> optionalFieldDef "abi" L.abiHash (mkAbiHash "") - <@> booleanFieldDef "indefinite" L.indefinite False - <@> booleanFieldDef "exposed" L.exposed False - <@> monoidalFieldAla "exposed-modules" ExposedModules L.exposedModules - <@> monoidalFieldAla "hidden-modules" (alaList' FSep MQuoted) L.hiddenModules - <@> booleanFieldDef "trusted" L.trusted False - <@> monoidalFieldAla "import-dirs" (alaList' FSep FilePathNT) L.importDirs - <@> monoidalFieldAla "library-dirs" (alaList' FSep FilePathNT) L.libraryDirs - <@> monoidalFieldAla "dynamic-library-dirs" (alaList' FSep FilePathNT) L.libraryDynDirs - <@> optionalFieldDefAla "data-dir" FilePathNT L.dataDir "" - <@> monoidalFieldAla "hs-libraries" (alaList' FSep Token) L.hsLibraries - <@> monoidalFieldAla "extra-libraries" (alaList' FSep Token) L.extraLibraries - <@> monoidalFieldAla "extra-ghci-libraries" (alaList' FSep Token) L.extraGHCiLibraries - <@> monoidalFieldAla "include-dirs" (alaList' FSep FilePathNT) L.includeDirs - <@> monoidalFieldAla "includes" (alaList' FSep FilePathNT) L.includes - <@> monoidalFieldAla "depends" (alaList FSep) L.depends - <@> monoidalFieldAla "abi-depends" (alaList FSep) L.abiDepends - <@> monoidalFieldAla "cc-options" (alaList' FSep Token) L.ccOptions - <@> monoidalFieldAla "cxx-options" (alaList' FSep Token) L.cxxOptions - <@> monoidalFieldAla "ld-options" (alaList' FSep Token) L.ldOptions - <@> monoidalFieldAla "framework-dirs" (alaList' FSep FilePathNT) L.frameworkDirs - <@> monoidalFieldAla "frameworks" (alaList' FSep Token) L.frameworks - <@> monoidalFieldAla "haddock-interfaces" (alaList' FSep FilePathNT) L.haddockInterfaces - <@> monoidalFieldAla "haddock-html" (alaList' FSep FilePathNT) L.haddockHTMLs - <@> optionalFieldAla "pkgroot" FilePathNT L.pkgRoot - where - mkInstalledPackageInfo _ Basic {..} = InstalledPackageInfo - -- _basicPkgName is not used - -- setMaybePackageId says it can be no-op. - (PackageIdentifier pn _basicVersion) - (combineLibraryName ln _basicLibName) - (mkComponentId "") -- installedComponentId_, not in use - _basicLibVisibility - where - MungedPackageName pn ln = _basicName -{-# SPECIALIZE ipiFieldGrammar :: FieldDescrs InstalledPackageInfo InstalledPackageInfo #-} -{-# SPECIALIZE ipiFieldGrammar :: ParsecFieldGrammar InstalledPackageInfo InstalledPackageInfo #-} -{-# SPECIALIZE ipiFieldGrammar :: PrettyFieldGrammar InstalledPackageInfo InstalledPackageInfo #-} - --- (forall b. [b]) ~ () -unitedList :: Lens' a [b] -unitedList f s = s <$ f [] - -------------------------------------------------------------------------------- --- Helper functions -------------------------------------------------------------------------------- - --- | Combine 'LibraryName'. in parsing we prefer value coming --- from munged @name@ field over the @lib-name@. --- --- /Should/ be irrelevant. -combineLibraryName :: LibraryName -> LibraryName -> LibraryName -combineLibraryName l@(LSubLibName _) _ = l -combineLibraryName _ l = l - --- To maintain backwards-compatibility, we accept both comma/non-comma --- separated variants of this field. You SHOULD use the comma syntax if you --- use any new functions, although actually it's unambiguous due to a quirk --- of the fact that modules must start with capital letters. - -showExposedModules :: [ExposedModule] -> Disp.Doc -showExposedModules xs - | all isExposedModule xs = Disp.fsep (map pretty xs) - | otherwise = Disp.fsep (Disp.punctuate Disp.comma (map pretty xs)) - where isExposedModule (ExposedModule _ Nothing) = True - isExposedModule _ = False - --- | Setter for the @package-name@ field. It should be acceptable for this --- to be a no-op. -setMaybePackageName :: Maybe PackageName -> InstalledPackageInfo -> InstalledPackageInfo -setMaybePackageName Nothing ipi = ipi -setMaybePackageName (Just pn) ipi = ipi - { sourcePackageId = (sourcePackageId ipi) {pkgName=pn} - } - -setMungedPackageName :: MungedPackageName -> InstalledPackageInfo -> InstalledPackageInfo -setMungedPackageName (MungedPackageName pn ln) ipi = ipi - { sourcePackageId = (sourcePackageId ipi) {pkgName=pn} - , sourceLibName = ln - } - ---- | Returns @Just@ if the @name@ field of the IPI record would not contain ---- the package name verbatim. This helps us avoid writing @package-name@ ---- when it's redundant. -maybePackageName :: InstalledPackageInfo -> Maybe PackageName -maybePackageName ipi = case sourceLibName ipi of - LMainLibName -> Nothing - LSubLibName _ -> Just (packageName ipi) - -------------------------------------------------------------------------------- --- Auxiliary types -------------------------------------------------------------------------------- - -newtype ExposedModules = ExposedModules { getExposedModules :: [ExposedModule] } - -instance Newtype [ExposedModule] ExposedModules - -instance Parsec ExposedModules where - parsec = ExposedModules <$> parsecOptCommaList parsec - -instance Pretty ExposedModules where - pretty = showExposedModules . getExposedModules - -newtype CompatPackageKey = CompatPackageKey { getCompatPackageKey :: String } - -instance Newtype String CompatPackageKey - -instance Pretty CompatPackageKey where - pretty = Disp.text . getCompatPackageKey - -instance Parsec CompatPackageKey where - parsec = CompatPackageKey <$> P.munch1 uid_char where - uid_char c = Char.isAlphaNum c || c `elem` ("-_.=[],:<>+" :: String) - -newtype InstWith = InstWith { getInstWith :: [(ModuleName,OpenModule)] } - -instance Newtype [(ModuleName, OpenModule)] InstWith - -instance Pretty InstWith where - pretty = dispOpenModuleSubst . Map.fromList . getInstWith - -instance Parsec InstWith where - parsec = InstWith . Map.toList <$> parsecOpenModuleSubst - --- | SPDX License expression or legacy license. Lenient parser, accepts either. -newtype SpecLicenseLenient = SpecLicenseLenient { getSpecLicenseLenient :: Either SPDX.License License } - -instance Newtype (Either SPDX.License License) SpecLicenseLenient - -instance Parsec SpecLicenseLenient where - parsec = fmap SpecLicenseLenient $ Left <$> P.try parsec <|> Right <$> parsec - -instance Pretty SpecLicenseLenient where - pretty = either pretty pretty . getSpecLicenseLenient - -------------------------------------------------------------------------------- --- Basic fields -------------------------------------------------------------------------------- - --- | This type is used to mangle fields as --- in serialised textual representation --- to the actual 'InstalledPackageInfo' fields. -data Basic = Basic - { _basicName :: MungedPackageName - , _basicVersion :: Version - , _basicPkgName :: Maybe PackageName - , _basicLibName :: LibraryName - , _basicLibVisibility :: LibraryVisibility - } - -basic :: Lens' InstalledPackageInfo Basic -basic f ipi = g <$> f b - where - b = Basic - (mungedPackageName ipi) - (packageVersion ipi) - (maybePackageName ipi) - (sourceLibName ipi) - (libVisibility ipi) - - g (Basic n v pn ln lv) = ipi - & setMungedPackageName n - & L.sourcePackageId . L.pkgVersion .~ v - & setMaybePackageName pn - & L.sourceLibName .~ ln - & L.libVisibility .~ lv - -basicName :: Lens' Basic MungedPackageName -basicName f b = (\x -> b { _basicName = x }) <$> f (_basicName b) -{-# INLINE basicName #-} - -basicVersion :: Lens' Basic Version -basicVersion f b = (\x -> b { _basicVersion = x }) <$> f (_basicVersion b) -{-# INLINE basicVersion #-} - -basicPkgName :: Lens' Basic (Maybe PackageName) -basicPkgName f b = (\x -> b { _basicPkgName = x }) <$> f (_basicPkgName b) -{-# INLINE basicPkgName #-} - -basicLibName :: Lens' Basic (Maybe UnqualComponentName) -basicLibName f b = (\x -> b { _basicLibName = maybeToLibraryName x }) <$> - f (libraryNameString (_basicLibName b)) -{-# INLINE basicLibName #-} - -basicLibVisibility :: Lens' Basic LibraryVisibility -basicLibVisibility f b = (\x -> b { _basicLibVisibility = x }) <$> - f (_basicLibVisibility b) -{-# INLINE basicLibVisibility #-} - -basicFieldGrammar - :: ( FieldGrammar c g, Applicative (g Basic) - , c (Identity LibraryVisibility) - , c (Identity PackageName) - , c (Identity UnqualComponentName) - , c (MQuoted MungedPackageName) - , c (MQuoted Version) - ) - => g Basic Basic -basicFieldGrammar = mkBasic - <$> optionalFieldDefAla "name" MQuoted basicName (mungedPackageName emptyInstalledPackageInfo) - <*> optionalFieldDefAla "version" MQuoted basicVersion nullVersion - <*> optionalField "package-name" basicPkgName - <*> optionalField "lib-name" basicLibName - <*> optionalFieldDef "visibility" basicLibVisibility LibraryVisibilityPrivate - where - mkBasic n v pn ln lv = Basic n v pn ln' lv' - where - ln' = maybe LMainLibName LSubLibName ln - -- Older GHCs (<8.8) always report installed libraries as private - -- because their ghc-pkg builds with an older Cabal. - -- So we always set LibraryVisibilityPublic for main (unnamed) libs. - -- This can be removed once we stop supporting GHC<8.8, at the - -- condition that we keep marking main libraries as public when - -- registering them. - lv' = if - let MungedPackageName _ mln = n in - -- We need to check both because on ghc<8.2 ln' will always - -- be LMainLibName - ln' == LMainLibName && mln == LMainLibName - then LibraryVisibilityPublic - else lv diff --git a/src/Distribution/Types/InstalledPackageInfo/Lens.hs b/src/Distribution/Types/InstalledPackageInfo/Lens.hs deleted file mode 100644 --- a/src/Distribution/Types/InstalledPackageInfo/Lens.hs +++ /dev/null @@ -1,190 +0,0 @@ -module Distribution.Types.InstalledPackageInfo.Lens ( - InstalledPackageInfo, - module Distribution.Types.InstalledPackageInfo.Lens - ) where - -import Distribution.Compat.Lens -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Backpack (OpenModule) -import Distribution.License (License) -import Distribution.ModuleName (ModuleName) -import Distribution.Package (AbiHash, ComponentId, PackageIdentifier, UnitId) -import Distribution.Types.InstalledPackageInfo (AbiDependency, ExposedModule, InstalledPackageInfo) -import Distribution.Types.LibraryName (LibraryName) -import Distribution.Types.LibraryVisibility (LibraryVisibility) -import Distribution.Utils.ShortText (ShortText) - - -import qualified Distribution.SPDX as SPDX -import qualified Distribution.Types.InstalledPackageInfo as T - -sourcePackageId :: Lens' InstalledPackageInfo PackageIdentifier -sourcePackageId f s = fmap (\x -> s { T.sourcePackageId = x }) (f (T.sourcePackageId s)) -{-# INLINE sourcePackageId #-} - -installedUnitId :: Lens' InstalledPackageInfo UnitId -installedUnitId f s = fmap (\x -> s { T.installedUnitId = x }) (f (T.installedUnitId s)) -{-# INLINE installedUnitId #-} - -installedComponentId_ :: Lens' InstalledPackageInfo ComponentId -installedComponentId_ f s = fmap (\x -> s { T.installedComponentId_ = x }) (f (T.installedComponentId_ s)) -{-# INLINE installedComponentId_ #-} - -instantiatedWith :: Lens' InstalledPackageInfo [(ModuleName,OpenModule)] -instantiatedWith f s = fmap (\x -> s { T.instantiatedWith = x }) (f (T.instantiatedWith s)) -{-# INLINE instantiatedWith #-} - -sourceLibName :: Lens' InstalledPackageInfo LibraryName -sourceLibName f s = fmap (\x -> s { T.sourceLibName = x }) (f (T.sourceLibName s)) -{-# INLINE sourceLibName #-} - -compatPackageKey :: Lens' InstalledPackageInfo String -compatPackageKey f s = fmap (\x -> s { T.compatPackageKey = x }) (f (T.compatPackageKey s)) -{-# INLINE compatPackageKey #-} - -license :: Lens' InstalledPackageInfo (Either SPDX.License License) -license f s = fmap (\x -> s { T.license = x }) (f (T.license s)) -{-# INLINE license #-} - -copyright :: Lens' InstalledPackageInfo ShortText -copyright f s = fmap (\x -> s { T.copyright = x }) (f (T.copyright s)) -{-# INLINE copyright #-} - -maintainer :: Lens' InstalledPackageInfo ShortText -maintainer f s = fmap (\x -> s { T.maintainer = x }) (f (T.maintainer s)) -{-# INLINE maintainer #-} - -author :: Lens' InstalledPackageInfo ShortText -author f s = fmap (\x -> s { T.author = x }) (f (T.author s)) -{-# INLINE author #-} - -stability :: Lens' InstalledPackageInfo ShortText -stability f s = fmap (\x -> s { T.stability = x }) (f (T.stability s)) -{-# INLINE stability #-} - -homepage :: Lens' InstalledPackageInfo ShortText -homepage f s = fmap (\x -> s { T.homepage = x }) (f (T.homepage s)) -{-# INLINE homepage #-} - -pkgUrl :: Lens' InstalledPackageInfo ShortText -pkgUrl f s = fmap (\x -> s { T.pkgUrl = x }) (f (T.pkgUrl s)) -{-# INLINE pkgUrl #-} - -synopsis :: Lens' InstalledPackageInfo ShortText -synopsis f s = fmap (\x -> s { T.synopsis = x }) (f (T.synopsis s)) -{-# INLINE synopsis #-} - -description :: Lens' InstalledPackageInfo ShortText -description f s = fmap (\x -> s { T.description = x }) (f (T.description s)) -{-# INLINE description #-} - -category :: Lens' InstalledPackageInfo ShortText -category f s = fmap (\x -> s { T.category = x }) (f (T.category s)) -{-# INLINE category #-} - -abiHash :: Lens' InstalledPackageInfo AbiHash -abiHash f s = fmap (\x -> s { T.abiHash = x }) (f (T.abiHash s)) -{-# INLINE abiHash #-} - -indefinite :: Lens' InstalledPackageInfo Bool -indefinite f s = fmap (\x -> s { T.indefinite = x }) (f (T.indefinite s)) -{-# INLINE indefinite #-} - -exposed :: Lens' InstalledPackageInfo Bool -exposed f s = fmap (\x -> s { T.exposed = x }) (f (T.exposed s)) -{-# INLINE exposed #-} - -exposedModules :: Lens' InstalledPackageInfo [ExposedModule] -exposedModules f s = fmap (\x -> s { T.exposedModules = x }) (f (T.exposedModules s)) -{-# INLINE exposedModules #-} - -hiddenModules :: Lens' InstalledPackageInfo [ModuleName] -hiddenModules f s = fmap (\x -> s { T.hiddenModules = x }) (f (T.hiddenModules s)) -{-# INLINE hiddenModules #-} - -trusted :: Lens' InstalledPackageInfo Bool -trusted f s = fmap (\x -> s { T.trusted = x }) (f (T.trusted s)) -{-# INLINE trusted #-} - -importDirs :: Lens' InstalledPackageInfo [FilePath] -importDirs f s = fmap (\x -> s { T.importDirs = x }) (f (T.importDirs s)) -{-# INLINE importDirs #-} - -libraryDirs :: Lens' InstalledPackageInfo [FilePath] -libraryDirs f s = fmap (\x -> s { T.libraryDirs = x }) (f (T.libraryDirs s)) -{-# INLINE libraryDirs #-} - -libraryDynDirs :: Lens' InstalledPackageInfo [FilePath] -libraryDynDirs f s = fmap (\x -> s { T.libraryDynDirs = x }) (f (T.libraryDynDirs s)) -{-# INLINE libraryDynDirs #-} - -dataDir :: Lens' InstalledPackageInfo FilePath -dataDir f s = fmap (\x -> s { T.dataDir = x }) (f (T.dataDir s)) -{-# INLINE dataDir #-} - -hsLibraries :: Lens' InstalledPackageInfo [String] -hsLibraries f s = fmap (\x -> s { T.hsLibraries = x }) (f (T.hsLibraries s)) -{-# INLINE hsLibraries #-} - -extraLibraries :: Lens' InstalledPackageInfo [String] -extraLibraries f s = fmap (\x -> s { T.extraLibraries = x }) (f (T.extraLibraries s)) -{-# INLINE extraLibraries #-} - -extraGHCiLibraries :: Lens' InstalledPackageInfo [String] -extraGHCiLibraries f s = fmap (\x -> s { T.extraGHCiLibraries = x }) (f (T.extraGHCiLibraries s)) -{-# INLINE extraGHCiLibraries #-} - -includeDirs :: Lens' InstalledPackageInfo [FilePath] -includeDirs f s = fmap (\x -> s { T.includeDirs = x }) (f (T.includeDirs s)) -{-# INLINE includeDirs #-} - -includes :: Lens' InstalledPackageInfo [String] -includes f s = fmap (\x -> s { T.includes = x }) (f (T.includes s)) -{-# INLINE includes #-} - -depends :: Lens' InstalledPackageInfo [UnitId] -depends f s = fmap (\x -> s { T.depends = x }) (f (T.depends s)) -{-# INLINE depends #-} - -abiDepends :: Lens' InstalledPackageInfo [AbiDependency] -abiDepends f s = fmap (\x -> s { T.abiDepends = x }) (f (T.abiDepends s)) -{-# INLINE abiDepends #-} - -ccOptions :: Lens' InstalledPackageInfo [String] -ccOptions f s = fmap (\x -> s { T.ccOptions = x }) (f (T.ccOptions s)) -{-# INLINE ccOptions #-} - -cxxOptions :: Lens' InstalledPackageInfo [String] -cxxOptions f s = fmap (\x -> s { T.cxxOptions = x }) (f (T.cxxOptions s)) -{-# INLINE cxxOptions #-} - -ldOptions :: Lens' InstalledPackageInfo [String] -ldOptions f s = fmap (\x -> s { T.ldOptions = x }) (f (T.ldOptions s)) -{-# INLINE ldOptions #-} - -frameworkDirs :: Lens' InstalledPackageInfo [FilePath] -frameworkDirs f s = fmap (\x -> s { T.frameworkDirs = x }) (f (T.frameworkDirs s)) -{-# INLINE frameworkDirs #-} - -frameworks :: Lens' InstalledPackageInfo [String] -frameworks f s = fmap (\x -> s { T.frameworks = x }) (f (T.frameworks s)) -{-# INLINE frameworks #-} - -haddockInterfaces :: Lens' InstalledPackageInfo [FilePath] -haddockInterfaces f s = fmap (\x -> s { T.haddockInterfaces = x }) (f (T.haddockInterfaces s)) -{-# INLINE haddockInterfaces #-} - -haddockHTMLs :: Lens' InstalledPackageInfo [FilePath] -haddockHTMLs f s = fmap (\x -> s { T.haddockHTMLs = x }) (f (T.haddockHTMLs s)) -{-# INLINE haddockHTMLs #-} - -pkgRoot :: Lens' InstalledPackageInfo (Maybe FilePath) -pkgRoot f s = fmap (\x -> s { T.pkgRoot = x }) (f (T.pkgRoot s)) -{-# INLINE pkgRoot #-} - -libVisibility :: Lens' InstalledPackageInfo LibraryVisibility -libVisibility f s = fmap (\x -> s { T.libVisibility = x }) (f (T.libVisibility s)) -{-# INLINE libVisibility #-} - diff --git a/src/Distribution/Types/LegacyExeDependency.hs b/src/Distribution/Types/LegacyExeDependency.hs deleted file mode 100644 --- a/src/Distribution/Types/LegacyExeDependency.hs +++ /dev/null @@ -1,47 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Types.LegacyExeDependency - ( LegacyExeDependency(..) - ) where - -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Parsec -import Distribution.Pretty -import Distribution.Version (VersionRange, anyVersion) - -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp - --- | Describes a legacy `build-tools`-style dependency on an executable --- --- It is "legacy" because we do not know what the build-tool referred to. It --- could refer to a pkg-config executable (PkgconfigName), or an internal --- executable (UnqualComponentName). Thus the name is stringly typed. --- --- @since 2.0.0.2 -data LegacyExeDependency = LegacyExeDependency - String - VersionRange - deriving (Generic, Read, Show, Eq, Typeable, Data) - -instance Binary LegacyExeDependency -instance Structured LegacyExeDependency -instance NFData LegacyExeDependency where rnf = genericRnf - -instance Pretty LegacyExeDependency where - pretty (LegacyExeDependency name ver) = - Disp.text name <+> pretty ver - -instance Parsec LegacyExeDependency where - parsec = do - name <- parsecMaybeQuoted nameP - P.spaces - verRange <- parsecMaybeQuoted parsec <|> pure anyVersion - pure $ LegacyExeDependency name verRange - where - nameP = intercalate "-" <$> toList <$> P.sepByNonEmpty component (P.char '-') - component = do - cs <- P.munch1 (\c -> isAlphaNum c || c == '+' || c == '_') - if all isDigit cs then fail "invalid component" else return cs diff --git a/src/Distribution/Types/Lens.hs b/src/Distribution/Types/Lens.hs deleted file mode 100644 --- a/src/Distribution/Types/Lens.hs +++ /dev/null @@ -1,25 +0,0 @@ -module Distribution.Types.Lens ( - module Distribution.Types.Benchmark.Lens, - module Distribution.Types.BuildInfo.Lens, - module Distribution.Types.Executable.Lens, - module Distribution.Types.ForeignLib.Lens, - module Distribution.Types.GenericPackageDescription.Lens, - module Distribution.Types.Library.Lens, - module Distribution.Types.PackageDescription.Lens, - module Distribution.Types.PackageId.Lens, - module Distribution.Types.SetupBuildInfo.Lens, - module Distribution.Types.SourceRepo.Lens, - module Distribution.Types.TestSuite.Lens, - ) where - -import Distribution.Types.Benchmark.Lens -import Distribution.Types.BuildInfo.Lens -import Distribution.Types.Executable.Lens -import Distribution.Types.ForeignLib.Lens -import Distribution.Types.GenericPackageDescription.Lens -import Distribution.Types.Library.Lens -import Distribution.Types.PackageDescription.Lens -import Distribution.Types.PackageId.Lens -import Distribution.Types.SetupBuildInfo.Lens -import Distribution.Types.SourceRepo.Lens -import Distribution.Types.TestSuite.Lens diff --git a/src/Distribution/Types/Library.hs b/src/Distribution/Types/Library.hs deleted file mode 100644 --- a/src/Distribution/Types/Library.hs +++ /dev/null @@ -1,96 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} - -module Distribution.Types.Library ( - Library(..), - emptyLibrary, - explicitLibModules, - libModulesAutogen, -) where - -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.ModuleName -import Distribution.Types.BuildInfo -import Distribution.Types.LibraryVisibility -import Distribution.Types.ModuleReexport -import Distribution.Types.LibraryName - -import qualified Distribution.Types.BuildInfo.Lens as L - -data Library = Library - { libName :: LibraryName - , exposedModules :: [ModuleName] - , reexportedModules :: [ModuleReexport] - , signatures :: [ModuleName] -- ^ What sigs need implementations? - , libExposed :: Bool -- ^ Is the lib to be exposed by default? (i.e. whether its modules available in GHCi for example) - , libVisibility :: LibraryVisibility -- ^ Whether this multilib can be dependent from outside. - , libBuildInfo :: BuildInfo - } - deriving (Generic, Show, Eq, Read, Typeable, Data) - -instance L.HasBuildInfo Library where - buildInfo f l = (\x -> l { libBuildInfo = x }) <$> f (libBuildInfo l) - -instance Binary Library -instance Structured Library -instance NFData Library where rnf = genericRnf - -emptyLibrary :: Library -emptyLibrary = Library - { libName = LMainLibName - , exposedModules = mempty - , reexportedModules = mempty - , signatures = mempty - , libExposed = True - , libVisibility = mempty - , libBuildInfo = mempty - } - --- | This instance is not good. --- --- We need it for 'PackageDescription.Configuration.addBuildableCondition'. --- More correct method would be some kind of "create empty clone". --- --- More concretely, 'addBuildableCondition' will make `libVisibility = False` --- libraries when `buildable: false`. This may cause problems. --- -instance Monoid Library where - mempty = emptyLibrary - mappend = (<>) - -instance Semigroup Library where - a <> b = Library - { libName = combineLibraryName (libName a) (libName b) - , exposedModules = combine exposedModules - , reexportedModules = combine reexportedModules - , signatures = combine signatures - , libExposed = libExposed a && libExposed b -- so False propagates - , libVisibility = combine libVisibility - , libBuildInfo = combine libBuildInfo - } - where combine field = field a `mappend` field b - --- | Get all the module names from the library (exposed and internal modules) --- which are explicitly listed in the package description which would --- need to be compiled. (This does not include reexports, which --- do not need to be compiled.) This may not include all modules for which --- GHC generated interface files (i.e., implicit modules.) -explicitLibModules :: Library -> [ModuleName] -explicitLibModules lib = exposedModules lib - ++ otherModules (libBuildInfo lib) - ++ signatures lib - --- | Get all the auto generated module names from the library, exposed or not. --- This are a subset of 'libModules'. -libModulesAutogen :: Library -> [ModuleName] -libModulesAutogen lib = autogenModules (libBuildInfo lib) - --- | Combine 'LibraryName'. in parsing we prefer value coming --- from munged @name@ field over the @lib-name@. --- --- /Should/ be irrelevant. -combineLibraryName :: LibraryName -> LibraryName -> LibraryName -combineLibraryName l@(LSubLibName _) _ = l -combineLibraryName _ l = l diff --git a/src/Distribution/Types/Library/Lens.hs b/src/Distribution/Types/Library/Lens.hs deleted file mode 100644 --- a/src/Distribution/Types/Library/Lens.hs +++ /dev/null @@ -1,45 +0,0 @@ -module Distribution.Types.Library.Lens ( - Library, - module Distribution.Types.Library.Lens, - ) where - -import Distribution.Compat.Lens -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.ModuleName (ModuleName) -import Distribution.Types.BuildInfo (BuildInfo) -import Distribution.Types.Library (Library) -import Distribution.Types.LibraryName (LibraryName) -import Distribution.Types.LibraryVisibility (LibraryVisibility) -import Distribution.Types.ModuleReexport (ModuleReexport) - -import qualified Distribution.Types.Library as T - -libName :: Lens' Library LibraryName -libName f s = fmap (\x -> s { T.libName = x }) (f (T.libName s)) -{-# INLINE libName #-} - -exposedModules :: Lens' Library [ModuleName] -exposedModules f s = fmap (\x -> s { T.exposedModules = x }) (f (T.exposedModules s)) -{-# INLINE exposedModules #-} - -reexportedModules :: Lens' Library [ModuleReexport] -reexportedModules f s = fmap (\x -> s { T.reexportedModules = x }) (f (T.reexportedModules s)) -{-# INLINE reexportedModules #-} - -signatures :: Lens' Library [ModuleName] -signatures f s = fmap (\x -> s { T.signatures = x }) (f (T.signatures s)) -{-# INLINE signatures #-} - -libExposed :: Lens' Library Bool -libExposed f s = fmap (\x -> s { T.libExposed = x }) (f (T.libExposed s)) -{-# INLINE libExposed #-} - -libVisibility :: Lens' Library LibraryVisibility -libVisibility f s = fmap (\x -> s { T.libVisibility = x }) (f (T.libVisibility s)) -{-# INLINE libVisibility #-} - -libBuildInfo :: Lens' Library BuildInfo -libBuildInfo f s = fmap (\x -> s { T.libBuildInfo = x }) (f (T.libBuildInfo s)) -{-# INLINE libBuildInfo #-} diff --git a/src/Distribution/Types/LibraryName.hs b/src/Distribution/Types/LibraryName.hs deleted file mode 100644 --- a/src/Distribution/Types/LibraryName.hs +++ /dev/null @@ -1,73 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} - -module Distribution.Types.LibraryName ( - LibraryName(..), - defaultLibName, - maybeToLibraryName, - showLibraryName, - libraryNameStanza, - libraryNameString, - -- * Pretty & Parse - prettyLibraryNameComponent, - parsecLibraryNameComponent, - ) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Types.UnqualComponentName -import Distribution.Pretty -import Distribution.Parsec - -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp - -data LibraryName = LMainLibName - | LSubLibName UnqualComponentName - deriving (Eq, Generic, Ord, Read, Show, Typeable, Data) - -instance Binary LibraryName -instance Structured LibraryName -instance NFData LibraryName where rnf = genericRnf - --- | Pretty print 'LibraryName' in build-target-ish syntax. --- --- /Note:/ there are no 'Pretty' or 'Parsec' instances, --- as there's other way to represent 'LibraryName', namely as bare --- 'UnqualComponentName'. -prettyLibraryNameComponent :: LibraryName -> Disp.Doc -prettyLibraryNameComponent LMainLibName = Disp.text "lib" -prettyLibraryNameComponent (LSubLibName str) = Disp.text "lib:" <<>> pretty str - -parsecLibraryNameComponent :: CabalParsing m => m LibraryName -parsecLibraryNameComponent = do - _ <- P.string "lib" - parseComposite <|> parseSingle - where - parseSingle = return LMainLibName - parseComposite = do - _ <- P.char ':' - LSubLibName <$> parsec - -defaultLibName :: LibraryName -defaultLibName = LMainLibName - -showLibraryName :: LibraryName -> String -showLibraryName LMainLibName = "library" -showLibraryName (LSubLibName name) = "library '" ++ prettyShow name ++ "'" - -libraryNameStanza :: LibraryName -> String -libraryNameStanza LMainLibName = "library" -libraryNameStanza (LSubLibName name) = "library " ++ prettyShow name - -libraryNameString :: LibraryName -> Maybe UnqualComponentName -libraryNameString LMainLibName = Nothing -libraryNameString (LSubLibName n) = Just n - --- | Convert the 'UnqualComponentName' of a library into a --- 'LibraryName'. -maybeToLibraryName :: Maybe UnqualComponentName -> LibraryName -maybeToLibraryName Nothing = LMainLibName -maybeToLibraryName (Just n) = LSubLibName n - diff --git a/src/Distribution/Types/LibraryVisibility.hs b/src/Distribution/Types/LibraryVisibility.hs deleted file mode 100644 --- a/src/Distribution/Types/LibraryVisibility.hs +++ /dev/null @@ -1,52 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} - -module Distribution.Types.LibraryVisibility( - LibraryVisibility(..), -) where - -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Parsec -import Distribution.Pretty - -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp - --- | Multi-lib visibility --- --- @since 3.0.0.0 --- -data LibraryVisibility - -- | Can be depenendent from other packages - = LibraryVisibilityPublic - -- | Internal library, default - | LibraryVisibilityPrivate - deriving (Generic, Show, Read, Eq, Typeable, Data) - -instance Pretty LibraryVisibility where - pretty LibraryVisibilityPublic = Disp.text "public" - pretty LibraryVisibilityPrivate = Disp.text "private" - -instance Parsec LibraryVisibility where - parsec = do - name <- P.munch1 isAlpha - parsecWarning PWTExperimental "visibility is experimental feature (issue #5660)" - case name of - "public" -> return LibraryVisibilityPublic - "private" -> return LibraryVisibilityPrivate - _ -> fail $ "Unknown visibility: " ++ name - -instance Binary LibraryVisibility -instance Structured LibraryVisibility -instance NFData LibraryVisibility where rnf = genericRnf - -instance Semigroup LibraryVisibility where - LibraryVisibilityPrivate <> LibraryVisibilityPrivate = LibraryVisibilityPrivate - _ <> _ = LibraryVisibilityPublic - -instance Monoid LibraryVisibility where - mempty = LibraryVisibilityPrivate - mappend = (<>) diff --git a/src/Distribution/Types/Mixin.hs b/src/Distribution/Types/Mixin.hs deleted file mode 100644 --- a/src/Distribution/Types/Mixin.hs +++ /dev/null @@ -1,93 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} - -module Distribution.Types.Mixin ( - Mixin(..), - mkMixin, - normaliseMixin, -) where - -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.CabalSpecVersion -import Distribution.Parsec -import Distribution.Pretty -import Distribution.Types.IncludeRenaming -import Distribution.Types.LibraryName -import Distribution.Types.PackageName -import Distribution.Types.UnqualComponentName - -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as PP - --- | --- --- /Invariant:/ if 'mixinLibraryName' is 'LSubLibName', it's not --- the same as 'mixinPackageName'. In other words, --- the same invariant as 'Dependency' has. --- -data Mixin = Mixin { mixinPackageName :: PackageName - , mixinLibraryName :: LibraryName - , mixinIncludeRenaming :: IncludeRenaming } - deriving (Show, Read, Eq, Ord, Typeable, Data, Generic) - -instance Binary Mixin -instance Structured Mixin - -instance NFData Mixin where rnf = genericRnf - -instance Pretty Mixin where - pretty (Mixin pn LMainLibName incl) = pretty pn <+> pretty incl - pretty (Mixin pn (LSubLibName ln) incl) = pretty pn <<>> PP.colon <<>> pretty ln <+> pretty incl - --- | --- --- >>> simpleParsec "mylib" :: Maybe Mixin --- Just (Mixin {mixinPackageName = PackageName "mylib", mixinLibraryName = LMainLibName, mixinIncludeRenaming = IncludeRenaming {includeProvidesRn = DefaultRenaming, includeRequiresRn = DefaultRenaming}}) --- --- >>> simpleParsec "thatlib:sublib" :: Maybe Mixin --- Just (Mixin {mixinPackageName = PackageName "thatlib", mixinLibraryName = LSubLibName (UnqualComponentName "sublib"), mixinIncludeRenaming = IncludeRenaming {includeProvidesRn = DefaultRenaming, includeRequiresRn = DefaultRenaming}}) --- --- >>> simpleParsec "thatlib:thatlib" :: Maybe Mixin --- Just (Mixin {mixinPackageName = PackageName "thatlib", mixinLibraryName = LMainLibName, mixinIncludeRenaming = IncludeRenaming {includeProvidesRn = DefaultRenaming, includeRequiresRn = DefaultRenaming}}) --- --- Sublibrary syntax is accepted since @cabal-version: 3.4@. --- --- >>> map (`simpleParsec'` "mylib:sub") [CabalSpecV3_0, CabalSpecV3_4] :: [Maybe Mixin] --- [Nothing,Just (Mixin {mixinPackageName = PackageName "mylib", mixinLibraryName = LSubLibName (UnqualComponentName "sub"), mixinIncludeRenaming = IncludeRenaming {includeProvidesRn = DefaultRenaming, includeRequiresRn = DefaultRenaming}})] --- -instance Parsec Mixin where - parsec = do - pn <- parsec - ln <- P.option LMainLibName $ do - _ <- P.char ':' - versionGuardMultilibs - parsecWarning PWTExperimental "colon specifier is experimental feature (issue #5660)" - LSubLibName <$> parsec - P.spaces - incl <- parsec - return (mkMixin pn ln incl) - where - -versionGuardMultilibs :: CabalParsing m => m () -versionGuardMultilibs = do - csv <- askCabalSpecVersion - when (csv < CabalSpecV3_4) $ fail $ unwords - [ "Sublibrary mixin syntax used." - , "To use this syntax the package needs to specify at least 'cabal-version: 3.4'." - ] - --- | Smart constructor of 'Mixin', enforces invariant. --- --- @since 3.4.0.0 -mkMixin :: PackageName -> LibraryName -> IncludeRenaming -> Mixin -mkMixin pn (LSubLibName uqn) incl - | packageNameToUnqualComponentName pn == uqn - = Mixin pn LMainLibName incl -mkMixin pn ln incl - = Mixin pn ln incl - --- | Restore invariant -normaliseMixin :: Mixin -> Mixin -normaliseMixin (Mixin pn ln incl) = mkMixin pn ln incl diff --git a/src/Distribution/Types/Module.hs b/src/Distribution/Types/Module.hs deleted file mode 100644 --- a/src/Distribution/Types/Module.hs +++ /dev/null @@ -1,46 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -module Distribution.Types.Module - ( Module(..) - ) where - -import Prelude () -import Distribution.Compat.Prelude - -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp -import Distribution.Pretty -import Distribution.Parsec -import Distribution.Types.UnitId -import Distribution.ModuleName - --- | A module identity uniquely identifies a Haskell module by --- qualifying a 'ModuleName' with the 'UnitId' which defined --- it. This type distinguishes between two packages --- which provide a module with the same name, or a module --- from the same package compiled with different dependencies. --- There are a few cases where Cabal needs to know about --- module identities, e.g., when writing out reexported modules in --- the 'InstalledPackageInfo'. -data Module = - Module DefUnitId ModuleName - deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) - -instance Binary Module -instance Structured Module - -instance Pretty Module where - pretty (Module uid mod_name) = - pretty uid <<>> Disp.text ":" <<>> pretty mod_name - -instance Parsec Module where - parsec = do - uid <- parsec - _ <- P.char ':' - mod_name <- parsec - return (Module uid mod_name) - -instance NFData Module where - rnf (Module uid mod_name) = rnf uid `seq` rnf mod_name diff --git a/src/Distribution/Types/ModuleReexport.hs b/src/Distribution/Types/ModuleReexport.hs deleted file mode 100644 --- a/src/Distribution/Types/ModuleReexport.hs +++ /dev/null @@ -1,50 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} - -module Distribution.Types.ModuleReexport ( - ModuleReexport(..) -) where - -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.ModuleName -import Distribution.Parsec -import Distribution.Pretty -import Distribution.Types.PackageName - -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp - --- ----------------------------------------------------------------------------- --- Module re-exports - -data ModuleReexport = ModuleReexport { - moduleReexportOriginalPackage :: Maybe PackageName, - moduleReexportOriginalName :: ModuleName, - moduleReexportName :: ModuleName - } - deriving (Eq, Generic, Read, Show, Typeable, Data) - -instance Binary ModuleReexport -instance Structured ModuleReexport -instance NFData ModuleReexport where rnf = genericRnf - -instance Pretty ModuleReexport where - pretty (ModuleReexport mpkgname origname newname) = - maybe Disp.empty (\pkgname -> pretty pkgname <<>> Disp.char ':') mpkgname - <<>> pretty origname - <+> if newname == origname - then Disp.empty - else Disp.text "as" <+> pretty newname - -instance Parsec ModuleReexport where - parsec = do - mpkgname <- P.optional (P.try $ parsec <* P.char ':') - origname <- parsec - newname <- P.option origname $ P.try $ do - P.spaces - _ <- P.string "as" - P.spaces - parsec - return (ModuleReexport mpkgname origname newname) diff --git a/src/Distribution/Types/ModuleRenaming.hs b/src/Distribution/Types/ModuleRenaming.hs deleted file mode 100644 --- a/src/Distribution/Types/ModuleRenaming.hs +++ /dev/null @@ -1,134 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE RankNTypes #-} - -module Distribution.Types.ModuleRenaming ( - ModuleRenaming(..), - interpModuleRenaming, - defaultRenaming, - isDefaultRenaming, -) where - -import Distribution.CabalSpecVersion -import Distribution.Compat.Prelude hiding (empty) -import Prelude () - -import Distribution.ModuleName -import Distribution.Parsec -import Distribution.Pretty - -import qualified Data.Map as Map -import qualified Data.Set as Set -import qualified Distribution.Compat.CharParsing as P -import Text.PrettyPrint (hsep, parens, punctuate, text, comma) - --- | Renaming applied to the modules provided by a package. --- The boolean indicates whether or not to also include all of the --- original names of modules. Thus, @ModuleRenaming False []@ is --- "don't expose any modules, and @ModuleRenaming True [("Data.Bool", "Bool")]@ --- is, "expose all modules, but also expose @Data.Bool@ as @Bool@". --- If a renaming is omitted you get the 'DefaultRenaming'. --- --- (NB: This is a list not a map so that we can preserve order.) --- -data ModuleRenaming - -- | A module renaming/thinning; e.g., @(A as B, C as C)@ - -- brings @B@ and @C@ into scope. - = ModuleRenaming [(ModuleName, ModuleName)] - -- | The default renaming, bringing all exported modules - -- into scope. - | DefaultRenaming - -- | Hiding renaming, e.g., @hiding (A, B)@, bringing all - -- exported modules into scope except the hidden ones. - | HidingRenaming [ModuleName] - deriving (Show, Read, Eq, Ord, Typeable, Data, Generic) - --- | Interpret a 'ModuleRenaming' as a partial map from 'ModuleName' --- to 'ModuleName'. For efficiency, you should partially apply it --- with 'ModuleRenaming' and then reuse it. -interpModuleRenaming :: ModuleRenaming -> ModuleName -> Maybe ModuleName -interpModuleRenaming DefaultRenaming = Just -interpModuleRenaming (ModuleRenaming rns) = - let m = Map.fromList rns - in \k -> Map.lookup k m -interpModuleRenaming (HidingRenaming hs) = - let s = Set.fromList hs - in \k -> if k `Set.member` s then Nothing else Just k - --- | The default renaming, if something is specified in @build-depends@ --- only. -defaultRenaming :: ModuleRenaming -defaultRenaming = DefaultRenaming - --- | Tests if its the default renaming; we can use a more compact syntax --- in 'Distribution.Types.IncludeRenaming.IncludeRenaming' in this case. -isDefaultRenaming :: ModuleRenaming -> Bool -isDefaultRenaming DefaultRenaming = True -isDefaultRenaming _ = False - - - -instance Binary ModuleRenaming where -instance Structured ModuleRenaming where - -instance NFData ModuleRenaming where rnf = genericRnf - --- NB: parentheses are mandatory, because later we may extend this syntax --- to allow "hiding (A, B)" or other modifier words. -instance Pretty ModuleRenaming where - pretty DefaultRenaming = mempty - pretty (HidingRenaming hides) - = text "hiding" <+> parens (hsep (punctuate comma (map pretty hides))) - pretty (ModuleRenaming rns) - = parens . hsep $ punctuate comma (map dispEntry rns) - where dispEntry (orig, new) - | orig == new = pretty orig - | otherwise = pretty orig <+> text "as" <+> pretty new - -instance Parsec ModuleRenaming where - parsec = do - csv <- askCabalSpecVersion - if csv >= CabalSpecV3_0 - then moduleRenamingParsec parensLax lexemeParsec - else moduleRenamingParsec parensStrict parsec - where - -- For cabal spec versions < 3.0 white spaces were not skipped - -- after the '(' and ')' tokens in the mixin field. This - -- parser checks the cabal file version and does the correct - -- skipping of spaces. - parensLax p = P.between (P.char '(' >> P.spaces) (P.char ')' >> P.spaces) p - parensStrict p = P.between (P.char '(' >> warnSpaces) (P.char ')') p - - warnSpaces = P.optional $ - P.space *> fail "space after parenthesis, use cabal-version: 3.0 or higher" - -moduleRenamingParsec - :: CabalParsing m - => (forall a. m a -> m a) -- ^ between parens - -> m ModuleName -- ^ module name parser - -> m ModuleRenaming -moduleRenamingParsec bp mn = - -- NB: try not necessary as the first token is obvious - P.choice [ parseRename, parseHiding, return DefaultRenaming ] - where - cma = P.char ',' >> P.spaces - parseRename = do - rns <- bp parseList - P.spaces - return (ModuleRenaming rns) - parseHiding = do - _ <- P.string "hiding" - P.spaces -- space isn't strictly required as next is an open paren - hides <- bp (P.sepBy mn cma) - return (HidingRenaming hides) - parseList = - P.sepBy parseEntry cma - parseEntry = do - orig <- parsec - P.spaces - P.option (orig, orig) $ do - _ <- P.string "as" - P.skipSpaces1 -- require space after "as" - new <- parsec - P.spaces - return (orig, new) diff --git a/src/Distribution/Types/MungedPackageId.hs b/src/Distribution/Types/MungedPackageId.hs deleted file mode 100644 --- a/src/Distribution/Types/MungedPackageId.hs +++ /dev/null @@ -1,83 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Types.MungedPackageId - ( MungedPackageId(..) - , computeCompatPackageId - ) where - -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Parsec -import Distribution.Pretty -import Distribution.Types.LibraryName -import Distribution.Types.MungedPackageName -import Distribution.Types.PackageId -import Distribution.Version (Version, nullVersion) - -import qualified Text.PrettyPrint as Disp - --- | A simple pair of a 'MungedPackageName' and 'Version'. 'MungedPackageName' is to --- 'MungedPackageId' as 'PackageName' is to 'PackageId'. See 'MungedPackageName' for more --- info. -data MungedPackageId - = MungedPackageId { - -- | The combined package and component name. see documentation for - -- 'MungedPackageName'. - mungedName :: MungedPackageName, - -- | The version of this package / component, eg 1.2 - mungedVersion :: Version - } - deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) - -instance Binary MungedPackageId -instance Structured MungedPackageId - --- | --- --- >>> prettyShow $ MungedPackageId (MungedPackageName "servant" LMainLibName) (mkVersion [1,2,3]) --- "servant-1.2.3" --- --- >>> prettyShow $ MungedPackageId (MungedPackageName "servant" (LSubLibName "lackey")) (mkVersion [0,1,2]) --- "z-servant-z-lackey-0.1.2" --- -instance Pretty MungedPackageId where - pretty (MungedPackageId n v) - | v == nullVersion = pretty n -- if no version, don't show version. - | otherwise = pretty n <<>> Disp.char '-' <<>> pretty v - --- | --- --- >>> simpleParsec "foo-bar-0" :: Maybe MungedPackageId --- Just (MungedPackageId {mungedName = MungedPackageName (PackageName "foo-bar") LMainLibName, mungedVersion = mkVersion [0]}) --- --- >>> simpleParsec "foo-bar" :: Maybe MungedPackageId --- Just (MungedPackageId {mungedName = MungedPackageName (PackageName "foo-bar") LMainLibName, mungedVersion = mkVersion []}) --- --- >>> simpleParsec "z-foo-bar-z-baz-0" :: Maybe MungedPackageId --- Just (MungedPackageId {mungedName = MungedPackageName (PackageName "foo-bar") (LSubLibName (UnqualComponentName "baz")), mungedVersion = mkVersion [0]}) --- --- >>> simpleParsec "foo-bar-0-0" :: Maybe MungedPackageId --- Nothing --- --- >>> simpleParsec "foo-bar.0" :: Maybe MungedPackageId --- Nothing --- --- >>> simpleParsec "foo-bar.4-2" :: Maybe MungedPackageId --- Nothing --- -instance Parsec MungedPackageId where - parsec = do - PackageIdentifier pn v <- parsec - return $ MungedPackageId (decodeCompatPackageName pn) v - -instance NFData MungedPackageId where - rnf (MungedPackageId name version) = rnf name `seq` rnf version - -computeCompatPackageId :: PackageId -> LibraryName -> MungedPackageId -computeCompatPackageId (PackageIdentifier pn vr) ln = - MungedPackageId (MungedPackageName pn ln) vr - --- $setup --- >>> :seti -XOverloadedStrings --- >>> import Distribution.Types.Version diff --git a/src/Distribution/Types/MungedPackageName.hs b/src/Distribution/Types/MungedPackageName.hs deleted file mode 100644 --- a/src/Distribution/Types/MungedPackageName.hs +++ /dev/null @@ -1,157 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Types.MungedPackageName - ( MungedPackageName (..) - , decodeCompatPackageName - , encodeCompatPackageName - ) where - -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Parsec -import Distribution.Pretty -import Distribution.Types.LibraryName -import Distribution.Types.PackageName -import Distribution.Types.UnqualComponentName - -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp - --- | A combination of a package and component name used in various legacy --- interfaces, chiefly bundled with a version as 'MungedPackageId'. It's generally --- better to use a 'UnitId' to opaquely refer to some compilation/packing unit, --- but that doesn't always work, e.g. where a "name" is needed, in which case --- this can be used as a fallback. --- --- Use 'mkMungedPackageName' and 'unMungedPackageName' to convert from/to a 'String'. --- --- In @3.0.0.0@ representation was changed from opaque (string) to semantic representation. --- --- @since 2.0.0.2 --- -data MungedPackageName = MungedPackageName !PackageName !LibraryName - deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) - -instance Binary MungedPackageName -instance Structured MungedPackageName -instance NFData MungedPackageName where rnf = genericRnf - --- | Computes the package name for a library. If this is the public --- library, it will just be the original package name; otherwise, --- it will be a munged package name recording the original package --- name as well as the name of the internal library. --- --- A lot of tooling in the Haskell ecosystem assumes that if something --- is installed to the package database with the package name 'foo', --- then it actually is an entry for the (only public) library in package --- 'foo'. With internal packages, this is not necessarily true: --- a public library as well as arbitrarily many internal libraries may --- come from the same package. To prevent tools from getting confused --- in this case, the package name of these internal libraries is munged --- so that they do not conflict the public library proper. A particular --- case where this matters is ghc-pkg: if we don't munge the package --- name, the inplace registration will OVERRIDE a different internal --- library. --- --- We munge into a reserved namespace, "z-", and encode both the --- component name and the package name of an internal library using the --- following format: --- --- compat-pkg-name ::= "z-" package-name "-z-" library-name --- --- where package-name and library-name have "-" ( "z" + ) "-" --- segments encoded by adding an extra "z". --- --- When we have the public library, the compat-pkg-name is just the --- package-name, no surprises there! --- --- >>> prettyShow $ MungedPackageName "servant" LMainLibName --- "servant" --- --- >>> prettyShow $ MungedPackageName "servant" (LSubLibName "lackey") --- "z-servant-z-lackey" --- -instance Pretty MungedPackageName where - -- First handle the cases where we can just use the original 'PackageName'. - -- This is for the PRIMARY library, and it is non-Backpack, or the - -- indefinite package for us. - pretty = Disp.text . encodeCompatPackageName' - --- | --- --- >>> simpleParsec "servant" :: Maybe MungedPackageName --- Just (MungedPackageName (PackageName "servant") LMainLibName) --- --- >>> simpleParsec "z-servant-z-lackey" :: Maybe MungedPackageName --- Just (MungedPackageName (PackageName "servant") (LSubLibName (UnqualComponentName "lackey"))) --- --- >>> simpleParsec "z-servant-zz" :: Maybe MungedPackageName --- Just (MungedPackageName (PackageName "z-servant-zz") LMainLibName) --- -instance Parsec MungedPackageName where - parsec = decodeCompatPackageName' <$> parsecUnqualComponentName - -------------------------------------------------------------------------------- --- ZDashCode conversions -------------------------------------------------------------------------------- - --- | Intended for internal use only --- --- >>> decodeCompatPackageName "z-servant-z-lackey" --- MungedPackageName (PackageName "servant") (LSubLibName (UnqualComponentName "lackey")) --- -decodeCompatPackageName :: PackageName -> MungedPackageName -decodeCompatPackageName = decodeCompatPackageName' . unPackageName - --- | Intended for internal use only --- --- >>> encodeCompatPackageName $ MungedPackageName "servant" (LSubLibName "lackey") --- PackageName "z-servant-z-lackey" --- --- This is used in @cabal-install@ in the Solver. --- May become obsolete as solver moves to per-component solving. --- -encodeCompatPackageName :: MungedPackageName -> PackageName -encodeCompatPackageName = mkPackageName . encodeCompatPackageName' - -decodeCompatPackageName' :: String -> MungedPackageName -decodeCompatPackageName' m = - case m of - 'z':'-':rest | Right [pn, cn] <- explicitEitherParsec parseZDashCode rest - -> MungedPackageName (mkPackageName pn) (LSubLibName (mkUnqualComponentName cn)) - s -> MungedPackageName (mkPackageName s) LMainLibName - -encodeCompatPackageName' :: MungedPackageName -> String -encodeCompatPackageName' (MungedPackageName pn LMainLibName) = unPackageName pn -encodeCompatPackageName' (MungedPackageName pn (LSubLibName uqn)) = - "z-" ++ zdashcode (unPackageName pn) ++ - "-z-" ++ zdashcode (unUnqualComponentName uqn) - -zdashcode :: String -> String -zdashcode s = go s (Nothing :: Maybe Int) [] - where go [] _ r = reverse r - go ('-':z) (Just n) r | n > 0 = go z (Just 0) ('-':'z':r) - go ('-':z) _ r = go z (Just 0) ('-':r) - go ('z':z) (Just n) r = go z (Just (n+1)) ('z':r) - go (c:z) _ r = go z Nothing (c:r) - -parseZDashCode :: CabalParsing m => m [String] -parseZDashCode = do - ns <- toList <$> P.sepByNonEmpty (some (P.satisfy (/= '-'))) (P.char '-') - return (go ns) - where - go ns = case break (=="z") ns of - (_, []) -> [paste ns] - (as, "z":bs) -> paste as : go bs - _ -> error "parseZDashCode: go" - unZ :: String -> String - unZ "" = error "parseZDashCode: unZ" - unZ r@('z':zs) | all (=='z') zs = zs - | otherwise = r - unZ r = r - paste :: [String] -> String - paste = intercalate "-" . map unZ - --- $setup --- >>> :seti -XOverloadedStrings diff --git a/src/Distribution/Types/PackageDescription.hs b/src/Distribution/Types/PackageDescription.hs deleted file mode 100644 --- a/src/Distribution/Types/PackageDescription.hs +++ /dev/null @@ -1,457 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} - ------------------------------------------------------------------------------ --- | --- Module : Distribution.Types.PackageDescription --- Copyright : Isaac Jones 2003-2005 --- License : BSD3 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This defines the data structure for the @.cabal@ file format. There are --- several parts to this structure. It has top level info and then 'Library', --- 'Executable', 'TestSuite', and 'Benchmark' sections each of which have --- associated 'BuildInfo' data that's used to build the library, exe, test, or --- benchmark. To further complicate things there is both a 'PackageDescription' --- and a 'GenericPackageDescription'. This distinction relates to cabal --- configurations. When we initially read a @.cabal@ file we get a --- 'GenericPackageDescription' which has all the conditional sections. --- Before actually building a package we have to decide --- on each conditional. Once we've done that we get a 'PackageDescription'. --- It was done this way initially to avoid breaking too much stuff when the --- feature was introduced. It could probably do with being rationalised at some --- point to make it simpler. - -module Distribution.Types.PackageDescription ( - PackageDescription(..), - license, - license', - buildType, - emptyPackageDescription, - hasPublicLib, - hasLibs, - allLibraries, - withLib, - hasExes, - withExe, - hasTests, - withTest, - hasBenchmarks, - withBenchmark, - hasForeignLibs, - withForeignLib, - allBuildInfo, - enabledBuildInfos, - allBuildDepends, - enabledBuildDepends, - updatePackageDescription, - pkgComponents, - pkgBuildableComponents, - enabledComponents, - lookupComponent, - getComponent, - ) where - -import Prelude () -import Distribution.Compat.Prelude - -import Control.Monad ((<=<)) - --- lens -import qualified Distribution.Types.BuildInfo.Lens as L -import Distribution.Types.Library -import Distribution.Types.TestSuite -import Distribution.Types.Executable -import Distribution.Types.Benchmark -import Distribution.Types.ForeignLib - -import Distribution.Types.Component -import Distribution.Types.ComponentRequestedSpec -import Distribution.Types.Dependency -import Distribution.Types.PackageId -import Distribution.Types.ComponentName -import Distribution.Types.PackageName -import Distribution.Types.UnqualComponentName -import Distribution.Types.SetupBuildInfo -import Distribution.Types.BuildInfo -import Distribution.Types.BuildType -import Distribution.Types.SourceRepo -import Distribution.Types.HookedBuildInfo - -import Distribution.CabalSpecVersion -import Distribution.Compiler -import Distribution.License -import Distribution.Package -import Distribution.Version -import Distribution.Utils.Path -import Distribution.Utils.ShortText - -import qualified Distribution.SPDX as SPDX - --- ----------------------------------------------------------------------------- --- The PackageDescription type - --- | This data type is the internal representation of the file @pkg.cabal@. --- It contains two kinds of information about the package: information --- which is needed for all packages, such as the package name and version, and --- information which is needed for the simple build system only, such as --- the compiler options and library name. --- -data PackageDescription - = PackageDescription { - -- the following are required by all packages: - - -- | The version of the Cabal spec that this package description uses. - specVersion :: CabalSpecVersion, - package :: PackageIdentifier, - licenseRaw :: Either SPDX.License License, - licenseFiles :: [SymbolicPath PackageDir LicenseFile], - copyright :: !ShortText, - maintainer :: !ShortText, - author :: !ShortText, - stability :: !ShortText, - testedWith :: [(CompilerFlavor,VersionRange)], - homepage :: !ShortText, - pkgUrl :: !ShortText, - bugReports :: !ShortText, - sourceRepos :: [SourceRepo], - synopsis :: !ShortText, -- ^A one-line summary of this package - description :: !ShortText, -- ^A more verbose description of this package - category :: !ShortText, - customFieldsPD :: [(String,String)], -- ^Custom fields starting - -- with x-, stored in a - -- simple assoc-list. - - -- | The original @build-type@ value as parsed from the - -- @.cabal@ file without defaulting. See also 'buildType'. - -- - -- @since 2.2 - buildTypeRaw :: Maybe BuildType, - setupBuildInfo :: Maybe SetupBuildInfo, - -- components - library :: Maybe Library, - subLibraries :: [Library], - executables :: [Executable], - foreignLibs :: [ForeignLib], - testSuites :: [TestSuite], - benchmarks :: [Benchmark], - -- files - dataFiles :: [FilePath], - dataDir :: FilePath, - extraSrcFiles :: [FilePath], - extraTmpFiles :: [FilePath], - extraDocFiles :: [FilePath] - } - deriving (Generic, Show, Read, Eq, Typeable, Data) - -instance Binary PackageDescription -instance Structured PackageDescription - -instance NFData PackageDescription where rnf = genericRnf - -instance Package PackageDescription where - packageId = package - --- | The SPDX 'LicenseExpression' of the package. --- --- @since 2.2.0.0 -license :: PackageDescription -> SPDX.License -license = license' . licenseRaw - --- | See 'license'. --- --- @since 2.2.0.0 -license' :: Either SPDX.License License -> SPDX.License -license' = either id licenseToSPDX - --- | The effective @build-type@ after applying defaulting rules. --- --- The original @build-type@ value parsed is stored in the --- 'buildTypeRaw' field. However, the @build-type@ field is optional --- and can therefore be empty in which case we need to compute the --- /effective/ @build-type@. This function implements the following --- defaulting rules: --- --- * For @cabal-version:2.0@ and below, default to the @Custom@ --- build-type unconditionally. --- --- * Otherwise, if a @custom-setup@ stanza is defined, default to --- the @Custom@ build-type; else default to @Simple@ build-type. --- --- @since 2.2 -buildType :: PackageDescription -> BuildType -buildType pkg - | specVersion pkg >= CabalSpecV2_2 - = fromMaybe newDefault (buildTypeRaw pkg) - | otherwise -- cabal-version < 2.1 - = fromMaybe Custom (buildTypeRaw pkg) - where - newDefault | isNothing (setupBuildInfo pkg) = Simple - | otherwise = Custom - -emptyPackageDescription :: PackageDescription -emptyPackageDescription - = PackageDescription { - package = PackageIdentifier (mkPackageName "") - nullVersion, - licenseRaw = Right UnspecifiedLicense, -- TODO: - licenseFiles = [], - specVersion = CabalSpecV1_0, - buildTypeRaw = Nothing, - copyright = mempty, - maintainer = mempty, - author = mempty, - stability = mempty, - testedWith = [], - homepage = mempty, - pkgUrl = mempty, - bugReports = mempty, - sourceRepos = [], - synopsis = mempty, - description = mempty, - category = mempty, - customFieldsPD = [], - setupBuildInfo = Nothing, - library = Nothing, - subLibraries = [], - foreignLibs = [], - executables = [], - testSuites = [], - benchmarks = [], - dataFiles = [], - dataDir = ".", - extraSrcFiles = [], - extraTmpFiles = [], - extraDocFiles = [] - } - --- --------------------------------------------------------------------------- --- The Library type - --- | Does this package have a buildable PUBLIC library? -hasPublicLib :: PackageDescription -> Bool -hasPublicLib p = - case library p of - Just lib -> buildable (libBuildInfo lib) - Nothing -> False - --- | Does this package have any libraries? -hasLibs :: PackageDescription -> Bool -hasLibs p = any (buildable . libBuildInfo) (allLibraries p) - -allLibraries :: PackageDescription -> [Library] -allLibraries p = maybeToList (library p) ++ subLibraries p - --- | If the package description has a buildable library section, --- call the given function with the library build info as argument. --- You probably want 'withLibLBI' if you have a 'LocalBuildInfo', --- see the note in --- "Distribution.Types.ComponentRequestedSpec#buildable_vs_enabled_components" --- for more information. -withLib :: PackageDescription -> (Library -> IO ()) -> IO () -withLib pkg_descr f = - sequence_ [f lib | lib <- allLibraries pkg_descr, buildable (libBuildInfo lib)] - --- --------------------------------------------------------------------------- --- The Executable type - --- |does this package have any executables? -hasExes :: PackageDescription -> Bool -hasExes p = any (buildable . buildInfo) (executables p) - --- | Perform the action on each buildable 'Executable' in the package --- description. You probably want 'withExeLBI' if you have a --- 'LocalBuildInfo', see the note in --- "Distribution.Types.ComponentRequestedSpec#buildable_vs_enabled_components" --- for more information. -withExe :: PackageDescription -> (Executable -> IO ()) -> IO () -withExe pkg_descr f = - sequence_ [f exe | exe <- executables pkg_descr, buildable (buildInfo exe)] - --- --------------------------------------------------------------------------- --- The TestSuite type - --- | Does this package have any test suites? -hasTests :: PackageDescription -> Bool -hasTests = any (buildable . testBuildInfo) . testSuites - --- | Perform an action on each buildable 'TestSuite' in a package. --- You probably want 'withTestLBI' if you have a 'LocalBuildInfo', see the note in --- "Distribution.Types.ComponentRequestedSpec#buildable_vs_enabled_components" --- for more information. - -withTest :: PackageDescription -> (TestSuite -> IO ()) -> IO () -withTest pkg_descr f = - sequence_ [ f test | test <- testSuites pkg_descr, buildable (testBuildInfo test) ] - --- --------------------------------------------------------------------------- --- The Benchmark type - --- | Does this package have any benchmarks? -hasBenchmarks :: PackageDescription -> Bool -hasBenchmarks = any (buildable . benchmarkBuildInfo) . benchmarks - --- | Perform an action on each buildable 'Benchmark' in a package. --- You probably want 'withBenchLBI' if you have a 'LocalBuildInfo', see the note in --- "Distribution.Types.ComponentRequestedSpec#buildable_vs_enabled_components" --- for more information. - -withBenchmark :: PackageDescription -> (Benchmark -> IO ()) -> IO () -withBenchmark pkg_descr f = - sequence_ [f bench | bench <- benchmarks pkg_descr, buildable (benchmarkBuildInfo bench)] - --- --------------------------------------------------------------------------- --- The ForeignLib type - --- | Does this package have any foreign libraries? -hasForeignLibs :: PackageDescription -> Bool -hasForeignLibs p = any (buildable . foreignLibBuildInfo) (foreignLibs p) - --- | Perform the action on each buildable 'ForeignLib' in the package --- description. -withForeignLib :: PackageDescription -> (ForeignLib -> IO ()) -> IO () -withForeignLib pkg_descr f = - sequence_ [ f flib - | flib <- foreignLibs pkg_descr - , buildable (foreignLibBuildInfo flib) - ] - --- --------------------------------------------------------------------------- --- The BuildInfo type - --- | All 'BuildInfo' in the 'PackageDescription': --- libraries, executables, test-suites and benchmarks. --- --- Useful for implementing package checks. -allBuildInfo :: PackageDescription -> [BuildInfo] -allBuildInfo pkg_descr = [ bi | lib <- allLibraries pkg_descr - , let bi = libBuildInfo lib ] - ++ [ bi | flib <- foreignLibs pkg_descr - , let bi = foreignLibBuildInfo flib ] - ++ [ bi | exe <- executables pkg_descr - , let bi = buildInfo exe ] - ++ [ bi | tst <- testSuites pkg_descr - , let bi = testBuildInfo tst ] - ++ [ bi | tst <- benchmarks pkg_descr - , let bi = benchmarkBuildInfo tst ] - --- | Return all of the 'BuildInfo's of enabled components, i.e., all of --- the ones that would be built if you run @./Setup build@. -enabledBuildInfos :: PackageDescription -> ComponentRequestedSpec -> [BuildInfo] -enabledBuildInfos pkg enabled = - [ componentBuildInfo comp - | comp <- enabledComponents pkg enabled ] - - --- ------------------------------------------------------------ --- * Utils --- ------------------------------------------------------------ - --- | Get the combined build-depends entries of all components. -allBuildDepends :: PackageDescription -> [Dependency] -allBuildDepends = targetBuildDepends <=< allBuildInfo - --- | Get the combined build-depends entries of all enabled components, per the --- given request spec. -enabledBuildDepends :: PackageDescription -> ComponentRequestedSpec -> [Dependency] -enabledBuildDepends spec pd = targetBuildDepends =<< enabledBuildInfos spec pd - - -updatePackageDescription :: HookedBuildInfo -> PackageDescription -> PackageDescription -updatePackageDescription (mb_lib_bi, exe_bi) p - = p{ executables = updateExecutables exe_bi (executables p) - , library = updateLibrary mb_lib_bi (library p) } - where - updateLibrary :: Maybe BuildInfo -> Maybe Library -> Maybe Library - updateLibrary (Just bi) (Just lib) = Just (lib{libBuildInfo = bi `mappend` libBuildInfo lib}) - updateLibrary Nothing mb_lib = mb_lib - updateLibrary (Just _) Nothing = Nothing - - updateExecutables :: [(UnqualComponentName, BuildInfo)] -- ^[(exeName, new buildinfo)] - -> [Executable] -- ^list of executables to update - -> [Executable] -- ^list with exeNames updated - updateExecutables exe_bi' executables' = foldr updateExecutable executables' exe_bi' - - updateExecutable :: (UnqualComponentName, BuildInfo) -- ^(exeName, new buildinfo) - -> [Executable] -- ^list of executables to update - -> [Executable] -- ^list with exeName updated - updateExecutable _ [] = [] - updateExecutable exe_bi'@(name,bi) (exe:exes) - | exeName exe == name = exe{buildInfo = bi `mappend` buildInfo exe} : exes - | otherwise = exe : updateExecutable exe_bi' exes - --- ----------------------------------------------------------------------------- --- Source-representation of buildable components - --- | All the components in the package. --- -pkgComponents :: PackageDescription -> [Component] -pkgComponents pkg = - [ CLib lib | lib <- allLibraries pkg ] - ++ [ CFLib flib | flib <- foreignLibs pkg ] - ++ [ CExe exe | exe <- executables pkg ] - ++ [ CTest tst | tst <- testSuites pkg ] - ++ [ CBench bm | bm <- benchmarks pkg ] - --- | A list of all components in the package that are buildable, --- i.e., were not marked with @buildable: False@. This does NOT --- indicate if we are actually going to build the component, --- see 'enabledComponents' instead. --- --- @since 2.0.0.2 --- -pkgBuildableComponents :: PackageDescription -> [Component] -pkgBuildableComponents = filter componentBuildable . pkgComponents - --- | A list of all components in the package that are enabled. --- --- @since 2.0.0.2 --- -enabledComponents :: PackageDescription -> ComponentRequestedSpec -> [Component] -enabledComponents pkg enabled = filter (componentEnabled enabled) $ pkgBuildableComponents pkg - -lookupComponent :: PackageDescription -> ComponentName -> Maybe Component -lookupComponent pkg (CLibName name) = - fmap CLib $ find ((name ==) . libName) (allLibraries pkg) -lookupComponent pkg (CFLibName name) = - fmap CFLib $ find ((name ==) . foreignLibName) (foreignLibs pkg) -lookupComponent pkg (CExeName name) = - fmap CExe $ find ((name ==) . exeName) (executables pkg) -lookupComponent pkg (CTestName name) = - fmap CTest $ find ((name ==) . testName) (testSuites pkg) -lookupComponent pkg (CBenchName name) = - fmap CBench $ find ((name ==) . benchmarkName) (benchmarks pkg) - -getComponent :: PackageDescription -> ComponentName -> Component -getComponent pkg cname = - case lookupComponent pkg cname of - Just cpnt -> cpnt - Nothing -> missingComponent - where - missingComponent = - error $ "internal error: the package description contains no " - ++ "component corresponding to " ++ show cname - --- ----------------------------------------------------------------------------- --- Traversal Instances - -instance L.HasBuildInfos PackageDescription where - traverseBuildInfos f (PackageDescription a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 - x1 x2 x3 x4 x5 x6 - a20 a21 a22 a23 a24) = - PackageDescription a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 - <$> (traverse . L.buildInfo) f x1 -- library - <*> (traverse . L.buildInfo) f x2 -- sub libraries - <*> (traverse . L.buildInfo) f x3 -- executables - <*> (traverse . L.buildInfo) f x4 -- foreign libs - <*> (traverse . L.buildInfo) f x5 -- test suites - <*> (traverse . L.buildInfo) f x6 -- benchmarks - <*> pure a20 -- data files - <*> pure a21 -- data dir - <*> pure a22 -- extra src files - <*> pure a23 -- extra temp files - <*> pure a24 -- extra doc files diff --git a/src/Distribution/Types/PackageDescription/Lens.hs b/src/Distribution/Types/PackageDescription/Lens.hs deleted file mode 100644 --- a/src/Distribution/Types/PackageDescription/Lens.hs +++ /dev/null @@ -1,221 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -module Distribution.Types.PackageDescription.Lens ( - PackageDescription, - module Distribution.Types.PackageDescription.Lens, - ) where - -import Distribution.Compat.Lens -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.CabalSpecVersion (CabalSpecVersion) -import Distribution.Compiler (CompilerFlavor) -import Distribution.License (License) -import Distribution.ModuleName (ModuleName) -import Distribution.Types.Benchmark (Benchmark, benchmarkModules) -import Distribution.Types.Benchmark.Lens (benchmarkBuildInfo, benchmarkName) -import Distribution.Types.BuildInfo (BuildInfo) -import Distribution.Types.BuildType (BuildType) -import Distribution.Types.ComponentName (ComponentName (..)) -import Distribution.Types.Executable (Executable, exeModules) -import Distribution.Types.Executable.Lens (exeBuildInfo, exeName) -import Distribution.Types.ForeignLib (ForeignLib, foreignLibModules) -import Distribution.Types.ForeignLib.Lens (foreignLibBuildInfo, foreignLibName) -import Distribution.Types.Library (Library, explicitLibModules) -import Distribution.Types.Library.Lens (libBuildInfo, libName) -import Distribution.Types.PackageDescription (PackageDescription) -import Distribution.Types.PackageId (PackageIdentifier) -import Distribution.Types.SetupBuildInfo (SetupBuildInfo) -import Distribution.Types.SourceRepo (SourceRepo) -import Distribution.Types.TestSuite (TestSuite, testModules) -import Distribution.Types.TestSuite.Lens (testBuildInfo, testName) -import Distribution.Utils.Path (LicenseFile, PackageDir, SymbolicPath) -import Distribution.Utils.ShortText (ShortText) -import Distribution.Version (VersionRange) - -import qualified Distribution.SPDX as SPDX -import qualified Distribution.Types.PackageDescription as T - -package :: Lens' PackageDescription PackageIdentifier -package f s = fmap (\x -> s { T.package = x }) (f (T.package s)) -{-# INLINE package #-} - -licenseRaw :: Lens' PackageDescription (Either SPDX.License License) -licenseRaw f s = fmap (\x -> s { T.licenseRaw = x }) (f (T.licenseRaw s)) -{-# INLINE licenseRaw #-} - -licenseFiles :: Lens' PackageDescription [SymbolicPath PackageDir LicenseFile] -licenseFiles f s = fmap (\x -> s { T.licenseFiles = x }) (f (T.licenseFiles s)) -{-# INLINE licenseFiles #-} - -copyright :: Lens' PackageDescription ShortText -copyright f s = fmap (\x -> s { T.copyright = x }) (f (T.copyright s)) -{-# INLINE copyright #-} - -maintainer :: Lens' PackageDescription ShortText -maintainer f s = fmap (\x -> s { T.maintainer = x }) (f (T.maintainer s)) -{-# INLINE maintainer #-} - -author :: Lens' PackageDescription ShortText -author f s = fmap (\x -> s { T.author = x }) (f (T.author s)) -{-# INLINE author #-} - -stability :: Lens' PackageDescription ShortText -stability f s = fmap (\x -> s { T.stability = x }) (f (T.stability s)) -{-# INLINE stability #-} - -testedWith :: Lens' PackageDescription [(CompilerFlavor,VersionRange)] -testedWith f s = fmap (\x -> s { T.testedWith = x }) (f (T.testedWith s)) -{-# INLINE testedWith #-} - -homepage :: Lens' PackageDescription ShortText -homepage f s = fmap (\x -> s { T.homepage = x }) (f (T.homepage s)) -{-# INLINE homepage #-} - -pkgUrl :: Lens' PackageDescription ShortText -pkgUrl f s = fmap (\x -> s { T.pkgUrl = x }) (f (T.pkgUrl s)) -{-# INLINE pkgUrl #-} - -bugReports :: Lens' PackageDescription ShortText -bugReports f s = fmap (\x -> s { T.bugReports = x }) (f (T.bugReports s)) -{-# INLINE bugReports #-} - -sourceRepos :: Lens' PackageDescription [SourceRepo] -sourceRepos f s = fmap (\x -> s { T.sourceRepos = x }) (f (T.sourceRepos s)) -{-# INLINE sourceRepos #-} - -synopsis :: Lens' PackageDescription ShortText -synopsis f s = fmap (\x -> s { T.synopsis = x }) (f (T.synopsis s)) -{-# INLINE synopsis #-} - -description :: Lens' PackageDescription ShortText -description f s = fmap (\x -> s { T.description = x }) (f (T.description s)) -{-# INLINE description #-} - -category :: Lens' PackageDescription ShortText -category f s = fmap (\x -> s { T.category = x }) (f (T.category s)) -{-# INLINE category #-} - -customFieldsPD :: Lens' PackageDescription [(String,String)] -customFieldsPD f s = fmap (\x -> s { T.customFieldsPD = x }) (f (T.customFieldsPD s)) -{-# INLINE customFieldsPD #-} - -specVersion :: Lens' PackageDescription CabalSpecVersion -specVersion f s = fmap (\x -> s { T.specVersion = x }) (f (T.specVersion s)) -{-# INLINE specVersion #-} - -buildTypeRaw :: Lens' PackageDescription (Maybe BuildType) -buildTypeRaw f s = fmap (\x -> s { T.buildTypeRaw = x }) (f (T.buildTypeRaw s)) -{-# INLINE buildTypeRaw #-} - -setupBuildInfo :: Lens' PackageDescription (Maybe SetupBuildInfo) -setupBuildInfo f s = fmap (\x -> s { T.setupBuildInfo = x }) (f (T.setupBuildInfo s)) -{-# INLINE setupBuildInfo #-} - -library :: Lens' PackageDescription (Maybe Library) -library f s = fmap (\x -> s { T.library = x }) (f (T.library s)) -{-# INLINE library #-} - -subLibraries :: Lens' PackageDescription [Library] -subLibraries f s = fmap (\x -> s { T.subLibraries = x }) (f (T.subLibraries s)) -{-# INLINE subLibraries #-} - -executables :: Lens' PackageDescription [Executable] -executables f s = fmap (\x -> s { T.executables = x }) (f (T.executables s)) -{-# INLINE executables #-} - -foreignLibs :: Lens' PackageDescription [ForeignLib] -foreignLibs f s = fmap (\x -> s { T.foreignLibs = x }) (f (T.foreignLibs s)) -{-# INLINE foreignLibs #-} - -testSuites :: Lens' PackageDescription [TestSuite] -testSuites f s = fmap (\x -> s { T.testSuites = x }) (f (T.testSuites s)) -{-# INLINE testSuites #-} - -benchmarks :: Lens' PackageDescription [Benchmark] -benchmarks f s = fmap (\x -> s { T.benchmarks = x }) (f (T.benchmarks s)) -{-# INLINE benchmarks #-} - -dataFiles :: Lens' PackageDescription [FilePath] -dataFiles f s = fmap (\x -> s { T.dataFiles = x }) (f (T.dataFiles s)) -{-# INLINE dataFiles #-} - -dataDir :: Lens' PackageDescription FilePath -dataDir f s = fmap (\x -> s { T.dataDir = x }) (f (T.dataDir s)) -{-# INLINE dataDir #-} - -extraSrcFiles :: Lens' PackageDescription [String] -extraSrcFiles f s = fmap (\x -> s { T.extraSrcFiles = x }) (f (T.extraSrcFiles s)) -{-# INLINE extraSrcFiles #-} - -extraTmpFiles :: Lens' PackageDescription [String] -extraTmpFiles f s = fmap (\x -> s { T.extraTmpFiles = x }) (f (T.extraTmpFiles s)) -{-# INLINE extraTmpFiles #-} - -extraDocFiles :: Lens' PackageDescription [String] -extraDocFiles f s = fmap (\x -> s { T.extraDocFiles = x }) (f (T.extraDocFiles s)) -{-# INLINE extraDocFiles #-} - --- | @since 3.0.0.0 -allLibraries :: Traversal' PackageDescription Library -allLibraries f pd = mk <$> traverse f (T.library pd) <*> traverse f (T.subLibraries pd) - where - mk l ls = pd { T.library = l, T.subLibraries = ls } - --- | @since 2.4 -componentModules :: Monoid r => ComponentName -> Getting r PackageDescription [ModuleName] -componentModules cname = case cname of - CLibName name -> - componentModules' name allLibraries libName explicitLibModules - CFLibName name -> - componentModules' name (foreignLibs . traverse) foreignLibName foreignLibModules - CExeName name -> - componentModules' name (executables . traverse) exeName exeModules - CTestName name -> - componentModules' name (testSuites . traverse) testName testModules - CBenchName name -> - componentModules' name (benchmarks . traverse) benchmarkName benchmarkModules - where - componentModules' - :: (Eq name, Monoid r) - => name - -> Traversal' PackageDescription a - -> Lens' a name - -> (a -> [ModuleName]) - -> Getting r PackageDescription [ModuleName] - componentModules' name pdL nameL modules = - pdL - . filtered ((== name) . view nameL) - . getting modules - - filtered :: (a -> Bool) -> Traversal' a a - filtered p f s = if p s then f s else pure s - --- | @since 2.4 -componentBuildInfo :: ComponentName -> Traversal' PackageDescription BuildInfo -componentBuildInfo cname = case cname of - CLibName name -> - componentBuildInfo' name allLibraries libName libBuildInfo - CFLibName name -> - componentBuildInfo' name (foreignLibs . traverse) foreignLibName foreignLibBuildInfo - CExeName name -> - componentBuildInfo' name (executables . traverse) exeName exeBuildInfo - CTestName name -> - componentBuildInfo' name (testSuites . traverse) testName testBuildInfo - CBenchName name -> - componentBuildInfo' name (benchmarks . traverse) benchmarkName benchmarkBuildInfo - where - componentBuildInfo' :: Eq name - => name - -> Traversal' PackageDescription a - -> Lens' a name - -> Traversal' a BuildInfo - -> Traversal' PackageDescription BuildInfo - componentBuildInfo' name pdL nameL biL = - pdL - . filtered ((== name) . view nameL) - . biL - - filtered :: (a -> Bool) -> Traversal' a a - filtered p f s = if p s then f s else pure s diff --git a/src/Distribution/Types/PackageId.hs b/src/Distribution/Types/PackageId.hs deleted file mode 100644 --- a/src/Distribution/Types/PackageId.hs +++ /dev/null @@ -1,74 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Types.PackageId - ( PackageIdentifier(..) - , PackageId - ) where - -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Parsec (Parsec (..), simpleParsec) -import Distribution.Pretty -import Distribution.Types.PackageName -import Distribution.Version (Version, nullVersion) - -import qualified Data.List.NonEmpty as NE -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp - --- | Type alias so we can use the shorter name PackageId. -type PackageId = PackageIdentifier - --- | The name and version of a package. -data PackageIdentifier - = PackageIdentifier { - pkgName :: PackageName, -- ^The name of this package, eg. foo - pkgVersion :: Version -- ^the version of this package, eg 1.2 - } - deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) - -instance Binary PackageIdentifier -instance Structured PackageIdentifier - -instance Pretty PackageIdentifier where - pretty (PackageIdentifier n v) - | v == nullVersion = pretty n -- if no version, don't show version. - | otherwise = pretty n <<>> Disp.char '-' <<>> pretty v - --- | --- --- >>> simpleParsec "foo-bar-0" :: Maybe PackageIdentifier --- Just (PackageIdentifier {pkgName = PackageName "foo-bar", pkgVersion = mkVersion [0]}) --- --- >>> simpleParsec "foo-bar" :: Maybe PackageIdentifier --- Just (PackageIdentifier {pkgName = PackageName "foo-bar", pkgVersion = mkVersion []}) --- --- /Note:/ Stricter than 'Text' instance --- --- >>> simpleParsec "foo-bar-0-0" :: Maybe PackageIdentifier --- Nothing --- --- >>> simpleParsec "foo-bar.0" :: Maybe PackageIdentifier --- Nothing --- --- >>> simpleParsec "foo-bar.4-2" :: Maybe PackageIdentifier --- Nothing --- --- >>> simpleParsec "1.2.3" :: Maybe PackageIdentifier --- Nothing --- -instance Parsec PackageIdentifier where - parsec = do - xs' <- P.sepByNonEmpty component (P.char '-') - (v, xs) <- case simpleParsec (NE.last xs') of - Nothing -> return (nullVersion, toList xs') -- all components are version - Just v -> return (v, NE.init xs') - if not (null xs) && all (\c -> all (/= '.') c && not (all isDigit c)) xs - then return $ PackageIdentifier (mkPackageName (intercalate "-" xs)) v - else fail "all digits or a dot in a portion of package name" - where - component = P.munch1 (\c -> isAlphaNum c || c == '.') - -instance NFData PackageIdentifier where - rnf (PackageIdentifier name version) = rnf name `seq` rnf version diff --git a/src/Distribution/Types/PackageId/Lens.hs b/src/Distribution/Types/PackageId/Lens.hs deleted file mode 100644 --- a/src/Distribution/Types/PackageId/Lens.hs +++ /dev/null @@ -1,22 +0,0 @@ -module Distribution.Types.PackageId.Lens ( - PackageIdentifier, - module Distribution.Types.PackageId.Lens, - ) where - -import Distribution.Compat.Lens -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Types.PackageId (PackageIdentifier) -import Distribution.Types.PackageName (PackageName) -import Distribution.Version (Version) - -import qualified Distribution.Types.PackageId as T - -pkgName :: Lens' PackageIdentifier PackageName -pkgName f s = fmap (\x -> s { T.pkgName = x }) (f (T.pkgName s)) -{-# INLINE pkgName #-} - -pkgVersion :: Lens' PackageIdentifier Version -pkgVersion f s = fmap (\x -> s { T.pkgVersion = x }) (f (T.pkgVersion s)) -{-# INLINE pkgVersion #-} diff --git a/src/Distribution/Types/PackageName.hs b/src/Distribution/Types/PackageName.hs deleted file mode 100644 --- a/src/Distribution/Types/PackageName.hs +++ /dev/null @@ -1,73 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Types.PackageName - ( PackageName - , unPackageName, mkPackageName - , unPackageNameST, mkPackageNameST - ) where - -import Prelude () -import Distribution.Compat.Prelude -import Distribution.Utils.ShortText - -import qualified Text.PrettyPrint as Disp -import Distribution.Pretty -import Distribution.Parsec - --- | A package name. --- --- Use 'mkPackageName' and 'unPackageName' to convert from/to a --- 'String'. --- --- This type is opaque since @Cabal-2.0@ --- --- @since 2.0.0.2 -newtype PackageName = PackageName ShortText - deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) - --- | Convert 'PackageName' to 'String' -unPackageName :: PackageName -> String -unPackageName (PackageName s) = fromShortText s - --- | @since 3.4.0.0 -unPackageNameST :: PackageName -> ShortText -unPackageNameST (PackageName s) = s - --- | Construct a 'PackageName' from a 'String' --- --- 'mkPackageName' is the inverse to 'unPackageName' --- --- Note: No validations are performed to ensure that the resulting --- 'PackageName' is valid --- --- @since 2.0.0.2 -mkPackageName :: String -> PackageName -mkPackageName = PackageName . toShortText - --- | Construct a 'PackageName' from a 'ShortText' --- --- Note: No validations are performed to ensure that the resulting --- 'PackageName' is valid --- --- @since 3.4.0.0 -mkPackageNameST :: ShortText -> PackageName -mkPackageNameST = PackageName - --- | 'mkPackageName' --- --- @since 2.0.0.2 -instance IsString PackageName where - fromString = mkPackageName - -instance Binary PackageName -instance Structured PackageName - -instance Pretty PackageName where - pretty = Disp.text . unPackageName - -instance Parsec PackageName where - parsec = mkPackageName <$> parsecUnqualComponentName - -instance NFData PackageName where - rnf (PackageName pkg) = rnf pkg diff --git a/src/Distribution/Types/PackageName/Magic.hs b/src/Distribution/Types/PackageName/Magic.hs --- a/src/Distribution/Types/PackageName/Magic.hs +++ b/src/Distribution/Types/PackageName/Magic.hs @@ -11,9 +11,13 @@ nonExistentPackageThisIsCabalBug :: PackageName nonExistentPackageThisIsCabalBug = mkPackageName "nonexistent-package-this-is-a-cabal-bug" --- | Used by @cabal new-repl@ and @cabal new-run@ +-- | Used by @cabal new-repl@, @cabal new-run@ and @cabal new-build@ fakePackageName :: PackageName fakePackageName = mkPackageName "fake-package" + +-- | Used by @cabal new-run@ and @cabal new-build@ +fakePackageCabalFileName :: FilePath +fakePackageCabalFileName = "fake-package.cabal" -- | 'fakePackageName' with 'version0'. fakePackageId :: PackageId diff --git a/src/Distribution/Types/PackageVersionConstraint.hs b/src/Distribution/Types/PackageVersionConstraint.hs deleted file mode 100644 --- a/src/Distribution/Types/PackageVersionConstraint.hs +++ /dev/null @@ -1,74 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Types.PackageVersionConstraint ( - PackageVersionConstraint(..), - thisPackageVersionConstraint, - simplifyPackageVersionConstraint, -) where - -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Parsec -import Distribution.Pretty -import Distribution.Types.PackageId -import Distribution.Types.PackageName -import Distribution.Types.Version -import Distribution.Types.VersionRange.Internal -import Distribution.Version (simplifyVersionRange) - -import qualified Distribution.Compat.CharParsing as P - --- | A version constraint on a package. Different from 'ExeDependency' and --- 'Dependency' since it does not specify the need for a component, not even --- the main library. --- There are a few places in the codebase where 'Dependency' was used where --- 'PackageVersionConstraint' is not used instead (#5570). -data PackageVersionConstraint = PackageVersionConstraint PackageName VersionRange - deriving (Generic, Read, Show, Eq, Typeable, Data) - -instance Binary PackageVersionConstraint -instance Structured PackageVersionConstraint -instance NFData PackageVersionConstraint where rnf = genericRnf - -instance Pretty PackageVersionConstraint where - -- Cannot do: PackageVersionConstraint have to be parseable - -- as Dependency, due roundtrip problems. (e.g. talking to old ./Setup). - -- - -- pretty (PackageVersionConstraint name (ThisVersion ver)) = - -- pretty (PackageIdentifier name ver) - pretty (PackageVersionConstraint name ver) = - pretty name <+> pretty ver - --- | --- --- >>> simpleParsec "foo" :: Maybe PackageVersionConstraint --- Just (PackageVersionConstraint (PackageName "foo") (OrLaterVersion (mkVersion [0]))) --- --- >>> simpleParsec "foo >=2.0" :: Maybe PackageVersionConstraint --- Just (PackageVersionConstraint (PackageName "foo") (OrLaterVersion (mkVersion [2,0]))) --- --- >>> simpleParsec "foo-2.0" :: Maybe PackageVersionConstraint --- Just (PackageVersionConstraint (PackageName "foo") (ThisVersion (mkVersion [2,0]))) --- -instance Parsec PackageVersionConstraint where - parsec = do - PackageIdentifier name ver <- parsec - if ver == nullVersion - then do - P.spaces - vr <- parsec <|> return anyVersion - P.spaces - return (PackageVersionConstraint name vr) - else - pure (PackageVersionConstraint name (thisVersion ver)) - --- | @since 3.4.0.0 -thisPackageVersionConstraint :: PackageIdentifier -> PackageVersionConstraint -thisPackageVersionConstraint (PackageIdentifier pn vr) = - PackageVersionConstraint pn (thisVersion vr) - --- | @since 3.4.0.0 -simplifyPackageVersionConstraint :: PackageVersionConstraint -> PackageVersionConstraint -simplifyPackageVersionConstraint (PackageVersionConstraint pn vr) = - PackageVersionConstraint pn (simplifyVersionRange vr) diff --git a/src/Distribution/Types/PkgconfigDependency.hs b/src/Distribution/Types/PkgconfigDependency.hs deleted file mode 100644 --- a/src/Distribution/Types/PkgconfigDependency.hs +++ /dev/null @@ -1,39 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Types.PkgconfigDependency - ( PkgconfigDependency(..) - ) where - -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Types.PkgconfigName -import Distribution.Types.PkgconfigVersionRange - -import Distribution.Parsec -import Distribution.Pretty - -import qualified Distribution.Compat.CharParsing as P - --- | Describes a dependency on a pkg-config library --- --- @since 2.0.0.2 -data PkgconfigDependency = PkgconfigDependency - PkgconfigName - PkgconfigVersionRange - deriving (Generic, Read, Show, Eq, Typeable, Data) - -instance Binary PkgconfigDependency -instance Structured PkgconfigDependency -instance NFData PkgconfigDependency where rnf = genericRnf - -instance Pretty PkgconfigDependency where - pretty (PkgconfigDependency name PcAnyVersion) = pretty name - pretty (PkgconfigDependency name ver) = pretty name <+> pretty ver - -instance Parsec PkgconfigDependency where - parsec = do - name <- parsec - P.spaces - verRange <- parsec <|> pure anyPkgconfigVersion - pure $ PkgconfigDependency name verRange diff --git a/src/Distribution/Types/PkgconfigName.hs b/src/Distribution/Types/PkgconfigName.hs deleted file mode 100644 --- a/src/Distribution/Types/PkgconfigName.hs +++ /dev/null @@ -1,68 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Types.PkgconfigName - ( PkgconfigName, unPkgconfigName, mkPkgconfigName - ) where - -import Prelude () -import Distribution.Compat.Prelude -import Distribution.Utils.ShortText - -import Distribution.Pretty -import Distribution.Parsec - -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp - --- | A pkg-config library name --- --- This is parsed as any valid argument to the pkg-config utility. --- --- @since 2.0.0.2 -newtype PkgconfigName = PkgconfigName ShortText - deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) - --- | Convert 'PkgconfigName' to 'String' --- --- @since 2.0.0.2 -unPkgconfigName :: PkgconfigName -> String -unPkgconfigName (PkgconfigName s) = fromShortText s - --- | Construct a 'PkgconfigName' from a 'String' --- --- 'mkPkgconfigName' is the inverse to 'unPkgconfigName' --- --- Note: No validations are performed to ensure that the resulting --- 'PkgconfigName' is valid --- --- @since 2.0.0.2 -mkPkgconfigName :: String -> PkgconfigName -mkPkgconfigName = PkgconfigName . toShortText - --- | 'mkPkgconfigName' --- --- @since 2.0.0.2 -instance IsString PkgconfigName where - fromString = mkPkgconfigName - -instance Binary PkgconfigName -instance Structured PkgconfigName - --- pkg-config allows versions and other letters in package names, eg --- "gtk+-2.0" is a valid pkg-config package _name_. It then has a package --- version number like 2.10.13 -instance Pretty PkgconfigName where - pretty = Disp.text . unPkgconfigName - -instance Parsec PkgconfigName where - parsec = mkPkgconfigName <$> P.munch1 isNameChar where - -- https://gitlab.haskell.org/ghc/ghc/issues/17752 - isNameChar '-' = True - isNameChar '_' = True - isNameChar '.' = True - isNameChar '+' = True - isNameChar c = isAlphaNum c - -instance NFData PkgconfigName where - rnf (PkgconfigName pkg) = rnf pkg diff --git a/src/Distribution/Types/PkgconfigVersion.hs b/src/Distribution/Types/PkgconfigVersion.hs deleted file mode 100644 --- a/src/Distribution/Types/PkgconfigVersion.hs +++ /dev/null @@ -1,119 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} --- @since 3.0 -module Distribution.Types.PkgconfigVersion ( - PkgconfigVersion (..), - rpmvercmp, - ) where - -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Parsec -import Distribution.Pretty -import Distribution.Utils.Generic (isAsciiAlphaNum) - -import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as BS8 -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as PP - --- | @pkg-config@ versions. --- --- In fact, this can be arbitrary 'BS.ByteString', --- but 'Parsec' instance is a little pickier. --- --- @since 3.0 -newtype PkgconfigVersion = PkgconfigVersion BS.ByteString - deriving (Generic, Read, Show, Typeable, Data) - -instance Eq PkgconfigVersion where - PkgconfigVersion a == PkgconfigVersion b = rpmvercmp a b == EQ - -instance Ord PkgconfigVersion where - PkgconfigVersion a `compare` PkgconfigVersion b = rpmvercmp a b - -instance Binary PkgconfigVersion -instance Structured PkgconfigVersion -instance NFData PkgconfigVersion where rnf = genericRnf - -instance Pretty PkgconfigVersion where - pretty (PkgconfigVersion bs) = PP.text (BS8.unpack bs) - --- | --- --- >>> simpleParsec "1.0.2n" :: Maybe PkgconfigVersion --- Just (PkgconfigVersion "1.0.2n") --- --- >>> simpleParsec "0.3.5+ds" :: Maybe PkgconfigVersion --- Nothing --- -instance Parsec PkgconfigVersion where - parsec = PkgconfigVersion . BS8.pack <$> P.munch1 predicate where - predicate c = isAsciiAlphaNum c || c == '.' || c == '-' - -------------------------------------------------------------------------------- --- rmpvercmp - pure Haskell implementation -------------------------------------------------------------------------------- - --- | Compare two version strings as @pkg-config@ would compare them. --- --- @since 3.0 -rpmvercmp :: BS.ByteString -> BS.ByteString -> Ordering -rpmvercmp a b = go0 (BS.unpack a) (BS.unpack b) - where - go0 :: [Word8] -> [Word8] -> Ordering - -- if there is _any_ trailing "garbage", it seems to affect result - -- https://github.com/haskell/cabal/issues/6805 - go0 [] [] = EQ - go0 [] _ = LT - go0 _ [] = GT - go0 xs ys = go1 (dropNonAlnum8 xs) (dropNonAlnum8 ys) - - go1 :: [Word8] -> [Word8] -> Ordering - go1 [] [] = EQ - go1 [] _ = LT - go1 _ [] = GT - go1 xs@(x:_) ys - | isDigit8 x = - let (xs1, xs2) = span isDigit8 xs - (ys1, ys2) = span isDigit8 ys - -- numeric segments are always newer than alpha segments - in if null ys1 - then GT - else compareInt xs1 ys1 <> go0 xs2 ys2 - - -- isAlpha - | otherwise = - let (xs1, xs2) = span isAlpha8 xs - (ys1, ys2) = span isAlpha8 ys - in if null ys1 - then LT - else compareStr xs1 ys1 <> go0 xs2 ys2 - --- compare as numbers -compareInt :: [Word8] -> [Word8] -> Ordering -compareInt xs ys = - -- whichever number has more digits wins - compare (length xs') (length ys') <> - -- equal length: use per character compare, "strcmp" - compare xs' ys' - where - -- drop leading zeros - xs' = dropWhile (== 0x30) xs - ys' = dropWhile (== 0x30) ys - --- strcmp -compareStr :: [Word8] -> [Word8] -> Ordering -compareStr = compare - -dropNonAlnum8 :: [Word8] -> [Word8] -dropNonAlnum8 = dropWhile (\w -> not (isDigit8 w || isAlpha8 w)) - -isDigit8 :: Word8 -> Bool -isDigit8 w = 0x30 <= w && w <= 0x39 - -isAlpha8 :: Word8 -> Bool -isAlpha8 w = (0x41 <= w && w <= 0x5A) || (0x61 <= w && w <= 0x7A) - - diff --git a/src/Distribution/Types/PkgconfigVersionRange.hs b/src/Distribution/Types/PkgconfigVersionRange.hs deleted file mode 100644 --- a/src/Distribution/Types/PkgconfigVersionRange.hs +++ /dev/null @@ -1,161 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Types.PkgconfigVersionRange ( - PkgconfigVersionRange (..), - anyPkgconfigVersion, - isAnyPkgconfigVersion, - withinPkgconfigVersionRange, - -- * Internal - versionToPkgconfigVersion, - versionRangeToPkgconfigVersionRange, - ) where - -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.CabalSpecVersion -import Distribution.Parsec -import Distribution.Pretty -import Distribution.Types.PkgconfigVersion -import Distribution.Types.Version -import Distribution.Types.VersionInterval -import Distribution.Types.VersionRange - -import qualified Data.ByteString.Char8 as BS8 -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as PP - --- | @since 3.0 -data PkgconfigVersionRange - = PcAnyVersion - | PcThisVersion PkgconfigVersion -- = version - | PcLaterVersion PkgconfigVersion -- > version (NB. not >=) - | PcEarlierVersion PkgconfigVersion -- < version - | PcOrLaterVersion PkgconfigVersion -- >= version - | PcOrEarlierVersion PkgconfigVersion -- =< version - | PcUnionVersionRanges PkgconfigVersionRange PkgconfigVersionRange - | PcIntersectVersionRanges PkgconfigVersionRange PkgconfigVersionRange - deriving (Generic, Read, Show, Eq, Typeable, Data) - -instance Binary PkgconfigVersionRange -instance Structured PkgconfigVersionRange -instance NFData PkgconfigVersionRange where rnf = genericRnf - -instance Pretty PkgconfigVersionRange where - pretty = pp 0 where - pp :: Int -> PkgconfigVersionRange -> PP.Doc - pp _ PcAnyVersion = PP.text "-any" - pp _ (PcThisVersion v) = PP.text "==" <<>> pretty v - pp _ (PcLaterVersion v) = PP.text ">" <<>> pretty v - pp _ (PcEarlierVersion v) = PP.text "<" <<>> pretty v - pp _ (PcOrLaterVersion v) = PP.text ">=" <<>> pretty v - pp _ (PcOrEarlierVersion v) = PP.text "<=" <<>> pretty v - - pp d (PcUnionVersionRanges v u) = parens (d >= 1) $ - pp 1 v PP.<+> PP.text "||" PP.<+> pp 0 u - pp d (PcIntersectVersionRanges v u) = parens (d >= 2) $ - pp 2 v PP.<+> PP.text "&&" PP.<+> pp 1 u - - parens True = PP.parens - parens False = id - -instance Parsec PkgconfigVersionRange where - -- note: the wildcard is used in some places, e.g - -- http://hackage.haskell.org/package/bindings-libzip-0.10.1/bindings-libzip.cabal - -- - -- however, in the presence of alphanumerics etc. lax version parser, - -- wildcard is ill-specified - - parsec = do - csv <- askCabalSpecVersion - if csv >= CabalSpecV3_0 - then pkgconfigParser - else versionRangeToPkgconfigVersionRange <$> versionRangeParser P.integral csv - --- "modern" parser of @pkg-config@ package versions. -pkgconfigParser :: CabalParsing m => m PkgconfigVersionRange -pkgconfigParser = P.spaces >> expr where - -- every parser here eats trailing space - expr = do - ts <- term `P.sepByNonEmpty` (P.string "||" >> P.spaces) - return $ foldr1 PcUnionVersionRanges ts - - term = do - fs <- factor `P.sepByNonEmpty` (P.string "&&" >> P.spaces) - return $ foldr1 PcIntersectVersionRanges fs - - factor = parens expr <|> prim - - prim = do - op <- P.munch1 isOpChar P. "operator" - case op of - "-" -> anyPkgconfigVersion <$ (P.string "any" *> P.spaces) - - "==" -> afterOp PcThisVersion - ">" -> afterOp PcLaterVersion - "<" -> afterOp PcEarlierVersion - ">=" -> afterOp PcOrLaterVersion - "<=" -> afterOp PcOrEarlierVersion - - _ -> P.unexpected $ "Unknown version operator " ++ show op - - -- https://gitlab.haskell.org/ghc/ghc/issues/17752 - isOpChar '<' = True - isOpChar '=' = True - isOpChar '>' = True - isOpChar '^' = True - isOpChar '-' = True - isOpChar _ = False - - afterOp f = do - P.spaces - v <- parsec - P.spaces - return (f v) - - parens = P.between - ((P.char '(' P. "opening paren") >> P.spaces) - (P.char ')' >> P.spaces) - -anyPkgconfigVersion :: PkgconfigVersionRange -anyPkgconfigVersion = PcAnyVersion - --- | TODO: this is not precise, but used only to prettify output. -isAnyPkgconfigVersion :: PkgconfigVersionRange -> Bool -isAnyPkgconfigVersion = (== PcAnyVersion) - -withinPkgconfigVersionRange :: PkgconfigVersion -> PkgconfigVersionRange -> Bool -withinPkgconfigVersionRange v = go where - go PcAnyVersion = True - go (PcThisVersion u) = v == u - go (PcLaterVersion u) = v > u - go (PcEarlierVersion u) = v < u - go (PcOrLaterVersion u) = v >= u - go (PcOrEarlierVersion u) = v <= u - go (PcUnionVersionRanges a b) = go a || go b - go (PcIntersectVersionRanges a b) = go a && go b - -------------------------------------------------------------------------------- --- Conversion -------------------------------------------------------------------------------- - -versionToPkgconfigVersion :: Version -> PkgconfigVersion -versionToPkgconfigVersion = PkgconfigVersion . BS8.pack . prettyShow - -versionRangeToPkgconfigVersionRange :: VersionRange -> PkgconfigVersionRange -versionRangeToPkgconfigVersionRange vr - | isAnyVersion vr - = PcAnyVersion - | otherwise - = case asVersionIntervals vr of - [] -> PcEarlierVersion (PkgconfigVersion (BS8.pack "0")) - (i:is) -> foldl (\r j -> PcUnionVersionRanges r (conv j)) (conv i) is - where - conv (VersionInterval (LowerBound v b) NoUpperBound) = convL v b - conv (VersionInterval (LowerBound v b) (UpperBound u c)) = PcIntersectVersionRanges (convL v b) (convU u c) - - convL v ExclusiveBound = PcLaterVersion (versionToPkgconfigVersion v) - convL v InclusiveBound = PcOrLaterVersion (versionToPkgconfigVersion v) - - convU v ExclusiveBound = PcEarlierVersion (versionToPkgconfigVersion v) - convU v InclusiveBound = PcOrEarlierVersion (versionToPkgconfigVersion v) diff --git a/src/Distribution/Types/SetupBuildInfo.hs b/src/Distribution/Types/SetupBuildInfo.hs deleted file mode 100644 --- a/src/Distribution/Types/SetupBuildInfo.hs +++ /dev/null @@ -1,41 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} - -module Distribution.Types.SetupBuildInfo ( - SetupBuildInfo(..) -) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Types.Dependency - --- --------------------------------------------------------------------------- --- The SetupBuildInfo type - --- One can see this as a very cut-down version of BuildInfo below. --- To keep things simple for tools that compile Setup.hs we limit the --- options authors can specify to just Haskell package dependencies. - -data SetupBuildInfo = SetupBuildInfo - { setupDepends :: [Dependency] - , defaultSetupDepends :: Bool - -- ^ Is this a default 'custom-setup' section added by the cabal-install - -- code (as opposed to user-provided)? This field is only used - -- internally, and doesn't correspond to anything in the .cabal - -- file. See #3199. - } - deriving (Generic, Show, Eq, Read, Typeable, Data) - -instance Binary SetupBuildInfo -instance Structured SetupBuildInfo -instance NFData SetupBuildInfo where rnf = genericRnf - -instance Monoid SetupBuildInfo where - mempty = SetupBuildInfo [] False - mappend = (<>) - -instance Semigroup SetupBuildInfo where - a <> b = SetupBuildInfo - (setupDepends a <> setupDepends b) - (defaultSetupDepends a || defaultSetupDepends b) diff --git a/src/Distribution/Types/SetupBuildInfo/Lens.hs b/src/Distribution/Types/SetupBuildInfo/Lens.hs deleted file mode 100644 --- a/src/Distribution/Types/SetupBuildInfo/Lens.hs +++ /dev/null @@ -1,21 +0,0 @@ -module Distribution.Types.SetupBuildInfo.Lens ( - SetupBuildInfo, - module Distribution.Types.SetupBuildInfo.Lens, - ) where - -import Distribution.Compat.Lens -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Types.Dependency (Dependency) -import Distribution.Types.SetupBuildInfo (SetupBuildInfo) - -import qualified Distribution.Types.SetupBuildInfo as T - -setupDepends :: Lens' SetupBuildInfo [Dependency] -setupDepends f s = fmap (\x -> s { T.setupDepends = x }) (f (T.setupDepends s)) -{-# INLINE setupDepends #-} - -defaultSetupDepends :: Lens' SetupBuildInfo Bool -defaultSetupDepends f s = fmap (\x -> s { T.defaultSetupDepends = x }) (f (T.defaultSetupDepends s)) -{-# INLINE defaultSetupDepends #-} diff --git a/src/Distribution/Types/SourceRepo.hs b/src/Distribution/Types/SourceRepo.hs deleted file mode 100644 --- a/src/Distribution/Types/SourceRepo.hs +++ /dev/null @@ -1,201 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} - -module Distribution.Types.SourceRepo ( - SourceRepo(..), - RepoKind(..), - RepoType(..), - KnownRepoType (..), - knownRepoTypes, - emptySourceRepo, - classifyRepoType, - classifyRepoKind, - ) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Utils.Generic (lowercase) - -import Distribution.Pretty -import Distribution.Parsec - -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp -import qualified Data.Map.Strict as M - --- ------------------------------------------------------------ --- * Source repos --- ------------------------------------------------------------ - --- | Information about the source revision control system for a package. --- --- When specifying a repo it is useful to know the meaning or intention of the --- information as doing so enables automation. There are two obvious common --- purposes: one is to find the repo for the latest development version, the --- other is to find the repo for this specific release. The 'ReopKind' --- specifies which one we mean (or another custom one). --- --- A package can specify one or the other kind or both. Most will specify just --- a head repo but some may want to specify a repo to reconstruct the sources --- for this package release. --- --- The required information is the 'RepoType' which tells us if it's using --- 'Darcs', 'Git' for example. The 'repoLocation' and other details are --- interpreted according to the repo type. --- -data SourceRepo = SourceRepo { - -- | The kind of repo. This field is required. - repoKind :: RepoKind, - - -- | The type of the source repository system for this repo, eg 'Darcs' or - -- 'Git'. This field is required. - repoType :: Maybe RepoType, - - -- | The location of the repository. For most 'RepoType's this is a URL. - -- This field is required. - repoLocation :: Maybe String, - - -- | 'CVS' can put multiple \"modules\" on one server and requires a - -- module name in addition to the location to identify a particular repo. - -- Logically this is part of the location but unfortunately has to be - -- specified separately. This field is required for the 'CVS' 'RepoType' and - -- should not be given otherwise. - repoModule :: Maybe String, - - -- | The name or identifier of the branch, if any. Many source control - -- systems have the notion of multiple branches in a repo that exist in the - -- same location. For example 'Git' and 'CVS' use this while systems like - -- 'Darcs' use different locations for different branches. This field is - -- optional but should be used if necessary to identify the sources, - -- especially for the 'RepoThis' repo kind. - repoBranch :: Maybe String, - - -- | The tag identify a particular state of the repository. This should be - -- given for the 'RepoThis' repo kind and not for 'RepoHead' kind. - -- - repoTag :: Maybe String, - - -- | Some repositories contain multiple projects in different subdirectories - -- This field specifies the subdirectory where this packages sources can be - -- found, eg the subdirectory containing the @.cabal@ file. It is interpreted - -- relative to the root of the repository. This field is optional. If not - -- given the default is \".\" ie no subdirectory. - repoSubdir :: Maybe FilePath -} - deriving (Eq, Ord, Generic, Read, Show, Typeable, Data) - -emptySourceRepo :: RepoKind -> SourceRepo -emptySourceRepo kind = SourceRepo - { repoKind = kind - , repoType = Nothing - , repoLocation = Nothing - , repoModule = Nothing - , repoBranch = Nothing - , repoTag = Nothing - , repoSubdir = Nothing - } - -instance Binary SourceRepo -instance Structured SourceRepo -instance NFData SourceRepo where rnf = genericRnf - --- | What this repo info is for, what it represents. --- -data RepoKind = - -- | The repository for the \"head\" or development version of the project. - -- This repo is where we should track the latest development activity or - -- the usual repo people should get to contribute patches. - RepoHead - - -- | The repository containing the sources for this exact package version - -- or release. For this kind of repo a tag should be given to give enough - -- information to re-create the exact sources. - | RepoThis - - | RepoKindUnknown String - deriving (Eq, Generic, Ord, Read, Show, Typeable, Data) - -instance Binary RepoKind -instance Structured RepoKind -instance NFData RepoKind where rnf = genericRnf - --- | An enumeration of common source control systems. The fields used in the --- 'SourceRepo' depend on the type of repo. The tools and methods used to --- obtain and track the repo depend on the repo type. --- -data KnownRepoType = Darcs | Git | SVN | CVS - | Mercurial | GnuArch | Bazaar | Monotone - | Pijul -- ^ @since 3.4.0.0 - deriving (Eq, Generic, Ord, Read, Show, Typeable, Data, Enum, Bounded) - -instance Binary KnownRepoType -instance Structured KnownRepoType -instance NFData KnownRepoType where rnf = genericRnf - -instance Parsec KnownRepoType where - parsec = do - str <- P.munch1 isIdent - maybe - (P.unexpected $ "Could not parse KnownRepoType from " ++ str) - return - (M.lookup str knownRepoTypeMap) - -instance Pretty KnownRepoType where - pretty = Disp.text . lowercase . show - -data RepoType = KnownRepoType KnownRepoType - | OtherRepoType String - deriving (Eq, Generic, Ord, Read, Show, Typeable, Data) - -instance Binary RepoType -instance Structured RepoType -instance NFData RepoType where rnf = genericRnf - -knownRepoTypes :: [KnownRepoType] -knownRepoTypes = [minBound .. maxBound] - -repoTypeAliases :: KnownRepoType -> [String] -repoTypeAliases Bazaar = ["bzr"] -repoTypeAliases Mercurial = ["hg"] -repoTypeAliases GnuArch = ["arch"] -repoTypeAliases _ = [] - -instance Pretty RepoKind where - pretty RepoHead = Disp.text "head" - pretty RepoThis = Disp.text "this" - pretty (RepoKindUnknown other) = Disp.text other - -instance Parsec RepoKind where - parsec = classifyRepoKind <$> P.munch1 isIdent - -classifyRepoKind :: String -> RepoKind -classifyRepoKind name = case lowercase name of - "head" -> RepoHead - "this" -> RepoThis - _ -> RepoKindUnknown name - -instance Parsec RepoType where - parsec = classifyRepoType <$> P.munch1 isIdent - -instance Pretty RepoType where - pretty (OtherRepoType other) = Disp.text other - pretty (KnownRepoType t) = pretty t - -classifyRepoType :: String -> RepoType -classifyRepoType s = - maybe - (OtherRepoType s) - KnownRepoType - (M.lookup (lowercase s) knownRepoTypeMap) - -knownRepoTypeMap :: Map String KnownRepoType -knownRepoTypeMap = - M.fromList - [ (name, repoType') - | repoType' <- knownRepoTypes - , name <- prettyShow repoType' : repoTypeAliases repoType' - ] - -isIdent :: Char -> Bool -isIdent c = isAlphaNum c || c == '_' || c == '-' diff --git a/src/Distribution/Types/SourceRepo/Lens.hs b/src/Distribution/Types/SourceRepo/Lens.hs deleted file mode 100644 --- a/src/Distribution/Types/SourceRepo/Lens.hs +++ /dev/null @@ -1,39 +0,0 @@ -module Distribution.Types.SourceRepo.Lens ( - T.SourceRepo, - module Distribution.Types.SourceRepo.Lens, - ) where - -import Prelude() -import Distribution.Compat.Prelude -import Distribution.Compat.Lens - -import Distribution.Types.SourceRepo (SourceRepo, RepoKind, RepoType) -import qualified Distribution.Types.SourceRepo as T - -repoKind :: Lens' SourceRepo RepoKind -repoKind f s = fmap (\x -> s { T.repoKind = x }) (f (T.repoKind s)) -{-# INLINE repoKind #-} - -repoType :: Lens' SourceRepo (Maybe RepoType) -repoType f s = fmap (\x -> s { T.repoType = x }) (f (T.repoType s)) -{-# INLINE repoType #-} - -repoLocation :: Lens' SourceRepo (Maybe String) -repoLocation f s = fmap (\x -> s { T.repoLocation = x }) (f (T.repoLocation s)) -{-# INLINE repoLocation #-} - -repoModule :: Lens' SourceRepo (Maybe String) -repoModule f s = fmap (\x -> s { T.repoModule = x }) (f (T.repoModule s)) -{-# INLINE repoModule #-} - -repoBranch :: Lens' SourceRepo (Maybe String) -repoBranch f s = fmap (\x -> s { T.repoBranch = x }) (f (T.repoBranch s)) -{-# INLINE repoBranch #-} - -repoTag :: Lens' SourceRepo (Maybe String) -repoTag f s = fmap (\x -> s { T.repoTag = x }) (f (T.repoTag s)) -{-# INLINE repoTag #-} - -repoSubdir :: Lens' SourceRepo (Maybe FilePath) -repoSubdir f s = fmap (\x -> s { T.repoSubdir = x }) (f (T.repoSubdir s)) -{-# INLINE repoSubdir #-} diff --git a/src/Distribution/Types/TestSuite.hs b/src/Distribution/Types/TestSuite.hs deleted file mode 100644 --- a/src/Distribution/Types/TestSuite.hs +++ /dev/null @@ -1,83 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} - -module Distribution.Types.TestSuite ( - TestSuite(..), - emptyTestSuite, - testType, - testModules, - testModulesAutogen -) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Types.BuildInfo -import Distribution.Types.TestType -import Distribution.Types.TestSuiteInterface -import Distribution.Types.UnqualComponentName - -import Distribution.ModuleName - -import qualified Distribution.Types.BuildInfo.Lens as L - --- | A \"test-suite\" stanza in a cabal file. --- -data TestSuite = TestSuite { - testName :: UnqualComponentName, - testInterface :: TestSuiteInterface, - testBuildInfo :: BuildInfo - } - deriving (Generic, Show, Read, Eq, Typeable, Data) - -instance L.HasBuildInfo TestSuite where - buildInfo f l = (\x -> l { testBuildInfo = x }) <$> f (testBuildInfo l) - -instance Binary TestSuite -instance Structured TestSuite - -instance NFData TestSuite where rnf = genericRnf - -instance Monoid TestSuite where - mempty = TestSuite { - testName = mempty, - testInterface = mempty, - testBuildInfo = mempty - } - mappend = (<>) - -instance Semigroup TestSuite where - a <> b = TestSuite { - testName = combine' testName, - testInterface = combine testInterface, - testBuildInfo = combine testBuildInfo - } - where combine field = field a `mappend` field b - combine' field = case ( unUnqualComponentName $ field a - , unUnqualComponentName $ field b) of - ("", _) -> field b - (_, "") -> field a - (x, y) -> error $ "Ambiguous values for test field: '" - ++ x ++ "' and '" ++ y ++ "'" - -emptyTestSuite :: TestSuite -emptyTestSuite = mempty - - -testType :: TestSuite -> TestType -testType test = case testInterface test of - TestSuiteExeV10 ver _ -> TestTypeExe ver - TestSuiteLibV09 ver _ -> TestTypeLib ver - TestSuiteUnsupported testtype -> testtype - --- | Get all the module names from a test suite. -testModules :: TestSuite -> [ModuleName] -testModules test = (case testInterface test of - TestSuiteLibV09 _ m -> [m] - _ -> []) - ++ otherModules (testBuildInfo test) - --- | Get all the auto generated module names from a test suite. --- This are a subset of 'testModules'. -testModulesAutogen :: TestSuite -> [ModuleName] -testModulesAutogen test = autogenModules (testBuildInfo test) diff --git a/src/Distribution/Types/TestSuite/Lens.hs b/src/Distribution/Types/TestSuite/Lens.hs deleted file mode 100644 --- a/src/Distribution/Types/TestSuite/Lens.hs +++ /dev/null @@ -1,27 +0,0 @@ -module Distribution.Types.TestSuite.Lens ( - TestSuite, - module Distribution.Types.TestSuite.Lens, - ) where - -import Distribution.Compat.Lens -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Types.BuildInfo (BuildInfo) -import Distribution.Types.TestSuite (TestSuite) -import Distribution.Types.TestSuiteInterface (TestSuiteInterface) -import Distribution.Types.UnqualComponentName (UnqualComponentName) - -import qualified Distribution.Types.TestSuite as T - -testName :: Lens' TestSuite UnqualComponentName -testName f s = fmap (\x -> s { T.testName = x }) (f (T.testName s)) -{-# INLINE testName #-} - -testInterface :: Lens' TestSuite TestSuiteInterface -testInterface f s = fmap (\x -> s { T.testInterface = x }) (f (T.testInterface s)) -{-# INLINE testInterface #-} - -testBuildInfo :: Lens' TestSuite BuildInfo -testBuildInfo f s = fmap (\x -> s { T.testBuildInfo = x }) (f (T.testBuildInfo s)) -{-# INLINE testBuildInfo #-} diff --git a/src/Distribution/Types/TestSuiteInterface.hs b/src/Distribution/Types/TestSuiteInterface.hs deleted file mode 100644 --- a/src/Distribution/Types/TestSuiteInterface.hs +++ /dev/null @@ -1,52 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} - -module Distribution.Types.TestSuiteInterface ( - TestSuiteInterface(..), -) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Types.TestType -import Distribution.ModuleName -import Distribution.Version - --- | The test suite interfaces that are currently defined. Each test suite must --- specify which interface it supports. --- --- More interfaces may be defined in future, either new revisions or totally --- new interfaces. --- -data TestSuiteInterface = - - -- | Test interface \"exitcode-stdio-1.0\". The test-suite takes the form - -- of an executable. It returns a zero exit code for success, non-zero for - -- failure. The stdout and stderr channels may be logged. It takes no - -- command line parameters and nothing on stdin. - -- - TestSuiteExeV10 Version FilePath - - -- | Test interface \"detailed-0.9\". The test-suite takes the form of a - -- library containing a designated module that exports \"tests :: [Test]\". - -- - | TestSuiteLibV09 Version ModuleName - - -- | A test suite that does not conform to one of the above interfaces for - -- the given reason (e.g. unknown test type). - -- - | TestSuiteUnsupported TestType - deriving (Eq, Generic, Read, Show, Typeable, Data) - -instance Binary TestSuiteInterface -instance Structured TestSuiteInterface - -instance NFData TestSuiteInterface where rnf = genericRnf - -instance Monoid TestSuiteInterface where - mempty = TestSuiteUnsupported (TestTypeUnknown mempty nullVersion) - mappend = (<>) - -instance Semigroup TestSuiteInterface where - a <> (TestSuiteUnsupported _) = a - _ <> b = b diff --git a/src/Distribution/Types/TestType.hs b/src/Distribution/Types/TestType.hs deleted file mode 100644 --- a/src/Distribution/Types/TestType.hs +++ /dev/null @@ -1,43 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} - -module Distribution.Types.TestType ( - TestType(..), - knownTestTypes, -) where - -import Distribution.Compat.Prelude -import Distribution.Version -import Prelude () - -import Distribution.Parsec -import Distribution.Pretty -import Text.PrettyPrint (char, text) - --- | The \"test-type\" field in the test suite stanza. --- -data TestType = TestTypeExe Version -- ^ \"type: exitcode-stdio-x.y\" - | TestTypeLib Version -- ^ \"type: detailed-x.y\" - | TestTypeUnknown String Version -- ^ Some unknown test type e.g. \"type: foo\" - deriving (Generic, Show, Read, Eq, Typeable, Data) - -instance Binary TestType -instance Structured TestType - -instance NFData TestType where rnf = genericRnf - -knownTestTypes :: [TestType] -knownTestTypes = [ TestTypeExe (mkVersion [1,0]) - , TestTypeLib (mkVersion [0,9]) ] - -instance Pretty TestType where - pretty (TestTypeExe ver) = text "exitcode-stdio-" <<>> pretty ver - pretty (TestTypeLib ver) = text "detailed-" <<>> pretty ver - pretty (TestTypeUnknown name ver) = text name <<>> char '-' <<>> pretty ver - -instance Parsec TestType where - parsec = parsecStandard $ \ver name -> case name of - "exitcode-stdio" -> TestTypeExe ver - "detailed" -> TestTypeLib ver - _ -> TestTypeUnknown name ver diff --git a/src/Distribution/Types/UnitId.hs b/src/Distribution/Types/UnitId.hs deleted file mode 100644 --- a/src/Distribution/Types/UnitId.hs +++ /dev/null @@ -1,134 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE FlexibleContexts #-} - -module Distribution.Types.UnitId - ( UnitId, unUnitId, mkUnitId - , DefUnitId - , unsafeMkDefUnitId - , unDefUnitId - , newSimpleUnitId - , mkLegacyUnitId - , getHSLibraryName - ) where - -import Prelude () -import Distribution.Compat.Prelude -import Distribution.Utils.ShortText - -import qualified Distribution.Compat.CharParsing as P -import Distribution.Pretty -import Distribution.Parsec -import Distribution.Types.ComponentId -import Distribution.Types.PackageId - -import Text.PrettyPrint (text) - --- | A unit identifier identifies a (possibly instantiated) --- package/component that can be installed the installed package --- database. There are several types of components that can be --- installed: --- --- * A traditional library with no holes, so that 'unitIdHash' --- is @Nothing@. In the absence of Backpack, 'UnitId' --- is the same as a 'ComponentId'. --- --- * An indefinite, Backpack library with holes. In this case, --- 'unitIdHash' is still @Nothing@, but in the install, --- there are only interfaces, no compiled objects. --- --- * An instantiated Backpack library with all the holes --- filled in. 'unitIdHash' is a @Just@ a hash of the --- instantiating mapping. --- --- A unit is a component plus the additional information on how the --- holes are filled in. Thus there is a one to many relationship: for a --- particular component there are many different ways of filling in the --- holes, and each different combination is a unit (and has a separate --- 'UnitId'). --- --- 'UnitId' is distinct from 'OpenUnitId', in that it is always --- installed, whereas 'OpenUnitId' are intermediate unit identities --- that arise during mixin linking, and don't necessarily correspond --- to any actually installed unit. Since the mapping is not actually --- recorded in a 'UnitId', you can't actually substitute over them --- (but you can substitute over 'OpenUnitId'). See also --- "Distribution.Backpack.FullUnitId" for a mechanism for expanding an --- instantiated 'UnitId' to retrieve its mapping. --- --- Backwards compatibility note: if you need to get the string --- representation of a UnitId to pass, e.g., as a @-package-id@ --- flag, use the 'display' function, which will work on all --- versions of Cabal. --- -newtype UnitId = UnitId ShortText - deriving (Generic, Read, Show, Eq, Ord, Typeable, Data, NFData) - -instance Binary UnitId -instance Structured UnitId - --- | The textual format for 'UnitId' coincides with the format --- GHC accepts for @-package-id@. --- -instance Pretty UnitId where - pretty = text . unUnitId - --- | The textual format for 'UnitId' coincides with the format --- GHC accepts for @-package-id@. --- -instance Parsec UnitId where - parsec = mkUnitId <$> P.munch1 isUnitChar where - -- https://gitlab.haskell.org/ghc/ghc/issues/17752 - isUnitChar '-' = True - isUnitChar '_' = True - isUnitChar '.' = True - isUnitChar '+' = True - isUnitChar c = isAlphaNum c - --- | If you need backwards compatibility, consider using 'display' --- instead, which is supported by all versions of Cabal. --- -unUnitId :: UnitId -> String -unUnitId (UnitId s) = fromShortText s - -mkUnitId :: String -> UnitId -mkUnitId = UnitId . toShortText - --- | 'mkUnitId' --- --- @since 2.0.0.2 -instance IsString UnitId where - fromString = mkUnitId - --- | Create a unit identity with no associated hash directly --- from a 'ComponentId'. -newSimpleUnitId :: ComponentId -> UnitId -newSimpleUnitId = mkUnitId . unComponentId - --- | Make an old-style UnitId from a package identifier. --- Assumed to be for the public library -mkLegacyUnitId :: PackageId -> UnitId -mkLegacyUnitId = newSimpleUnitId . mkComponentId . prettyShow - --- | Returns library name prefixed with HS, suitable for filenames -getHSLibraryName :: UnitId -> String -getHSLibraryName uid = "HS" ++ prettyShow uid - --- | A 'UnitId' for a definite package. The 'DefUnitId' invariant says --- that a 'UnitId' identified this way is definite; i.e., it has no --- unfilled holes. -newtype DefUnitId = DefUnitId { unDefUnitId :: UnitId } - deriving (Generic, Read, Show, Eq, Ord, Typeable, Data, Binary, NFData, Pretty) - -instance Structured DefUnitId - --- Workaround for a GHC 8.0.1 bug, see --- https://github.com/haskell/cabal/issues/4793#issuecomment-334258288 -instance Parsec DefUnitId where - parsec = DefUnitId <$> parsec - --- | Unsafely create a 'DefUnitId' from a 'UnitId'. Your responsibility --- is to ensure that the 'DefUnitId' invariant holds. -unsafeMkDefUnitId :: UnitId -> DefUnitId -unsafeMkDefUnitId = DefUnitId diff --git a/src/Distribution/Types/UnqualComponentName.hs b/src/Distribution/Types/UnqualComponentName.hs deleted file mode 100644 --- a/src/Distribution/Types/UnqualComponentName.hs +++ /dev/null @@ -1,93 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -module Distribution.Types.UnqualComponentName - ( UnqualComponentName, unUnqualComponentName, unUnqualComponentNameST, mkUnqualComponentName - , packageNameToUnqualComponentName, unqualComponentNameToPackageName - ) where - -import Distribution.Compat.Prelude -import Distribution.Utils.ShortText -import Prelude () - -import Distribution.Parsec -import Distribution.Pretty -import Distribution.Types.PackageName - --- | An unqualified component name, for any kind of component. --- --- This is distinguished from a 'ComponentName' and 'ComponentId'. The former --- also states which of a library, executable, etc the name refers too. The --- later uniquely identifiers a component and its closure. --- --- @since 2.0.0.2 -newtype UnqualComponentName = UnqualComponentName ShortText - deriving (Generic, Read, Show, Eq, Ord, Typeable, Data, - Semigroup, Monoid) -- TODO: bad enabler of bad monoids - --- | Convert 'UnqualComponentName' to 'String' --- --- @since 2.0.0.2 -unUnqualComponentName :: UnqualComponentName -> String -unUnqualComponentName (UnqualComponentName s) = fromShortText s - --- | @since 3.4.0.0 -unUnqualComponentNameST :: UnqualComponentName -> ShortText -unUnqualComponentNameST (UnqualComponentName s) = s - --- | Construct a 'UnqualComponentName' from a 'String' --- --- 'mkUnqualComponentName' is the inverse to 'unUnqualComponentName' --- --- Note: No validations are performed to ensure that the resulting --- 'UnqualComponentName' is valid --- --- @since 2.0.0.2 -mkUnqualComponentName :: String -> UnqualComponentName -mkUnqualComponentName = UnqualComponentName . toShortText - --- | 'mkUnqualComponentName' --- --- @since 2.0.0.2 -instance IsString UnqualComponentName where - fromString = mkUnqualComponentName - -instance Binary UnqualComponentName -instance Structured UnqualComponentName - -instance Pretty UnqualComponentName where - pretty = showToken . unUnqualComponentName - -instance Parsec UnqualComponentName where - parsec = mkUnqualComponentName <$> parsecUnqualComponentName - -instance NFData UnqualComponentName where - rnf (UnqualComponentName pkg) = rnf pkg - --- TODO avoid String round trip with these PackageName <-> --- UnqualComponentName converters. - --- | Converts a package name to an unqualified component name --- --- Useful in legacy situations where a package name may refer to an internal --- component, if one is defined with that name. --- --- 2018-12-21: These "legacy" situations are not legacy. --- We can @build-depends@ on the internal library. However --- Now dependency contains @Set LibraryName@, and we should use that. --- --- @since 2.0.0.2 -packageNameToUnqualComponentName :: PackageName -> UnqualComponentName -packageNameToUnqualComponentName = UnqualComponentName . unPackageNameST - --- | Converts an unqualified component name to a package name --- --- `packageNameToUnqualComponentName` is the inverse of --- `unqualComponentNameToPackageName`. --- --- Useful in legacy situations where a package name may refer to an internal --- component, if one is defined with that name. --- --- @since 2.0.0.2 -unqualComponentNameToPackageName :: UnqualComponentName -> PackageName -unqualComponentNameToPackageName = mkPackageNameST . unUnqualComponentNameST diff --git a/src/Distribution/Types/Version.hs b/src/Distribution/Types/Version.hs deleted file mode 100644 --- a/src/Distribution/Types/Version.hs +++ /dev/null @@ -1,242 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Types.Version ( - -- * Package versions - Version, - mkVersion, - mkVersion', - versionNumbers, - nullVersion, - alterVersion, - version0, - - -- * Internal - validVersion, - versionDigitParser, - ) where - -import Data.Bits (shiftL, shiftR, (.&.), (.|.)) -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Parsec -import Distribution.Pretty - -import qualified Data.Version as Base -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp -import qualified Text.Read as Read - --- | A 'Version' represents the version of a software entity. --- --- Instances of 'Eq' and 'Ord' are provided, which gives exact --- equality and lexicographic ordering of the version number --- components (i.e. 2.1 > 2.0, 1.2.3 > 1.2.2, etc.). --- --- This type is opaque and distinct from the 'Base.Version' type in --- "Data.Version" since @Cabal-2.0@. The difference extends to the --- 'Binary' instance using a different (and more compact) encoding. --- --- @since 2.0.0.2 -data Version = PV0 {-# UNPACK #-} !Word64 - | PV1 !Int [Int] - -- NOTE: If a version fits into the packed Word64 - -- representation (i.e. at most four version components - -- which all fall into the [0..0xfffe] range), then PV0 - -- MUST be used. This is essential for the 'Eq' instance - -- to work. - deriving (Data,Eq,Generic,Typeable) - -instance Ord Version where - compare (PV0 x) (PV0 y) = compare x y - compare (PV1 x xs) (PV1 y ys) = case compare x y of - EQ -> compare xs ys - c -> c - compare (PV0 w) (PV1 y ys) = case compare x y of - EQ -> compare [x2,x3,x4] ys - c -> c - where - x = fromIntegral ((w `shiftR` 48) .&. 0xffff) - 1 - x2 = fromIntegral ((w `shiftR` 32) .&. 0xffff) - 1 - x3 = fromIntegral ((w `shiftR` 16) .&. 0xffff) - 1 - x4 = fromIntegral (w .&. 0xffff) - 1 - compare (PV1 x xs) (PV0 w) = case compare x y of - EQ -> compare xs [y2,y3,y4] - c -> c - where - y = fromIntegral ((w `shiftR` 48) .&. 0xffff) - 1 - y2 = fromIntegral ((w `shiftR` 32) .&. 0xffff) - 1 - y3 = fromIntegral ((w `shiftR` 16) .&. 0xffff) - 1 - y4 = fromIntegral (w .&. 0xffff) - 1 - -instance Show Version where - showsPrec d v = showParen (d > 10) - $ showString "mkVersion " - . showsPrec 11 (versionNumbers v) - -instance Read Version where - readPrec = Read.parens $ do - Read.Ident "mkVersion" <- Read.lexP - v <- Read.step Read.readPrec - return (mkVersion v) - -instance Binary Version -instance Structured Version - -instance NFData Version where - rnf (PV0 _) = () - rnf (PV1 _ ns) = rnf ns - -instance Pretty Version where - pretty ver - = Disp.hcat (Disp.punctuate (Disp.char '.') - (map Disp.int $ versionNumbers ver)) - -instance Parsec Version where - parsec = mkVersion <$> toList <$> P.sepByNonEmpty versionDigitParser (P.char '.') <* tags - where - tags = do - ts <- many $ P.char '-' *> some (P.satisfy isAlphaNum) - case ts of - [] -> pure () - (_ : _) -> parsecWarning PWTVersionTag "version with tags" - --- | An integral without leading zeroes. --- --- @since 3.0 -versionDigitParser :: CabalParsing m => m Int -versionDigitParser = (some d >>= toNumber) P. "version digit (integral without leading zeroes)" - where - toNumber :: CabalParsing m => [Int] -> m Int - toNumber [0] = return 0 - toNumber (0:_) = P.unexpected "Version digit with leading zero" - toNumber xs - -- 10^9 = 1000000000 - -- 2^30 = 1073741824 - -- - -- GHC Int is at least 32 bits, so 2^31-1 is the 'maxBound'. - | length xs > 9 = P.unexpected "At most 9 numbers are allowed per version number part" - | otherwise = return $ foldl' (\a b -> a * 10 + b) 0 xs - - d :: P.CharParsing m => m Int - d = f <$> P.satisfyRange '0' '9' - f c = ord c - ord '0' - --- | Construct 'Version' from list of version number components. --- --- For instance, @mkVersion [3,2,1]@ constructs a 'Version' --- representing the version @3.2.1@. --- --- All version components must be non-negative. @mkVersion []@ --- currently represents the special /null/ version; see also 'nullVersion'. --- --- @since 2.0.0.2 -mkVersion :: [Int] -> Version --- TODO: add validity check; disallow 'mkVersion []' (we have --- 'nullVersion' for that) -mkVersion [] = nullVersion -mkVersion (v1:[]) - | inWord16VerRep1 v1 = PV0 (mkWord64VerRep1 v1) - | otherwise = PV1 v1 [] - where - inWord16VerRep1 x1 = inWord16 (x1 .|. (x1+1)) - mkWord64VerRep1 y1 = mkWord64VerRep (y1+1) 0 0 0 - -mkVersion (v1:vs@(v2:[])) - | inWord16VerRep2 v1 v2 = PV0 (mkWord64VerRep2 v1 v2) - | otherwise = PV1 v1 vs - where - inWord16VerRep2 x1 x2 = inWord16 (x1 .|. (x1+1) - .|. x2 .|. (x2+1)) - mkWord64VerRep2 y1 y2 = mkWord64VerRep (y1+1) (y2+1) 0 0 - -mkVersion (v1:vs@(v2:v3:[])) - | inWord16VerRep3 v1 v2 v3 = PV0 (mkWord64VerRep3 v1 v2 v3) - | otherwise = PV1 v1 vs - where - inWord16VerRep3 x1 x2 x3 = inWord16 (x1 .|. (x1+1) - .|. x2 .|. (x2+1) - .|. x3 .|. (x3+1)) - mkWord64VerRep3 y1 y2 y3 = mkWord64VerRep (y1+1) (y2+1) (y3+1) 0 - -mkVersion (v1:vs@(v2:v3:v4:[])) - | inWord16VerRep4 v1 v2 v3 v4 = PV0 (mkWord64VerRep4 v1 v2 v3 v4) - | otherwise = PV1 v1 vs - where - inWord16VerRep4 x1 x2 x3 x4 = inWord16 (x1 .|. (x1+1) - .|. x2 .|. (x2+1) - .|. x3 .|. (x3+1) - .|. x4 .|. (x4+1)) - mkWord64VerRep4 y1 y2 y3 y4 = mkWord64VerRep (y1+1) (y2+1) (y3+1) (y4+1) - -mkVersion (v1:vs) = PV1 v1 vs - --- | Version 0. A lower bound of 'Version'. --- --- @since 2.2 -version0 :: Version -version0 = mkVersion [0] - -{-# INLINE mkWord64VerRep #-} -mkWord64VerRep :: Int -> Int -> Int -> Int -> Word64 -mkWord64VerRep v1 v2 v3 v4 = - (fromIntegral v1 `shiftL` 48) - .|. (fromIntegral v2 `shiftL` 32) - .|. (fromIntegral v3 `shiftL` 16) - .|. fromIntegral v4 - -{-# INLINE inWord16 #-} -inWord16 :: Int -> Bool -inWord16 x = (fromIntegral x :: Word) <= 0xffff - --- | Variant of 'mkVersion' which converts a "Data.Version" --- 'Base.Version' into Cabal's 'Version' type. --- --- @since 2.0.0.2 -mkVersion' :: Base.Version -> Version -mkVersion' = mkVersion . Base.versionBranch - --- | Unpack 'Version' into list of version number components. --- --- This is the inverse to 'mkVersion', so the following holds: --- --- > (versionNumbers . mkVersion) vs == vs --- --- @since 2.0.0.2 -versionNumbers :: Version -> [Int] -versionNumbers (PV1 n ns) = n:ns -versionNumbers (PV0 w) - | v1 < 0 = [] - | v2 < 0 = [v1] - | v3 < 0 = [v1,v2] - | v4 < 0 = [v1,v2,v3] - | otherwise = [v1,v2,v3,v4] - where - v1 = fromIntegral ((w `shiftR` 48) .&. 0xffff) - 1 - v2 = fromIntegral ((w `shiftR` 32) .&. 0xffff) - 1 - v3 = fromIntegral ((w `shiftR` 16) .&. 0xffff) - 1 - v4 = fromIntegral (w .&. 0xffff) - 1 - - --- | Constant representing the special /null/ 'Version' --- --- The 'nullVersion' compares (via 'Ord') as less than every proper --- 'Version' value. --- --- @since 2.0.0.2 -nullVersion :: Version --- TODO: at some point, 'mkVersion' may disallow creating /null/ --- 'Version's -nullVersion = PV0 0 - --- | Apply function to list of version number components --- --- > alterVersion f == mkVersion . f . versionNumbers --- --- @since 2.0.0.2 -alterVersion :: ([Int] -> [Int]) -> Version -> Version -alterVersion f = mkVersion . f . versionNumbers - --- internal helper -validVersion :: Version -> Bool -validVersion v = v /= nullVersion && all (>=0) (versionNumbers v) diff --git a/src/Distribution/Types/VersionInterval.hs b/src/Distribution/Types/VersionInterval.hs deleted file mode 100644 --- a/src/Distribution/Types/VersionInterval.hs +++ /dev/null @@ -1,345 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DeriveDataTypeable #-} --- | In @Cabal-3.6@ this module have been rewritten. --- --- -module Distribution.Types.VersionInterval ( - -- * Version intervals - VersionIntervals, - unVersionIntervals, - - -- * Conversions - toVersionIntervals, - fromVersionIntervals, - - -- ** Normalisation - normaliseVersionRange2, - - -- * Relaxation - relaxLastInterval, - relaxHeadInterval, - - -- * Version intervals view - asVersionIntervals, - VersionInterval (..), - LowerBound(..), - UpperBound(..), - Bound(..), - - -- * Invariants - invariantVersionIntervals, - ) where - -import Control.Applicative (liftA2) -import Control.Exception (assert) -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Types.Version -import Distribution.Types.VersionRange.Internal - --- To test this module, and to run version range normalisation benchmarks: --- --- cabal run Cabal:unit-tests -- -p Distribution.Version --- cabal run cabal-benchmarks -- -o bench.html normaliseVersionRange - -------------------------------------------------------------------------------- --- Data -------------------------------------------------------------------------------- - --- | A complementary representation of a 'VersionRange'. Instead of a boolean --- version predicate it uses an increasing sequence of non-overlapping, --- non-empty intervals. --- --- The key point is that this representation gives a canonical representation --- for the semantics of 'VersionRange's. This makes it easier to check things --- like whether a version range is empty, covers all versions, or requires a --- certain minimum or maximum version. It also makes it easy to check equality --- or containment. It also makes it easier to identify \'simple\' version --- predicates for translation into foreign packaging systems that do not --- support complex version range expressions. --- -newtype VersionIntervals = VersionIntervals [VersionInterval] - deriving (Eq, Show, Typeable) - --- | Inspect the list of version intervals. --- -unVersionIntervals :: VersionIntervals -> [VersionInterval] -unVersionIntervals (VersionIntervals is) = is - -data VersionInterval = VersionInterval !LowerBound !UpperBound deriving (Eq, Show) -data LowerBound = LowerBound !Version !Bound deriving (Eq, Show) -data UpperBound = NoUpperBound | UpperBound !Version !Bound deriving (Eq, Show) -data Bound = ExclusiveBound | InclusiveBound deriving (Eq, Show) - -zeroLowerBound :: LowerBound -zeroLowerBound = LowerBound version0 InclusiveBound - -isVersion0 :: Version -> Bool -isVersion0 = (==) version0 - -------------------------------------------------------------------------------- --- Stage1 -------------------------------------------------------------------------------- - -stage1 :: VersionRange -> [VersionInterval] -stage1 = cataVersionRange alg where - -- version range leafs transform into singleton intervals - alg (ThisVersionF v) = [VersionInterval (LowerBound v InclusiveBound) (UpperBound v InclusiveBound)] - alg (LaterVersionF v) = [VersionInterval (LowerBound v ExclusiveBound) NoUpperBound] - alg (OrLaterVersionF v) = [VersionInterval (LowerBound v InclusiveBound) NoUpperBound] - alg (EarlierVersionF v) - | isVersion0 v = [] - | otherwise = [VersionInterval zeroLowerBound (UpperBound v ExclusiveBound)] - alg (OrEarlierVersionF v) = [VersionInterval zeroLowerBound (UpperBound v InclusiveBound)] - - -- ^>= version-range's upper bound should be MajorBound - alg (MajorBoundVersionF v) = [VersionInterval (LowerBound v InclusiveBound) (UpperBound (majorUpperBound v) ExclusiveBound)] - - -- union: just merge the version intervals - alg (UnionVersionRangesF v1 v2) = v1 ++ v2 - - -- intersection: pairwise intersect. Strip empty intervals. Sort to restore the invariant. - alg (IntersectVersionRangesF v1 v2) = mapMaybe nonEmptyInterval $ liftA2 intersectInterval (stage2and3 v1) (stage2and3 v2) - --- | Creck that interval is non-empty -nonEmptyInterval :: VersionInterval -> Maybe VersionInterval -nonEmptyInterval i | nonEmptyVI i = Just i -nonEmptyInterval _ = Nothing - -------------------------------------------------------------------------------- --- Stage2 -------------------------------------------------------------------------------- - -stage2 :: [VersionInterval] -> [VersionInterval] -stage2 = sortBy lowerboundCmp - -lowerboundCmp :: VersionInterval -> VersionInterval -> Ordering -lowerboundCmp (VersionInterval (LowerBound v vb) _) (VersionInterval (LowerBound u ub) _) = - compare v u `mappend` compareBound vb ub - where - compareBound :: Bound -> Bound -> Ordering - compareBound InclusiveBound InclusiveBound = EQ - compareBound InclusiveBound ExclusiveBound = LT - compareBound ExclusiveBound InclusiveBound = GT - compareBound ExclusiveBound ExclusiveBound = EQ - -------------------------------------------------------------------------------- --- Postprocess -------------------------------------------------------------------------------- - --- | Post-processing takes a list of ordered version intervals, --- but possibly overlapping, and creates 'VersionIntervals'. --- -postprocess :: [VersionInterval] -> VersionIntervals -postprocess = checkInvariant . VersionIntervals . stage2and3 - -stage2and3 :: [VersionInterval] -> [VersionInterval] -stage2and3 = stage3 . stage2 - -stage3 :: [VersionInterval] -> [VersionInterval] -stage3 [] = [] -stage3 (VersionInterval lb ub : rest) = stage3go lb ub rest - -stage3go :: LowerBound -> UpperBound -> [VersionInterval] -> [VersionInterval] -stage3go !lb NoUpperBound _ = [VersionInterval lb NoUpperBound] -stage3go !lb !ub [] = [VersionInterval lb ub] -stage3go !lb !ub (VersionInterval lb' ub' : rest') - | doesNotTouch ub lb' = VersionInterval lb ub : stage3go lb' ub' rest' - | otherwise = stage3go lb (unionUpper ub ub') rest' - -------------------------------------------------------------------------------- --- Intersections -------------------------------------------------------------------------------- - -intersectInterval :: VersionInterval -> VersionInterval -> VersionInterval -intersectInterval (VersionInterval lv uv) (VersionInterval lu uu) = - VersionInterval (intersectLower lv lu) (intersectUpper uv uu) - -intersectLower :: LowerBound -> LowerBound -> LowerBound -intersectLower (LowerBound v vb) (LowerBound u ub) = case compare v u of - EQ -> LowerBound v (intersectBound vb ub) - LT -> LowerBound u ub - GT -> LowerBound v vb - -intersectUpper :: UpperBound -> UpperBound -> UpperBound -intersectUpper NoUpperBound b = b -intersectUpper b NoUpperBound = b -intersectUpper (UpperBound v vb) (UpperBound u ub) = case compare v u of - EQ -> UpperBound v (intersectBound vb ub) - LT -> UpperBound v vb - GT -> UpperBound u ub - -intersectBound :: Bound -> Bound -> Bound -intersectBound InclusiveBound InclusiveBound = InclusiveBound -intersectBound _ _ = ExclusiveBound - -------------------------------------------------------------------------------- --- Unions -------------------------------------------------------------------------------- - -unionUpper :: UpperBound -> UpperBound -> UpperBound -unionUpper NoUpperBound _ = NoUpperBound -unionUpper _ NoUpperBound = NoUpperBound -unionUpper (UpperBound v vb) (UpperBound u ub) = case compare v u of - EQ -> UpperBound v (unionBound vb ub) - LT -> UpperBound u ub - GT -> UpperBound v vb - -unionBound :: Bound -> Bound -> Bound -unionBound ExclusiveBound ExclusiveBound = ExclusiveBound -unionBound _ _ = InclusiveBound - -------------------------------------------------------------------------------- --- VersionRange -------------------------------------------------------------------------------- - --- | View a 'VersionRange' as a union of intervals. --- --- This provides a canonical view of the semantics of a 'VersionRange' as --- opposed to the syntax of the expression used to define it. For the syntactic --- view use 'foldVersionRange'. --- --- Each interval is non-empty. The sequence is in increasing order and no --- intervals overlap or touch. Therefore only the first and last can be --- unbounded. The sequence can be empty if the range is empty --- (e.g. a range expression like @< 1 && > 2@). --- --- Other checks are trivial to implement using this view. For example: --- --- > isNoVersion vr | [] <- asVersionIntervals vr = True --- > | otherwise = False --- --- > isSpecificVersion vr --- > | [(LowerBound v InclusiveBound --- > ,UpperBound v' InclusiveBound)] <- asVersionIntervals vr --- > , v == v' = Just v --- > | otherwise = Nothing --- -asVersionIntervals :: VersionRange -> [VersionInterval] -asVersionIntervals = unVersionIntervals . toVersionIntervals - -------------------------------------------------------------------------------- --- Helpers -------------------------------------------------------------------------------- - --- | Check an upper bound does not intersect, or even touch a lower bound: --- --- @ --- ---| or ---) but not ---] or ---) or ---] --- |--- (--- (--- [--- [--- --- @ --- -doesNotTouch :: UpperBound -> LowerBound -> Bool -doesNotTouch NoUpperBound _ = False -doesNotTouch (UpperBound u ub) (LowerBound l lb) = - (u < l) || (u == l && ub == ExclusiveBound && lb == ExclusiveBound) - -------------------------------------------------------------------------------- --- Invariants -------------------------------------------------------------------------------- - --- | 'VersionIntervals' invariant: --- --- * all intervals are valid (lower bound is less then upper bound, i.e. non-empty) --- * intervals doesn't touch each other (distinct) --- -invariantVersionIntervals :: VersionIntervals -> Bool -invariantVersionIntervals (VersionIntervals intervals) = - all validInterval intervals && - all doesNotTouch' adjacentIntervals - where - doesNotTouch' :: (VersionInterval, VersionInterval) -> Bool - doesNotTouch' (VersionInterval _ u, VersionInterval l' _) = doesNotTouch u l' - - adjacentIntervals :: [(VersionInterval, VersionInterval)] - adjacentIntervals = case intervals of - [] -> [] - (_:tl) -> zip intervals tl - -checkInvariant :: VersionIntervals -> VersionIntervals -checkInvariant is = assert (invariantVersionIntervals is) is -{-# INLINE checkInvariant #-} - -validInterval :: VersionInterval -> Bool -validInterval i@(VersionInterval l u) = validLower l && validUpper u && nonEmptyVI i - where - validLower (LowerBound v _) = validVersion v - validUpper NoUpperBound = True - validUpper (UpperBound v _) = validVersion v - --- Check an interval is non-empty --- -nonEmptyVI :: VersionInterval -> Bool -nonEmptyVI (VersionInterval _ NoUpperBound) = True -nonEmptyVI (VersionInterval (LowerBound l lb) (UpperBound u ub)) = - (l < u) || (l == u && lb == InclusiveBound && ub == InclusiveBound) - -------------------------------------------------------------------------------- --- Conversions -------------------------------------------------------------------------------- - --- | Convert a 'VersionRange' to a sequence of version intervals. --- -toVersionIntervals :: VersionRange -> VersionIntervals -toVersionIntervals = postprocess . stage1 - --- | Convert a 'VersionIntervals' value back into a 'VersionRange' expression --- representing the version intervals. --- -fromVersionIntervals :: VersionIntervals -> VersionRange -fromVersionIntervals (VersionIntervals []) = noVersion -fromVersionIntervals (VersionIntervals (x:xs)) = foldr1 unionVersionRanges (fmap intervalToVersionRange (x:|xs)) - -intervalToVersionRange :: VersionInterval -> VersionRange -intervalToVersionRange (VersionInterval (LowerBound v vb) upper') = case upper' of - NoUpperBound - -> lowerBound - - UpperBound u ub - | vb == InclusiveBound - , ub == InclusiveBound - , v == u - -> thisVersion v - - UpperBound u ub -> withLowerBound (makeUpperBound u ub) - where - lowerBound :: VersionRange - lowerBound = case vb of - InclusiveBound -> orLaterVersion v - ExclusiveBound -> laterVersion v - - withLowerBound :: VersionRange -> VersionRange - withLowerBound vr - | isVersion0 v, vb == InclusiveBound = vr - | otherwise = intersectVersionRanges lowerBound vr - - makeUpperBound :: Version -> Bound -> VersionRange - makeUpperBound u InclusiveBound = orEarlierVersion u - makeUpperBound u ExclusiveBound = earlierVersion u - -------------------------------------------------------------------------------- --- Normalisation -------------------------------------------------------------------------------- - --- | Since @Cabal-3.6@ this function.. TODO --- -normaliseVersionRange2 :: VersionRange -> VersionRange -normaliseVersionRange2 = fromVersionIntervals . toVersionIntervals - -------------------------------------------------------------------------------- --- Relaxation -------------------------------------------------------------------------------- - -relaxLastInterval :: VersionIntervals -> VersionIntervals -relaxLastInterval (VersionIntervals xs) = VersionIntervals (relaxLastInterval' xs) - where - relaxLastInterval' [] = [] - relaxLastInterval' [VersionInterval l _] = [VersionInterval l NoUpperBound] - relaxLastInterval' (i:is) = i : relaxLastInterval' is - -relaxHeadInterval :: VersionIntervals -> VersionIntervals -relaxHeadInterval (VersionIntervals xs) = VersionIntervals (relaxHeadInterval' xs) - where - relaxHeadInterval' [] = [] - relaxHeadInterval' (VersionInterval _ u : is) = VersionInterval zeroLowerBound u : is diff --git a/src/Distribution/Types/VersionInterval/Legacy.hs b/src/Distribution/Types/VersionInterval/Legacy.hs deleted file mode 100644 --- a/src/Distribution/Types/VersionInterval/Legacy.hs +++ /dev/null @@ -1,368 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} --- | This is old version of "Distribution.Types.VersionInterval" module. --- --- It will be removed in @Cabal-3.8@. --- -module Distribution.Types.VersionInterval.Legacy {-# DEPRECATED "Use Distribution.Types.VersionInterval instead" #-} ( - -- * Version intervals - VersionIntervals, - toVersionIntervals, - fromVersionIntervals, - withinIntervals, - versionIntervals, - mkVersionIntervals, - unionVersionIntervals, - intersectVersionIntervals, - invertVersionIntervals, - relaxLastInterval, - relaxHeadInterval, - - -- * Version intervals view - asVersionIntervals, - VersionInterval, - LowerBound(..), - UpperBound(..), - Bound(..), - ) where - -import Prelude () -import Distribution.Compat.Prelude -import Control.Exception (assert) - -import Distribution.Types.Version -import Distribution.Types.VersionRange.Internal - --- NonEmpty -import qualified Prelude (foldr1) - -------------------------------------------------------------------------------- --- VersionRange -------------------------------------------------------------------------------- - --- | View a 'VersionRange' as a union of intervals. --- --- This provides a canonical view of the semantics of a 'VersionRange' as --- opposed to the syntax of the expression used to define it. For the syntactic --- view use 'foldVersionRange'. --- --- Each interval is non-empty. The sequence is in increasing order and no --- intervals overlap or touch. Therefore only the first and last can be --- unbounded. The sequence can be empty if the range is empty --- (e.g. a range expression like @< 1 && > 2@). --- --- Other checks are trivial to implement using this view. For example: --- --- > isNoVersion vr | [] <- asVersionIntervals vr = True --- > | otherwise = False --- --- > isSpecificVersion vr --- > | [(LowerBound v InclusiveBound --- > ,UpperBound v' InclusiveBound)] <- asVersionIntervals vr --- > , v == v' = Just v --- > | otherwise = Nothing --- -asVersionIntervals :: VersionRange -> [VersionInterval] -asVersionIntervals = versionIntervals . toVersionIntervals - - -------------------------------------------------------------------------------- --- VersionInterval -------------------------------------------------------------------------------- - --- | A complementary representation of a 'VersionRange'. Instead of a boolean --- version predicate it uses an increasing sequence of non-overlapping, --- non-empty intervals. --- --- The key point is that this representation gives a canonical representation --- for the semantics of 'VersionRange's. This makes it easier to check things --- like whether a version range is empty, covers all versions, or requires a --- certain minimum or maximum version. It also makes it easy to check equality --- or containment. It also makes it easier to identify \'simple\' version --- predicates for translation into foreign packaging systems that do not --- support complex version range expressions. --- -newtype VersionIntervals = VersionIntervals [VersionInterval] - deriving (Eq, Show, Typeable) - --- | Inspect the list of version intervals. --- -versionIntervals :: VersionIntervals -> [VersionInterval] -versionIntervals (VersionIntervals is) = is - -type VersionInterval = (LowerBound, UpperBound) -data LowerBound = LowerBound Version !Bound deriving (Eq, Show) -data UpperBound = NoUpperBound | UpperBound Version !Bound deriving (Eq, Show) -data Bound = ExclusiveBound | InclusiveBound deriving (Eq, Show) - -minLowerBound :: LowerBound -minLowerBound = LowerBound (mkVersion [0]) InclusiveBound - -isVersion0 :: Version -> Bool -isVersion0 = (==) version0 - -instance Ord LowerBound where - LowerBound ver bound <= LowerBound ver' bound' = case compare ver ver' of - LT -> True - EQ -> not (bound == ExclusiveBound && bound' == InclusiveBound) - GT -> False - -instance Ord UpperBound where - _ <= NoUpperBound = True - NoUpperBound <= UpperBound _ _ = False - UpperBound ver bound <= UpperBound ver' bound' = case compare ver ver' of - LT -> True - EQ -> not (bound == InclusiveBound && bound' == ExclusiveBound) - GT -> False - -invariant :: VersionIntervals -> Bool -invariant (VersionIntervals intervals) = all validInterval intervals - && all doesNotTouch' adjacentIntervals - where - doesNotTouch' :: (VersionInterval, VersionInterval) -> Bool - doesNotTouch' ((_,u), (l',_)) = doesNotTouch u l' - - adjacentIntervals :: [(VersionInterval, VersionInterval)] - adjacentIntervals = case intervals of - [] -> [] - (_:tl) -> zip intervals tl - -checkInvariant :: VersionIntervals -> VersionIntervals -checkInvariant is = assert (invariant is) is - --- | Directly construct a 'VersionIntervals' from a list of intervals. --- --- In @Cabal-2.2@ the 'Maybe' is dropped from the result type. --- -mkVersionIntervals :: [VersionInterval] -> VersionIntervals -mkVersionIntervals intervals - | invariant (VersionIntervals intervals) = VersionIntervals intervals - | otherwise - = checkInvariant - . foldl' (flip insertInterval) (VersionIntervals []) - . filter validInterval - $ intervals - -insertInterval :: VersionInterval -> VersionIntervals -> VersionIntervals -insertInterval i is = unionVersionIntervals (VersionIntervals [i]) is - -validInterval :: (LowerBound, UpperBound) -> Bool -validInterval i@(l, u) = validLower l && validUpper u && nonEmptyVI i - where - validLower (LowerBound v _) = validVersion v - validUpper NoUpperBound = True - validUpper (UpperBound v _) = validVersion v - --- Check an interval is non-empty --- -nonEmptyVI :: VersionInterval -> Bool -nonEmptyVI (_, NoUpperBound ) = True -nonEmptyVI (LowerBound l lb, UpperBound u ub) = - (l < u) || (l == u && lb == InclusiveBound && ub == InclusiveBound) - --- Check an upper bound does not intersect, or even touch a lower bound: --- --- ---| or ---) but not ---] or ---) or ---] --- |--- (--- (--- [--- [--- --- -doesNotTouch :: UpperBound -> LowerBound -> Bool -doesNotTouch NoUpperBound _ = False -doesNotTouch (UpperBound u ub) (LowerBound l lb) = - u < l - || (u == l && ub == ExclusiveBound && lb == ExclusiveBound) - --- | Check an upper bound does not intersect a lower bound: --- --- ---| or ---) or ---] or ---) but not ---] --- |--- (--- (--- [--- [--- --- -doesNotIntersect :: UpperBound -> LowerBound -> Bool -doesNotIntersect NoUpperBound _ = False -doesNotIntersect (UpperBound u ub) (LowerBound l lb) = - u < l - || (u == l && not (ub == InclusiveBound && lb == InclusiveBound)) - --- | Test if a version falls within the version intervals. --- --- It exists mostly for completeness and testing. It satisfies the following --- properties: --- --- > withinIntervals v (toVersionIntervals vr) = withinRange v vr --- > withinIntervals v ivs = withinRange v (fromVersionIntervals ivs) --- -withinIntervals :: Version -> VersionIntervals -> Bool -withinIntervals v (VersionIntervals intervals) = any withinInterval intervals - where - withinInterval (lowerBound, upperBound) = withinLower lowerBound - && withinUpper upperBound - withinLower (LowerBound v' ExclusiveBound) = v' < v - withinLower (LowerBound v' InclusiveBound) = v' <= v - - withinUpper NoUpperBound = True - withinUpper (UpperBound v' ExclusiveBound) = v' > v - withinUpper (UpperBound v' InclusiveBound) = v' >= v - --- | Convert a 'VersionRange' to a sequence of version intervals. --- -toVersionIntervals :: VersionRange -> VersionIntervals -toVersionIntervals = cataVersionRange alg where - alg (ThisVersionF v) = chkIvl (LowerBound v InclusiveBound, UpperBound v InclusiveBound) - alg (LaterVersionF v) = chkIvl (LowerBound v ExclusiveBound, NoUpperBound) - alg (OrLaterVersionF v) = chkIvl (LowerBound v InclusiveBound, NoUpperBound) - alg (EarlierVersionF v) - | isVersion0 v = VersionIntervals [] - | otherwise = chkIvl (minLowerBound, UpperBound v ExclusiveBound) - alg (OrEarlierVersionF v) = chkIvl (minLowerBound, UpperBound v InclusiveBound) - alg (MajorBoundVersionF v) = chkIvl (LowerBound v InclusiveBound, UpperBound (majorUpperBound v) ExclusiveBound) - alg (UnionVersionRangesF v1 v2) = unionVersionIntervals v1 v2 - alg (IntersectVersionRangesF v1 v2) = intersectVersionIntervals v1 v2 - - chkIvl interval = checkInvariant (VersionIntervals [interval]) - --- | Convert a 'VersionIntervals' value back into a 'VersionRange' expression --- representing the version intervals. --- -fromVersionIntervals :: VersionIntervals -> VersionRange -fromVersionIntervals (VersionIntervals []) = noVersion -fromVersionIntervals (VersionIntervals intervals) = - Prelude.foldr1 unionVersionRanges [ interval l u | (l, u) <- intervals ] - - where - interval (LowerBound v InclusiveBound) - (UpperBound v' InclusiveBound) | v == v' - = thisVersion v - interval l u = lowerBound l `intersectVersionRanges'` upperBound u - - lowerBound (LowerBound v InclusiveBound) - | isVersion0 v = Nothing - | otherwise = Just (orLaterVersion v) - lowerBound (LowerBound v ExclusiveBound) = Just (laterVersion v) - - upperBound NoUpperBound = Nothing - upperBound (UpperBound v InclusiveBound) = Just (orEarlierVersion v) - upperBound (UpperBound v ExclusiveBound) = Just (earlierVersion v) - - intersectVersionRanges' Nothing Nothing = anyVersion - intersectVersionRanges' (Just vr) Nothing = vr - intersectVersionRanges' Nothing (Just vr) = vr - intersectVersionRanges' (Just vr) (Just vr') = intersectVersionRanges vr vr' - -unionVersionIntervals :: VersionIntervals -> VersionIntervals - -> VersionIntervals -unionVersionIntervals (VersionIntervals is0) (VersionIntervals is'0) = - checkInvariant (VersionIntervals (union is0 is'0)) - where - union is [] = is - union [] is' = is' - union (i:is) (i':is') = case unionInterval i i' of - Left Nothing -> i : union is (i' :is') - Left (Just i'') -> union is (i'':is') - Right Nothing -> i' : union (i :is) is' - Right (Just i'') -> union (i'':is) is' - -unionInterval :: VersionInterval -> VersionInterval - -> Either (Maybe VersionInterval) (Maybe VersionInterval) -unionInterval (lower , upper ) (lower', upper') - - -- Non-intersecting intervals with the left interval ending first - | upper `doesNotTouch` lower' = Left Nothing - - -- Non-intersecting intervals with the right interval first - | upper' `doesNotTouch` lower = Right Nothing - - -- Complete or partial overlap, with the left interval ending first - | upper <= upper' = lowerBound `seq` - Left (Just (lowerBound, upper')) - - -- Complete or partial overlap, with the left interval ending first - | otherwise = lowerBound `seq` - Right (Just (lowerBound, upper)) - where - lowerBound = min lower lower' - -intersectVersionIntervals :: VersionIntervals -> VersionIntervals - -> VersionIntervals -intersectVersionIntervals (VersionIntervals is0) (VersionIntervals is'0) = - checkInvariant (VersionIntervals (intersect is0 is'0)) - where - intersect _ [] = [] - intersect [] _ = [] - intersect (i:is) (i':is') = case intersectInterval i i' of - Left Nothing -> intersect is (i':is') - Left (Just i'') -> i'' : intersect is (i':is') - Right Nothing -> intersect (i:is) is' - Right (Just i'') -> i'' : intersect (i:is) is' - -intersectInterval :: VersionInterval -> VersionInterval - -> Either (Maybe VersionInterval) (Maybe VersionInterval) -intersectInterval (lower , upper ) (lower', upper') - - -- Non-intersecting intervals with the left interval ending first - | upper `doesNotIntersect` lower' = Left Nothing - - -- Non-intersecting intervals with the right interval first - | upper' `doesNotIntersect` lower = Right Nothing - - -- Complete or partial overlap, with the left interval ending first - | upper <= upper' = lowerBound `seq` - Left (Just (lowerBound, upper)) - - -- Complete or partial overlap, with the right interval ending first - | otherwise = lowerBound `seq` - Right (Just (lowerBound, upper')) - where - lowerBound = max lower lower' - -invertVersionIntervals :: VersionIntervals - -> VersionIntervals -invertVersionIntervals (VersionIntervals xs) = - case xs of - -- Empty interval set - [] -> VersionIntervals [(noLowerBound, NoUpperBound)] - -- Interval with no lower bound - ((lb, ub) : more) | lb == noLowerBound -> - VersionIntervals $ invertVersionIntervals' ub more - -- Interval with a lower bound - ((lb, ub) : more) -> - VersionIntervals $ (noLowerBound, invertLowerBound lb) - : invertVersionIntervals' ub more - where - -- Invert subsequent version intervals given the upper bound of - -- the intervals already inverted. - invertVersionIntervals' :: UpperBound - -> [(LowerBound, UpperBound)] - -> [(LowerBound, UpperBound)] - invertVersionIntervals' NoUpperBound [] = [] - invertVersionIntervals' ub0 [] = [(invertUpperBound ub0, NoUpperBound)] - invertVersionIntervals' ub0 [(lb, NoUpperBound)] = - [(invertUpperBound ub0, invertLowerBound lb)] - invertVersionIntervals' ub0 ((lb, ub1) : more) = - (invertUpperBound ub0, invertLowerBound lb) - : invertVersionIntervals' ub1 more - - invertLowerBound :: LowerBound -> UpperBound - invertLowerBound (LowerBound v b) = UpperBound v (invertBound b) - - invertUpperBound :: UpperBound -> LowerBound - invertUpperBound (UpperBound v b) = LowerBound v (invertBound b) - invertUpperBound NoUpperBound = error "NoUpperBound: unexpected" - - invertBound :: Bound -> Bound - invertBound ExclusiveBound = InclusiveBound - invertBound InclusiveBound = ExclusiveBound - - noLowerBound :: LowerBound - noLowerBound = LowerBound (mkVersion [0]) InclusiveBound - - -relaxLastInterval :: VersionIntervals -> VersionIntervals -relaxLastInterval (VersionIntervals xs) = VersionIntervals (relaxLastInterval' xs) - where - relaxLastInterval' [] = [] - relaxLastInterval' [(l,_)] = [(l, NoUpperBound)] - relaxLastInterval' (i:is) = i : relaxLastInterval' is - -relaxHeadInterval :: VersionIntervals -> VersionIntervals -relaxHeadInterval (VersionIntervals xs) = VersionIntervals (relaxHeadInterval' xs) - where - relaxHeadInterval' [] = [] - relaxHeadInterval' ((_,u):is) = (minLowerBound,u) : is diff --git a/src/Distribution/Types/VersionRange.hs b/src/Distribution/Types/VersionRange.hs deleted file mode 100644 --- a/src/Distribution/Types/VersionRange.hs +++ /dev/null @@ -1,180 +0,0 @@ -module Distribution.Types.VersionRange ( - -- * Version ranges - VersionRange, - - -- ** Constructing - anyVersion, noVersion, - thisVersion, notThisVersion, - laterVersion, earlierVersion, - orLaterVersion, orEarlierVersion, - unionVersionRanges, intersectVersionRanges, - withinVersion, - majorBoundVersion, - - -- ** Inspection - -- - -- See "Distribution.Version" for more utilities. - withinRange, - foldVersionRange, - normaliseVersionRange, - stripParensVersionRange, - hasUpperBound, - hasLowerBound, - - -- ** Cata & ana - VersionRangeF (..), - cataVersionRange, - anaVersionRange, - hyloVersionRange, - projectVersionRange, - embedVersionRange, - - -- ** Utilities - isAnyVersion, - isAnyVersionLight, - wildcardUpperBound, - majorUpperBound, - isWildcardRange, - versionRangeParser, - ) where - -import Distribution.Compat.Prelude -import Distribution.Types.Version -import Distribution.Types.VersionInterval -import Distribution.Types.VersionRange.Internal -import Prelude () - --- | Fold over the basic syntactic structure of a 'VersionRange'. --- --- This provides a syntactic view of the expression defining the version range. --- The syntactic sugar @\">= v\"@, @\"<= v\"@ and @\"== v.*\"@ is presented --- in terms of the other basic syntax. --- --- For a semantic view use 'asVersionIntervals'. --- -foldVersionRange :: a -- ^ @\"-any\"@ version - -> (Version -> a) -- ^ @\"== v\"@ - -> (Version -> a) -- ^ @\"> v\"@ - -> (Version -> a) -- ^ @\"< v\"@ - -> (a -> a -> a) -- ^ @\"_ || _\"@ union - -> (a -> a -> a) -- ^ @\"_ && _\"@ intersection - -> VersionRange -> a -foldVersionRange _any this later earlier union intersect = fold - where - fold = cataVersionRange alg - - alg (ThisVersionF v) = this v - alg (LaterVersionF v) = later v - alg (OrLaterVersionF v) = union (this v) (later v) - alg (EarlierVersionF v) = earlier v - alg (OrEarlierVersionF v) = union (this v) (earlier v) - alg (MajorBoundVersionF v) = fold (majorBound v) - alg (UnionVersionRangesF v1 v2) = union v1 v2 - alg (IntersectVersionRangesF v1 v2) = intersect v1 v2 - - majorBound v = intersectVersionRanges - (orLaterVersion v) - (earlierVersion (majorUpperBound v)) - --- | Normalise 'VersionRange'. --- --- In particular collapse @(== v || > v)@ into @>= v@, and so on. -normaliseVersionRange :: VersionRange -> VersionRange -normaliseVersionRange = hyloVersionRange embed projectVersionRange - where - -- == v || > v, > v || == v ==> >= v - embed (UnionVersionRangesF (ThisVersion v) (LaterVersion v')) | v == v' = - orLaterVersion v - embed (UnionVersionRangesF (LaterVersion v) (ThisVersion v')) | v == v' = - orLaterVersion v - - -- == v || < v, < v || == v ==> <= v - embed (UnionVersionRangesF (ThisVersion v) (EarlierVersion v')) | v == v' = - orEarlierVersion v - embed (UnionVersionRangesF (EarlierVersion v) (ThisVersion v')) | v == v' = - orEarlierVersion v - - -- otherwise embed normally - embed vr = embedVersionRange vr - --- | Remove 'VersionRangeParens' constructors. --- --- Since version 3.4 this function is 'id', there aren't 'VersionRangeParens' constructor in 'VersionRange' anymore. --- --- @since 2.2 -stripParensVersionRange :: VersionRange -> VersionRange -stripParensVersionRange = id - --- | Does this version fall within the given range? --- --- This is the evaluation function for the 'VersionRange' type. --- -withinRange :: Version -> VersionRange -> Bool -withinRange v = foldVersionRange - True - (\v' -> v == v') - (\v' -> v > v') - (\v' -> v < v') - (||) - (&&) - --- | Does this 'VersionRange' place any restriction on the 'Version' or is it --- in fact equivalent to 'AnyVersion'. --- --- Note this is a semantic check, not simply a syntactic check. So for example --- the following is @True@ (for all @v@). --- --- > isAnyVersion (EarlierVersion v `UnionVersionRanges` orLaterVersion v) --- -isAnyVersion :: VersionRange -> Bool -isAnyVersion vr = case asVersionIntervals vr of - [VersionInterval (LowerBound v InclusiveBound) NoUpperBound] -> v == version0 - _ -> False - --- A fast and non-precise version of 'isAnyVersion', --- returns 'True' only for @>= 0@ 'VersionRange's. --- --- /Do not use/. The "VersionIntervals don't destroy MajorBoundVersion" --- https://github.com/haskell/cabal/pull/6736 pull-request --- will change 'simplifyVersionRange' to properly preserve semantics. --- Then we can use it to normalise 'VersionRange's in tests. --- -isAnyVersionLight :: VersionRange -> Bool -isAnyVersionLight (OrLaterVersion v) = v == version0 -isAnyVersionLight _vr = False - ----------------------------- --- Wildcard range utilities --- - - -isWildcardRange :: Version -> Version -> Bool -isWildcardRange ver1 ver2 = check (versionNumbers ver1) (versionNumbers ver2) - where check (n:[]) (m:[]) | n+1 == m = True - check (n:ns) (m:ms) | n == m = check ns ms - check _ _ = False - --- | Does the version range have an upper bound? --- --- @since 1.24.0.0 -hasUpperBound :: VersionRange -> Bool -hasUpperBound = foldVersionRange - False - (const True) - (const False) - (const True) - (&&) (||) - --- | Does the version range have an explicit lower bound? --- --- Note: this function only considers the user-specified lower bounds, but not --- the implicit >=0 lower bound. --- --- @since 1.24.0.0 -hasLowerBound :: VersionRange -> Bool -hasLowerBound = foldVersionRange - False - (const True) - (const True) - (const False) - (&&) (||) diff --git a/src/Distribution/Types/VersionRange/Internal.hs b/src/Distribution/Types/VersionRange/Internal.hs deleted file mode 100644 --- a/src/Distribution/Types/VersionRange/Internal.hs +++ /dev/null @@ -1,526 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} - --- | The only purpose of this module is to prevent the export of --- 'VersionRange' constructors from --- 'Distribution.Types.VersionRange'. To avoid creating orphan --- instances, a lot of related code had to be moved here too. - -module Distribution.Types.VersionRange.Internal - ( VersionRange(..) - , anyVersion, noVersion - , thisVersion, notThisVersion - , laterVersion, earlierVersion - , orLaterVersion, orEarlierVersion - , unionVersionRanges, intersectVersionRanges - , withinVersion - , majorBoundVersion - - , VersionRangeF(..) - , projectVersionRange - , embedVersionRange - , cataVersionRange - , anaVersionRange - , hyloVersionRange - , versionRangeParser - - , majorUpperBound - , wildcardUpperBound - ) where - -import Distribution.Compat.Prelude -import Distribution.Types.Version -import Prelude () - -import Distribution.CabalSpecVersion -import Distribution.Parsec -import Distribution.Pretty -import Distribution.Utils.Generic (unsnoc) - -import qualified Distribution.Compat.CharParsing as P -import qualified Distribution.Compat.DList as DList -import qualified Text.PrettyPrint as Disp - -data VersionRange - = ThisVersion Version -- = version - | LaterVersion Version -- > version (NB. not >=) - | OrLaterVersion Version -- >= version - | EarlierVersion Version -- < version - | OrEarlierVersion Version -- <= version - | MajorBoundVersion Version -- @^>= ver@ (same as >= ver && < MAJ(ver)+1) - | UnionVersionRanges VersionRange VersionRange - | IntersectVersionRanges VersionRange VersionRange - deriving ( Data, Eq, Generic, Read, Show, Typeable ) - -instance Binary VersionRange -instance Structured VersionRange -instance NFData VersionRange where rnf = genericRnf - --- | The version range @-any@. That is, a version range containing all --- versions. --- --- > withinRange v anyVersion = True --- -anyVersion :: VersionRange -anyVersion = OrLaterVersion (mkVersion [0]) - --- | The empty version range, that is a version range containing no versions. --- --- This can be constructed using any unsatisfiable version range expression, --- for example @< 0@. --- --- > withinRange v noVersion = False --- -noVersion :: VersionRange -noVersion = EarlierVersion (mkVersion [0]) - --- | The version range @== v@ --- --- > withinRange v' (thisVersion v) = v' == v --- -thisVersion :: Version -> VersionRange -thisVersion = ThisVersion - --- | The version range @< v || > v@ --- --- > withinRange v' (notThisVersion v) = v' /= v --- -notThisVersion :: Version -> VersionRange -notThisVersion v = UnionVersionRanges (EarlierVersion v) (LaterVersion v) - --- | The version range @> v@ --- --- > withinRange v' (laterVersion v) = v' > v --- -laterVersion :: Version -> VersionRange -laterVersion = LaterVersion - --- | The version range @>= v@ --- --- > withinRange v' (orLaterVersion v) = v' >= v --- -orLaterVersion :: Version -> VersionRange -orLaterVersion = OrLaterVersion - --- | The version range @< v@ --- --- > withinRange v' (earlierVersion v) = v' < v --- -earlierVersion :: Version -> VersionRange -earlierVersion = EarlierVersion - --- | The version range @<= v@ --- --- > withinRange v' (orEarlierVersion v) = v' <= v --- -orEarlierVersion :: Version -> VersionRange -orEarlierVersion = OrEarlierVersion - --- | The version range @vr1 || vr2@ --- --- > withinRange v' (unionVersionRanges vr1 vr2) --- > = withinRange v' vr1 || withinRange v' vr2 --- -unionVersionRanges :: VersionRange -> VersionRange -> VersionRange -unionVersionRanges = UnionVersionRanges - --- | The version range @vr1 && vr2@ --- --- > withinRange v' (intersectVersionRanges vr1 vr2) --- > = withinRange v' vr1 && withinRange v' vr2 --- -intersectVersionRanges :: VersionRange -> VersionRange -> VersionRange -intersectVersionRanges = IntersectVersionRanges - --- | The version range @== v.*@. --- --- For example, for version @1.2@, the version range @== 1.2.*@ is the same as --- @>= 1.2 && < 1.3@ --- --- > withinRange v' (laterVersion v) = v' >= v && v' < upper v --- > where --- > upper (Version lower t) = Version (init lower ++ [last lower + 1]) t --- -withinVersion :: Version -> VersionRange -withinVersion v = intersectVersionRanges - (orLaterVersion v) - (earlierVersion (wildcardUpperBound v)) - --- | The version range @^>= v@. --- --- For example, for version @1.2.3.4@, the version range @^>= 1.2.3.4@ --- is the same as @>= 1.2.3.4 && < 1.3@. --- --- Note that @^>= 1@ is equivalent to @>= 1 && < 1.1@. --- --- @since 2.0.0.2 -majorBoundVersion :: Version -> VersionRange -majorBoundVersion = MajorBoundVersion - - --- | F-Algebra of 'VersionRange'. See 'cataVersionRange'. --- --- @since 2.2 -data VersionRangeF a - = ThisVersionF Version -- = version - | LaterVersionF Version -- > version (NB. not >=) - | OrLaterVersionF Version -- >= version - | EarlierVersionF Version -- < version - | OrEarlierVersionF Version -- <= version - | MajorBoundVersionF Version -- @^>= ver@ (same as >= ver && < MAJ(ver)+1) - | UnionVersionRangesF a a - | IntersectVersionRangesF a a - deriving ( Data, Eq, Generic, Read, Show, Typeable - , Functor, Foldable, Traversable ) - --- | @since 2.2 -projectVersionRange :: VersionRange -> VersionRangeF VersionRange -projectVersionRange (ThisVersion v) = ThisVersionF v -projectVersionRange (LaterVersion v) = LaterVersionF v -projectVersionRange (OrLaterVersion v) = OrLaterVersionF v -projectVersionRange (EarlierVersion v) = EarlierVersionF v -projectVersionRange (OrEarlierVersion v) = OrEarlierVersionF v -projectVersionRange (MajorBoundVersion v) = MajorBoundVersionF v -projectVersionRange (UnionVersionRanges a b) = UnionVersionRangesF a b -projectVersionRange (IntersectVersionRanges a b) = IntersectVersionRangesF a b - --- | Fold 'VersionRange'. --- --- @since 2.2 -cataVersionRange :: (VersionRangeF a -> a) -> VersionRange -> a -cataVersionRange f = c where c = f . fmap c . projectVersionRange - --- | @since 2.2 -embedVersionRange :: VersionRangeF VersionRange -> VersionRange -embedVersionRange (ThisVersionF v) = ThisVersion v -embedVersionRange (LaterVersionF v) = LaterVersion v -embedVersionRange (OrLaterVersionF v) = OrLaterVersion v -embedVersionRange (EarlierVersionF v) = EarlierVersion v -embedVersionRange (OrEarlierVersionF v) = OrEarlierVersion v -embedVersionRange (MajorBoundVersionF v) = MajorBoundVersion v -embedVersionRange (UnionVersionRangesF a b) = UnionVersionRanges a b -embedVersionRange (IntersectVersionRangesF a b) = IntersectVersionRanges a b - --- | Unfold 'VersionRange'. --- --- @since 2.2 -anaVersionRange :: (a -> VersionRangeF a) -> a -> VersionRange -anaVersionRange g = a where a = embedVersionRange . fmap a . g - --- | Refold 'VersionRange' --- --- @since 2.2 -hyloVersionRange :: (VersionRangeF VersionRange -> VersionRange) - -> (VersionRange -> VersionRangeF VersionRange) - -> VersionRange -> VersionRange -hyloVersionRange f g = h where h = f . fmap h . g - -------------------------------------------------------------------------------- --- Parsec & Pretty -------------------------------------------------------------------------------- - --- | --- --- >>> fmap pretty (simpleParsec' CabalSpecV1_6 "== 3.2.*" :: Maybe VersionRange) --- Just >=3.2 && <3.3 --- --- >>> fmap (prettyVersioned CabalSpecV1_6) (simpleParsec' CabalSpecV1_6 "== 3.2.*" :: Maybe VersionRange) --- Just ==3.2.* --- --- >>> fmap pretty (simpleParsec' CabalSpecV1_6 "-any" :: Maybe VersionRange) --- Just >=0 --- --- >>> fmap (prettyVersioned CabalSpecV1_6) (simpleParsec' CabalSpecV1_6 "-any" :: Maybe VersionRange) --- Just >=0 --- -instance Pretty VersionRange where - pretty = prettyVersioned cabalSpecLatest - - prettyVersioned csv - | csv > CabalSpecV1_6 = prettyVersionRange - | otherwise = prettyVersionRange16 - -prettyVersionRange :: VersionRange -> Disp.Doc -prettyVersionRange vr = cataVersionRange alg vr 0 - where - alg :: VersionRangeF (Int -> Disp.Doc) -> Int -> Disp.Doc - alg (ThisVersionF v) _ = Disp.text "==" <<>> pretty v - alg (LaterVersionF v) _ = Disp.text ">" <<>> pretty v - alg (OrLaterVersionF v) _ = Disp.text ">=" <<>> pretty v - alg (EarlierVersionF v) _ = Disp.text "<" <<>> pretty v - alg (OrEarlierVersionF v) _ = Disp.text "<=" <<>> pretty v - alg (MajorBoundVersionF v) _ = Disp.text "^>=" <<>> pretty v - alg (UnionVersionRangesF r1 r2) d = parens (d > 0) - $ r1 1 <+> Disp.text "||" <+> r2 0 - alg (IntersectVersionRangesF r1 r2) d = parens (d > 1) - $ r1 2 <+> Disp.text "&&" <+> r2 1 - - parens True = Disp.parens - parens False = id - --- | Don't use && and || operators. If possible. -prettyVersionRange16 :: VersionRange -> Disp.Doc -prettyVersionRange16 (IntersectVersionRanges (OrLaterVersion v) (EarlierVersion u)) - | u == wildcardUpperBound v - = Disp.text "==" <<>> dispWild v - where - dispWild ver = - Disp.hcat (Disp.punctuate (Disp.char '.') - (map Disp.int $ versionNumbers ver)) - <<>> Disp.text ".*" - -prettyVersionRange16 vr = prettyVersionRange vr - --- | --- --- >>> simpleParsec "^>= 3.4" :: Maybe VersionRange --- Just (MajorBoundVersion (mkVersion [3,4])) --- --- Small history: --- --- @-any@ and @-none@ removed in 3.4 --- Use @>=0@ and @<0@ instead. --- --- >>> map (`simpleParsec'` "-none") [CabalSpecV3_0, CabalSpecV3_4] :: [Maybe VersionRange] --- [Just (EarlierVersion (mkVersion [0])),Nothing] --- --- Set operations are introduced in 3.0 --- --- >>> map (`simpleParsec'` "^>= { 1.2 , 1.3 }") [CabalSpecV2_4, CabalSpecV3_0] :: [Maybe VersionRange] --- [Nothing,Just (UnionVersionRanges (MajorBoundVersion (mkVersion [1,2])) (MajorBoundVersion (mkVersion [1,3])))] --- --- @^>=@ is introduced in 2.0 --- --- >>> map (`simpleParsec'` "^>=1.2") [CabalSpecV1_24, CabalSpecV2_0] :: [Maybe VersionRange] --- [Nothing,Just (MajorBoundVersion (mkVersion [1,2]))] --- --- @-none@ is introduced in 1.22 --- --- >>> map (`simpleParsec'` "-none") [CabalSpecV1_20, CabalSpecV1_22] :: [Maybe VersionRange] --- [Nothing,Just (EarlierVersion (mkVersion [0]))] --- --- Operators are introduced in 1.8. Issues only a warning. --- --- >>> map (`simpleParsecW'` "== 1 || ==2") [CabalSpecV1_6, CabalSpecV1_8] :: [Maybe VersionRange] --- [Nothing,Just (UnionVersionRanges (ThisVersion (mkVersion [1])) (ThisVersion (mkVersion [2])))] --- --- Wild-version ranges are introduced in 1.6. Issues only a warning. --- --- >>> map (`simpleParsecW'` "== 1.2.*") [CabalSpecV1_4, CabalSpecV1_6] :: [Maybe VersionRange] --- [Nothing,Just (IntersectVersionRanges (OrLaterVersion (mkVersion [1,2])) (EarlierVersion (mkVersion [1,3])))] --- -instance Parsec VersionRange where - parsec = askCabalSpecVersion >>= versionRangeParser versionDigitParser - --- | 'VersionRange' parser parametrised by version digit parser --- --- - 'versionDigitParser' is used for all 'VersionRange'. --- - 'P.integral' is used for backward-compat @pkgconfig-depends@ --- versions, 'PkgConfigVersionRange'. --- --- @since 3.0 -versionRangeParser :: forall m. CabalParsing m => m Int -> CabalSpecVersion -> m VersionRange -versionRangeParser digitParser csv = expr - where - expr = do P.spaces - t <- term - P.spaces - (do _ <- P.string "||" - checkOp - P.spaces - e <- expr - return (unionVersionRanges t e) - <|> - return t) - term = do f <- factor - P.spaces - (do _ <- P.string "&&" - checkOp - P.spaces - t <- term - return (intersectVersionRanges f t) - <|> - return f) - factor = parens expr <|> prim - - prim = do - op <- P.munch1 isOpChar P. "operator" - case op of - "-" -> anyVersion <$ P.string "any" <|> P.string "none" *> noVersion' - - "==" -> do - P.spaces - (do (wild, v) <- verOrWild - checkWild wild - pure $ (if wild then withinVersion else thisVersion) v - <|> - (verSet' thisVersion =<< verSet)) - - "^>=" -> do - P.spaces - (do (wild, v) <- verOrWild - when wild $ P.unexpected $ - "wild-card version after ^>= operator" - majorBoundVersion' v - <|> - (verSet' majorBoundVersion =<< verSet)) - - _ -> do - P.spaces - (wild, v) <- verOrWild - when wild $ P.unexpected $ - "wild-card version after non-== operator: " ++ show op - case op of - ">=" -> pure $ orLaterVersion v - "<" -> pure $ earlierVersion v - "<=" -> pure $ orEarlierVersion v - ">" -> pure $ laterVersion v - _ -> fail $ "Unknown version operator " ++ show op - - -- Cannot be warning - -- On 2020-03-16 there was around 27400 files on Hackage failing to parse due this - -- For example https://hackage.haskell.org/package/haxr-3000.0.0/haxr.cabal - -- - checkOp = when (csv < CabalSpecV1_8) $ - parsecWarning PWTVersionOperator $ unwords - [ "version operators used." - , "To use version operators the package needs to specify at least 'cabal-version: >= 1.8'." - ] - - -- Cannot be warning - -- On 2020-03-16 there was 46 files on Hackage failing to parse due this - -- For example https://hackage.haskell.org/package/derive-0.1.2/derive.cabal - -- - checkWild False = pure () - checkWild True = when (csv < CabalSpecV1_6) $ - parsecWarning PWTVersionWildcard $ unwords - [ "Wildcard syntax used." - , "To use version wildcards the package needs to specify at least 'cabal-version: >= 1.6'." - ] - - -- https://gitlab.haskell.org/ghc/ghc/issues/17752 - isOpChar '<' = True - isOpChar '=' = True - isOpChar '>' = True - isOpChar '^' = True - isOpChar '-' = csv < CabalSpecV3_4 - -- https://github.com/haskell/cabal/issues/6589 - -- Unfortunately we have must not consume the dash, - -- as otherwise following parts may not be parsed. - -- - -- i.e. we cannot fail here with good error. - isOpChar _ = False - - -- -none version range is available since 1.22 - noVersion' = - if csv >= CabalSpecV1_22 - then pure noVersion - else fail $ unwords - [ "-none version range used." - , "To use this syntax the package needs to specify at least 'cabal-version: 1.22'." - , "Alternatively, if broader compatibility is important then use" - , "<0 or other empty range." - ] - - -- ^>= is available since 2.0 - majorBoundVersion' v = - if csv >= CabalSpecV2_0 - then pure $ majorBoundVersion v - else fail $ unwords - [ "major bounded version syntax (caret, ^>=) used." - , "To use this syntax the package need to specify at least 'cabal-version: 2.0'." - , "Alternatively, if broader compatibility is important then use:" - , prettyShow $ eliminateMajorBoundSyntax $ majorBoundVersion v - ] - where - eliminateMajorBoundSyntax = hyloVersionRange embed projectVersionRange - embed (MajorBoundVersionF u) = intersectVersionRanges - (orLaterVersion u) (earlierVersion (majorUpperBound u)) - embed vr = embedVersionRange vr - - -- version set notation (e.g. "== { 0.0.1.0, 0.0.2.0, 0.1.0.0 }") - verSet' op vs = - if csv >= CabalSpecV3_0 - then pure $ foldr1 unionVersionRanges (fmap op vs) - else fail $ unwords - [ "version set syntax used." - , "To use this syntax the package needs to specify at least 'cabal-version: 3.0'." - , "Alternatively, if broader compatibility is important then use" - , "a series of single version constraints joined with the || operator:" - , prettyShow (foldr1 unionVersionRanges (fmap op vs)) - ] - - verSet :: CabalParsing m => m (NonEmpty Version) - verSet = do - _ <- P.char '{' - P.spaces - vs <- P.sepByNonEmpty (verPlain <* P.spaces) (P.char ',' *> P.spaces) - _ <- P.char '}' - pure vs - - -- a plain version without tags or wildcards - verPlain :: CabalParsing m => m Version - verPlain = mkVersion <$> toList <$> P.sepByNonEmpty digitParser (P.char '.') - - -- either wildcard or normal version - verOrWild :: CabalParsing m => m (Bool, Version) - verOrWild = do - x <- digitParser - verLoop (DList.singleton x) - - -- trailing: wildcard (.y.*) or normal version (optional tags) (.y.z-tag) - verLoop :: CabalParsing m => DList.DList Int -> m (Bool, Version) - verLoop acc = verLoop' acc - <|> (tags *> pure (False, mkVersion (DList.toList acc))) - - verLoop' :: CabalParsing m => DList.DList Int -> m (Bool, Version) - verLoop' acc = do - _ <- P.char '.' - let digit = digitParser >>= verLoop . DList.snoc acc - let wild = (True, mkVersion (DList.toList acc)) <$ P.char '*' - digit <|> wild - - parens p = P.between - ((P.char '(' P. "opening paren") >> P.spaces) - (P.char ')' >> P.spaces) - $ do - a <- p - P.spaces - return a - - tags :: CabalParsing m => m () - tags = do - ts <- many $ P.char '-' *> some (P.satisfy isAlphaNum) - case ts of - [] -> pure () - (_ : _) -> parsecWarning PWTVersionTag "version with tags" - - ----------------------------- --- Wildcard range utilities --- - --- | Compute next greater major version to be used as upper bound --- --- Example: @0.4.1@ produces the version @0.5@ which then can be used --- to construct a range @>= 0.4.1 && < 0.5@ --- --- @since 2.2 -majorUpperBound :: Version -> Version -majorUpperBound = alterVersion $ \numbers -> case numbers of - [] -> [0,1] -- should not happen - [m1] -> [m1,1] -- e.g. version '1' - (m1:m2:_) -> [m1,m2+1] - --- | @since 2.2 -wildcardUpperBound :: Version -> Version -wildcardUpperBound = alterVersion $ - \lowerBound -> case unsnoc lowerBound of - Nothing -> [] - Just (xs, x) -> xs ++ [x + 1] diff --git a/src/Distribution/Utils/Base62.hs b/src/Distribution/Utils/Base62.hs deleted file mode 100644 --- a/src/Distribution/Utils/Base62.hs +++ /dev/null @@ -1,22 +0,0 @@ - --- | Implementation of base-62 encoding, which we use when computing hashes --- for fully instantiated unit ids. -module Distribution.Utils.Base62 (hashToBase62) where - -import GHC.Fingerprint ( Fingerprint(..), fingerprintString ) -import Numeric ( showIntAtBase ) -import Data.Char ( chr ) - --- | Hash a string using GHC's fingerprinting algorithm (a 128-bit --- MD5 hash) and then encode the resulting hash in base 62. -hashToBase62 :: String -> String -hashToBase62 s = showFingerprint $ fingerprintString s - where - showIntAtBase62 x = showIntAtBase 62 representBase62 x "" - representBase62 x - | x < 10 = chr (48 + x) - | x < 36 = chr (65 + x - 10) - | x < 62 = chr (97 + x - 36) - | otherwise = '@' - showFingerprint (Fingerprint a b) = showIntAtBase62 a ++ showIntAtBase62 b - diff --git a/src/Distribution/Utils/Generic.hs b/src/Distribution/Utils/Generic.hs deleted file mode 100644 --- a/src/Distribution/Utils/Generic.hs +++ /dev/null @@ -1,576 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE BangPatterns #-} - ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.Utils --- Copyright : Isaac Jones, Simon Marlow 2003-2004 --- License : BSD3 --- portions Copyright (c) 2007, Galois Inc. --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- A large and somewhat miscellaneous collection of utility functions used --- throughout the rest of the Cabal lib and in other tools that use the Cabal --- lib like @cabal-install@. It has a very simple set of logging actions. It --- has low level functions for running programs, a bunch of wrappers for --- various directory and file functions that do extra logging. - -module Distribution.Utils.Generic ( - -- * reading and writing files safely - withFileContents, - writeFileAtomic, - - -- * Unicode - - -- ** Conversions - fromUTF8BS, - fromUTF8LBS, - - toUTF8BS, - toUTF8LBS, - - validateUTF8, - - -- ** File I/O - readUTF8File, - withUTF8FileContents, - writeUTF8File, - - -- ** BOM - ignoreBOM, - - -- ** Misc - normaliseLineEndings, - - -- * generic utils - dropWhileEndLE, - takeWhileEndLE, - equating, - comparing, - isInfixOf, - intercalate, - lowercase, - isAscii, - isAsciiAlpha, - isAsciiAlphaNum, - listUnion, - listUnionRight, - ordNub, - ordNubBy, - ordNubRight, - safeHead, - safeTail, - safeLast, - safeInit, - unintersperse, - wrapText, - wrapLine, - unfoldrM, - spanMaybe, - breakMaybe, - unsnoc, - unsnocNE, - - -- * Triples - fstOf3, - sndOf3, - trdOf3, - - -- * FilePath stuff - isAbsoluteOnAnyPlatform, - isRelativeOnAnyPlatform, - ) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Utils.String - -import Data.Bits ((.&.), (.|.), shiftL) -import Data.List - ( isInfixOf ) -import qualified Data.Set as Set -import qualified Data.ByteString as SBS -import qualified Data.ByteString.Lazy as LBS - -import System.Directory - ( removeFile, renameFile ) -import System.FilePath - ( (<.>), splitFileName ) -import System.IO - ( withFile, withBinaryFile - , openBinaryTempFileWithDefaultPermissions - , IOMode(ReadMode), hGetContents, hClose ) -import qualified Control.Exception as Exception - --- ----------------------------------------------------------------------------- --- Helper functions - --- | Wraps text to the default line width. Existing newlines are preserved. -wrapText :: String -> String -wrapText = unlines - . map (intercalate "\n" - . map unwords - . wrapLine 79 - . words) - . lines - --- | Wraps a list of words to a list of lines of words of a particular width. -wrapLine :: Int -> [String] -> [[String]] -wrapLine width = wrap 0 [] - where wrap :: Int -> [String] -> [String] -> [[String]] - wrap 0 [] (w:ws) - | length w + 1 > width - = wrap (length w) [w] ws - wrap col line (w:ws) - | col + length w + 1 > width - = reverse line : wrap 0 [] (w:ws) - wrap col line (w:ws) - = let col' = col + length w + 1 - in wrap col' (w:line) ws - wrap _ [] [] = [] - wrap _ line [] = [reverse line] - ------------------------------------ --- Safely reading and writing files - --- | Gets the contents of a file, but guarantee that it gets closed. --- --- The file is read lazily but if it is not fully consumed by the action then --- the remaining input is truncated and the file is closed. --- -withFileContents :: FilePath -> (String -> IO a) -> IO a -withFileContents name action = - withFile name ReadMode - (\hnd -> hGetContents hnd >>= action) - --- | Writes a file atomically. --- --- The file is either written successfully or an IO exception is raised and --- the original file is left unchanged. --- --- On windows it is not possible to delete a file that is open by a process. --- This case will give an IO exception but the atomic property is not affected. --- -writeFileAtomic :: FilePath -> LBS.ByteString -> IO () -writeFileAtomic targetPath content = do - let (targetDir, targetFile) = splitFileName targetPath - Exception.bracketOnError - (openBinaryTempFileWithDefaultPermissions targetDir $ targetFile <.> "tmp") - (\(tmpPath, handle) -> hClose handle >> removeFile tmpPath) - (\(tmpPath, handle) -> do - LBS.hPut handle content - hClose handle - renameFile tmpPath targetPath) - --- ------------------------------------------------------------ --- * Unicode stuff --- ------------------------------------------------------------ - --- | Decode 'String' from UTF8-encoded 'BS.ByteString' --- --- Invalid data in the UTF8 stream (this includes code-points @U+D800@ --- through @U+DFFF@) will be decoded as the replacement character (@U+FFFD@). --- -fromUTF8BS :: SBS.ByteString -> String -fromUTF8BS = decodeStringUtf8 . SBS.unpack - --- | Variant of 'fromUTF8BS' for lazy 'BS.ByteString's --- -fromUTF8LBS :: LBS.ByteString -> String -fromUTF8LBS = decodeStringUtf8 . LBS.unpack - --- | Encode 'String' to UTF8-encoded 'SBS.ByteString' --- --- Code-points in the @U+D800@-@U+DFFF@ range will be encoded --- as the replacement character (i.e. @U+FFFD@). --- -toUTF8BS :: String -> SBS.ByteString -toUTF8BS = SBS.pack . encodeStringUtf8 - --- | Variant of 'toUTF8BS' for lazy 'BS.ByteString's --- -toUTF8LBS :: String -> LBS.ByteString -toUTF8LBS = LBS.pack . encodeStringUtf8 - --- | Check that strict 'ByteString' is valid UTF8. Returns 'Just offset' if it's not. -validateUTF8 :: SBS.ByteString -> Maybe Int -validateUTF8 = go 0 where - go off bs = case SBS.uncons bs of - Nothing -> Nothing - Just (c, bs') - | c <= 0x7F -> go (off + 1) bs' - | c <= 0xBF -> Just off - | c <= 0xDF -> twoBytes off c bs' - | c <= 0xEF -> moreBytes off 3 0x800 bs' (fromIntegral $ c .&. 0xF) - | c <= 0xF7 -> moreBytes off 4 0x10000 bs' (fromIntegral $ c .&. 0x7) - | c <= 0xFB -> moreBytes off 5 0x200000 bs' (fromIntegral $ c .&. 0x3) - | c <= 0xFD -> moreBytes off 6 0x4000000 bs' (fromIntegral $ c .&. 0x1) - | otherwise -> Just off - - twoBytes off c0 bs = case SBS.uncons bs of - Nothing -> Just off - Just (c1, bs') - | c1 .&. 0xC0 == 0x80 -> - if d >= (0x80 :: Int) - then go (off + 2) bs' - else Just off - | otherwise -> Just off - where - d = (fromIntegral (c0 .&. 0x1F) `shiftL` 6) .|. fromIntegral (c1 .&. 0x3F) - - moreBytes :: Int -> Int -> Int -> SBS.ByteString -> Int -> Maybe Int - moreBytes off 1 overlong cs' acc - | overlong <= acc, acc <= 0x10FFFF, acc < 0xD800 || 0xDFFF < acc - = go (off + 1) cs' - - | otherwise - = Just off - - moreBytes off byteCount overlong bs acc = case SBS.uncons bs of - Just (cn, bs') | cn .&. 0xC0 == 0x80 -> - moreBytes (off + 1) (byteCount-1) overlong bs' ((acc `shiftL` 6) .|. fromIntegral cn .&. 0x3F) - _ -> Just off - - --- | Ignore a Unicode byte order mark (BOM) at the beginning of the input --- -ignoreBOM :: String -> String -ignoreBOM ('\xFEFF':string) = string -ignoreBOM string = string - --- | Reads a UTF8 encoded text file as a Unicode String --- --- Reads lazily using ordinary 'readFile'. --- -readUTF8File :: FilePath -> IO String -readUTF8File f = (ignoreBOM . fromUTF8LBS) <$> LBS.readFile f - --- | Reads a UTF8 encoded text file as a Unicode String --- --- Same behaviour as 'withFileContents'. --- -withUTF8FileContents :: FilePath -> (String -> IO a) -> IO a -withUTF8FileContents name action = - withBinaryFile name ReadMode - (\hnd -> LBS.hGetContents hnd >>= action . ignoreBOM . fromUTF8LBS) - --- | Writes a Unicode String as a UTF8 encoded text file. --- --- Uses 'writeFileAtomic', so provides the same guarantees. --- -writeUTF8File :: FilePath -> String -> IO () -writeUTF8File path = writeFileAtomic path . toUTF8LBS - --- | Fix different systems silly line ending conventions -normaliseLineEndings :: String -> String -normaliseLineEndings [] = [] -normaliseLineEndings ('\r':'\n':s) = '\n' : normaliseLineEndings s -- windows -normaliseLineEndings ('\r':s) = '\n' : normaliseLineEndings s -- old OS X -normaliseLineEndings ( c :s) = c : normaliseLineEndings s - --- ------------------------------------------------------------ --- * Common utils --- ------------------------------------------------------------ - --- | @dropWhileEndLE p@ is equivalent to @reverse . dropWhile p . reverse@, but --- quite a bit faster. The difference between "Data.List.dropWhileEnd" and this --- version is that the one in "Data.List" is strict in elements, but spine-lazy, --- while this one is spine-strict but lazy in elements. That's what @LE@ stands --- for - "lazy in elements". --- --- Example: --- --- >>> safeTail $ Data.List.dropWhileEnd (<3) [undefined, 5, 4, 3, 2, 1] --- *** Exception: Prelude.undefined --- ... --- --- >>> safeTail $ dropWhileEndLE (<3) [undefined, 5, 4, 3, 2, 1] --- [5,4,3] --- --- >>> take 3 $ Data.List.dropWhileEnd (<3) [5, 4, 3, 2, 1, undefined] --- [5,4,3] --- --- >>> take 3 $ dropWhileEndLE (<3) [5, 4, 3, 2, 1, undefined] --- *** Exception: Prelude.undefined --- ... --- -dropWhileEndLE :: (a -> Bool) -> [a] -> [a] -dropWhileEndLE p = foldr (\x r -> if null r && p x then [] else x:r) [] - --- | @takeWhileEndLE p@ is equivalent to @reverse . takeWhile p . reverse@, but --- is usually faster (as well as being easier to read). -takeWhileEndLE :: (a -> Bool) -> [a] -> [a] -takeWhileEndLE p = fst . foldr go ([], False) - where - go x (rest, done) - | not done && p x = (x:rest, False) - | otherwise = (rest, True) - --- | Like 'Data.List.nub', but has @O(n log n)@ complexity instead of --- @O(n^2)@. Code for 'ordNub' and 'listUnion' taken from Niklas Hambüchen's --- package. -ordNub :: Ord a => [a] -> [a] -ordNub = ordNubBy id - --- | Like 'ordNub' and 'Data.List.nubBy'. Selects a key for each element and --- takes the nub based on that key. -ordNubBy :: Ord b => (a -> b) -> [a] -> [a] -ordNubBy f l = go Set.empty l - where - go !_ [] = [] - go !s (x:xs) - | y `Set.member` s = go s xs - | otherwise = let !s' = Set.insert y s - in x : go s' xs - where - y = f x - --- | Like "Data.List.union", but has @O(n log n)@ complexity instead of --- @O(n^2)@. -listUnion :: (Ord a) => [a] -> [a] -> [a] -listUnion a b = a ++ ordNub (filter (`Set.notMember` aSet) b) - where - aSet = Set.fromList a - --- | A right-biased version of 'ordNub'. --- --- Example: --- --- >>> ordNub [1,2,1] :: [Int] --- [1,2] --- --- >>> ordNubRight [1,2,1] :: [Int] --- [2,1] --- -ordNubRight :: (Ord a) => [a] -> [a] -ordNubRight = fst . foldr go ([], Set.empty) - where - go x p@(l, s) = if x `Set.member` s then p - else (x:l, Set.insert x s) - --- | A right-biased version of 'listUnion'. --- --- Example: --- --- >>> listUnion [1,2,3,4,3] [2,1,1] --- [1,2,3,4,3] --- --- >>> listUnionRight [1,2,3,4,3] [2,1,1] --- [4,3,2,1,1] --- -listUnionRight :: (Ord a) => [a] -> [a] -> [a] -listUnionRight a b = ordNubRight (filter (`Set.notMember` bSet) a) ++ b - where - bSet = Set.fromList b - --- | A total variant of 'head'. --- --- @since 3.2.0.0 -safeHead :: [a] -> Maybe a -safeHead [] = Nothing -safeHead (x:_) = Just x - --- | A total variant of 'tail'. --- --- @since 3.2.0.0 -safeTail :: [a] -> [a] -safeTail [] = [] -safeTail (_:xs) = xs - --- | A total variant of 'last'. --- --- @since 3.2.0.0 -safeLast :: [a] -> Maybe a -safeLast [] = Nothing -safeLast (x:xs) = Just (foldl (\_ a -> a) x xs) - --- | A total variant of 'init'. --- --- @since 3.2.0.0 -safeInit :: [a] -> [a] -safeInit [] = [] -safeInit [_] = [] -safeInit (x:xs) = x : safeInit xs - -equating :: Eq a => (b -> a) -> b -> b -> Bool -equating p x y = p x == p y - --- | Lower case string --- --- >>> lowercase "Foobar" --- "foobar" -lowercase :: String -> String -lowercase = map toLower - --- | Ascii characters -isAscii :: Char -> Bool -isAscii c = fromEnum c < 0x80 - --- | Ascii letters. -isAsciiAlpha :: Char -> Bool -isAsciiAlpha c = ('a' <= c && c <= 'z') - || ('A' <= c && c <= 'Z') - --- | Ascii letters and digits. --- --- >>> isAsciiAlphaNum 'a' --- True --- --- >>> isAsciiAlphaNum 'ä' --- False --- -isAsciiAlphaNum :: Char -> Bool -isAsciiAlphaNum c = isAscii c && isAlphaNum c - -unintersperse :: Char -> String -> [String] -unintersperse mark = unfoldr unintersperse1 where - unintersperse1 str - | null str = Nothing - | otherwise = - let (this, rest) = break (== mark) str in - Just (this, safeTail rest) - --- | Like 'break', but with 'Maybe' predicate --- --- >>> breakMaybe (readMaybe :: String -> Maybe Int) ["foo", "bar", "1", "2", "quu"] --- (["foo","bar"],Just (1,["2","quu"])) --- --- >>> breakMaybe (readMaybe :: String -> Maybe Int) ["foo", "bar"] --- (["foo","bar"],Nothing) --- --- @since 2.2 --- -breakMaybe :: (a -> Maybe b) -> [a] -> ([a], Maybe (b, [a])) -breakMaybe f = go id where - go !acc [] = (acc [], Nothing) - go !acc (x:xs) = case f x of - Nothing -> go (acc . (x:)) xs - Just b -> (acc [], Just (b, xs)) - --- | Like 'span' but with 'Maybe' predicate --- --- >>> spanMaybe listToMaybe [[1,2],[3],[],[4,5],[6,7]] --- ([1,3],[[],[4,5],[6,7]]) --- --- >>> spanMaybe (readMaybe :: String -> Maybe Int) ["1", "2", "foo"] --- ([1,2],["foo"]) --- --- @since 2.2 --- -spanMaybe :: (a -> Maybe b) -> [a] -> ([b],[a]) -spanMaybe _ xs@[] = ([], xs) -spanMaybe p xs@(x:xs') = case p x of - Just y -> let (ys, zs) = spanMaybe p xs' in (y : ys, zs) - Nothing -> ([], xs) - --- | 'unfoldr' with monadic action. --- --- >>> take 5 $ unfoldrM (\b r -> Just (r + b, b + 1)) (1 :: Int) 2 --- [3,4,5,6,7] --- --- @since 2.2 --- -unfoldrM :: Monad m => (b -> m (Maybe (a, b))) -> b -> m [a] -unfoldrM f = go where - go b = do - m <- f b - case m of - Nothing -> return [] - Just (a, b') -> liftM (a :) (go b') - --- | The opposite of 'snoc', which is the reverse of 'cons' --- --- Example: --- --- >>> unsnoc [1, 2, 3] --- Just ([1,2],3) --- --- >>> unsnoc [] --- Nothing --- --- @since 3.2.0.0 --- -unsnoc :: [a] -> Maybe ([a], a) -unsnoc [] = Nothing -unsnoc (x:xs) = Just (unsnocNE (x :| xs)) - --- | Like 'unsnoc', but for 'NonEmpty' so without the 'Maybe' --- --- Example: --- --- >>> unsnocNE (1 :| [2, 3]) --- ([1,2],3) --- --- >>> unsnocNE (1 :| []) --- ([],1) --- --- @since 3.2.0.0 --- -unsnocNE :: NonEmpty a -> ([a], a) -unsnocNE (x:|xs) = go x xs where - go y [] = ([], y) - go y (z:zs) = let ~(ws, w) = go z zs in (y : ws, w) - -------------------------------------------------------------------------------- --- Triples -------------------------------------------------------------------------------- - --- | @since 3.4.0.0 -fstOf3 :: (a,b,c) -> a -fstOf3 (a,_,_) = a - --- | @since 3.4.0.0 -sndOf3 :: (a,b,c) -> b -sndOf3 (_,b,_) = b - --- | @since 3.4.0.0 -trdOf3 :: (a,b,c) -> c -trdOf3 (_,_,c) = c - --- ------------------------------------------------------------ --- * FilePath stuff --- ------------------------------------------------------------ - --- | 'isAbsoluteOnAnyPlatform' and 'isRelativeOnAnyPlatform' are like --- 'System.FilePath.isAbsolute' and 'System.FilePath.isRelative' but have --- platform independent heuristics. --- The System.FilePath exists in two versions, Windows and Posix. The two --- versions don't agree on what is a relative path and we don't know if we're --- given Windows or Posix paths. --- This results in false positives when running on Posix and inspecting --- Windows paths, like the hackage server does. --- System.FilePath.Posix.isAbsolute \"C:\\hello\" == False --- System.FilePath.Windows.isAbsolute \"/hello\" == False --- This means that we would treat paths that start with \"/\" to be absolute. --- On Posix they are indeed absolute, while on Windows they are not. --- --- The portable versions should be used when we might deal with paths that --- are from another OS than the host OS. For example, the Hackage Server --- deals with both Windows and Posix paths while performing the --- PackageDescription checks. In contrast, when we run 'cabal configure' we --- do expect the paths to be correct for our OS and we should not have to use --- the platform independent heuristics. -isAbsoluteOnAnyPlatform :: FilePath -> Bool --- C:\\directory -isAbsoluteOnAnyPlatform (drive:':':'\\':_) = isAlpha drive -isAbsoluteOnAnyPlatform (drive:':':'/':_) = isAlpha drive --- UNC -isAbsoluteOnAnyPlatform ('\\':'\\':_) = True --- Posix root -isAbsoluteOnAnyPlatform ('/':_) = True -isAbsoluteOnAnyPlatform _ = False - --- | @isRelativeOnAnyPlatform = not . 'isAbsoluteOnAnyPlatform'@ -isRelativeOnAnyPlatform :: FilePath -> Bool -isRelativeOnAnyPlatform = not . isAbsoluteOnAnyPlatform - --- $setup --- >>> import Data.Maybe --- >>> import Text.Read diff --git a/src/Distribution/Utils/IOData.hs b/src/Distribution/Utils/IOData.hs --- a/src/Distribution/Utils/IOData.hs +++ b/src/Distribution/Utils/IOData.hs @@ -1,4 +1,5 @@ {-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE RankNTypes #-} -- | @since 2.2.0 module Distribution.Utils.IOData diff --git a/src/Distribution/Utils/Json.hs b/src/Distribution/Utils/Json.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Utils/Json.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE OverloadedStrings #-} +-- | Extremely simple JSON helper. Don't do anything too fancy with this! + +module Distribution.Utils.Json + ( Json(..) + , (.=) + , renderJson + ) where + +import Distribution.Compat.Prelude +import qualified Data.ByteString.Lazy as LBS +import Data.ByteString.Builder + ( Builder, stringUtf8, intDec, toLazyByteString ) + +data Json = JsonArray [Json] + | JsonBool !Bool + | JsonNull + | JsonNumber !Int -- No support for Floats, Doubles just yet + | JsonObject [(String, Json)] + | JsonString !String + deriving Show + +-- | Convert a 'Json' into a 'ByteString' +renderJson :: Json -> LBS.ByteString +renderJson json = toLazyByteString (go json) + where + go (JsonArray objs) = + surround "[" "]" $ mconcat $ intersperse "," $ map go objs + go (JsonBool True) = stringUtf8 "true" + go (JsonBool False) = stringUtf8 "false" + go JsonNull = stringUtf8 "null" + go (JsonNumber n) = intDec n + go (JsonObject attrs) = + surround "{" "}" $ mconcat $ intersperse "," $ map render attrs + where + render (k,v) = (surround "\"" "\"" $ stringUtf8 (escape k)) <> ":" <> go v + go (JsonString s) = surround "\"" "\"" $ stringUtf8 (escape s) + +surround :: Builder -> Builder -> Builder -> Builder +surround begin end middle = mconcat [ begin , middle , end] + +escape :: String -> String +escape ('\"':xs) = "\\\"" <> escape xs +escape ('\\':xs) = "\\\\" <> escape xs +escape ('\b':xs) = "\\b" <> escape xs +escape ('\f':xs) = "\\f" <> escape xs +escape ('\n':xs) = "\\n" <> escape xs +escape ('\r':xs) = "\\r" <> escape xs +escape ('\t':xs) = "\\t" <> escape xs +escape (x:xs) = x : escape xs +escape [] = mempty + +-- | A shorthand for building up 'JsonObject's +-- >>> JsonObject [ "a" .= JsonNumber 42, "b" .= JsonBool True ] +-- JsonObject [("a",JsonNumber 42),("b",JsonBool True)] +(.=) :: String -> Json -> (String, Json) +k .= v = (k, v) diff --git a/src/Distribution/Utils/MD5.hs b/src/Distribution/Utils/MD5.hs deleted file mode 100644 --- a/src/Distribution/Utils/MD5.hs +++ /dev/null @@ -1,79 +0,0 @@ -module Distribution.Utils.MD5 ( - MD5, - showMD5, - md5, - -- * Helpers - md5FromInteger, - -- * Binary - binaryPutMD5, - binaryGetMD5, - ) where - -import Data.Binary (Get, Put) -import Data.Binary.Get (getWord64le) -import Data.Binary.Put (putWord64le) -import Data.Bits (complement, shiftR, (.&.)) -import Foreign.Ptr (castPtr) -import GHC.Fingerprint (Fingerprint (..), fingerprintData) -import Numeric (showHex) -import System.IO.Unsafe (unsafeDupablePerformIO) - -import qualified Data.ByteString as BS -import qualified Data.ByteString.Unsafe as BS - -type MD5 = Fingerprint - --- | Show 'MD5' in human readable form --- --- >>> showMD5 (Fingerprint 123 456) --- "000000000000007b00000000000001c8" --- --- >>> showMD5 $ md5 $ BS.pack [0..127] --- "37eff01866ba3f538421b30b7cbefcac" --- --- @since 3.2.0.0 -showMD5 :: MD5 -> String -showMD5 (Fingerprint a b) = pad a' ++ pad b' where - a' = showHex a "" - b' = showHex b "" - pad s = replicate (16 - length s) '0' ++ s - --- | @since 3.2.0.0 -md5 :: BS.ByteString -> MD5 -md5 bs = unsafeDupablePerformIO $ BS.unsafeUseAsCStringLen bs $ \(ptr, len) -> - fingerprintData (castPtr ptr) len - --- | @since 3.2.0.0 -binaryPutMD5 :: MD5 -> Put -binaryPutMD5 (Fingerprint a b) = do - putWord64le a - putWord64le b - --- | @since 3.2.0.0 -binaryGetMD5 :: Get MD5 -binaryGetMD5 = do - a <- getWord64le - b <- getWord64le - return (Fingerprint a b) - --- | --- --- >>> showMD5 $ md5FromInteger 0x37eff01866ba3f538421b30b7cbefcac --- "37eff01866ba3f538421b30b7cbefcac" --- --- Note: the input is truncated: --- --- >>> showMD5 $ md5FromInteger 0x1230000037eff01866ba3f538421b30b7cbefcac --- "37eff01866ba3f538421b30b7cbefcac" --- --- Yet, negative numbers are not a problem... --- --- >>> showMD5 $ md5FromInteger (-1) --- "ffffffffffffffffffffffffffffffff" --- --- @since 3.4.0.0 -md5FromInteger :: Integer -> MD5 -md5FromInteger i = Fingerprint hi lo where - mask = complement 0 - lo = mask .&. fromInteger i - hi = mask .&. fromInteger (i `shiftR` 64) diff --git a/src/Distribution/Utils/MapAccum.hs b/src/Distribution/Utils/MapAccum.hs --- a/src/Distribution/Utils/MapAccum.hs +++ b/src/Distribution/Utils/MapAccum.hs @@ -10,25 +10,13 @@ instance Functor m => Functor (StateM s m) where fmap f (StateM x) = StateM $ \s -> fmap (\(s', a) -> (s', f a)) (x s) -instance -#if __GLASGOW_HASKELL__ < 709 - (Functor m, Monad m) -#else - Monad m -#endif - => Applicative (StateM s m) where +instance Monad m => Applicative (StateM s m) where pure x = StateM $ \s -> return (s, x) StateM f <*> StateM x = StateM $ \s -> do (s', f') <- f s (s'', x') <- x s' return (s'', f' x') -- | Monadic variant of 'mapAccumL'. -mapAccumM :: -#if __GLASGOW_HASKELL__ < 709 - (Functor m, Monad m, Traversable t) -#else - (Monad m, Traversable t) -#endif +mapAccumM :: (Monad m, Traversable t) => (a -> b -> m (a, c)) -> a -> t b -> m (a, t c) mapAccumM f s t = runStateM (traverse (\x -> StateM (\s' -> f s' x)) t) s - diff --git a/src/Distribution/Utils/NubList.hs b/src/Distribution/Utils/NubList.hs --- a/src/Distribution/Utils/NubList.hs +++ b/src/Distribution/Utils/NubList.hs @@ -3,7 +3,7 @@ {-# LANGUAGE ScopedTypeVariables #-} module Distribution.Utils.NubList ( NubList -- opaque - , toNubList -- smart construtor + , toNubList -- smart constructor , fromNubList , overNubList @@ -39,7 +39,7 @@ overNubList f (NubList list) = toNubList . f $ list -- | Monoid operations on NubLists. --- For a valid Monoid instance we need to satistfy the required monoid laws; +-- For a valid Monoid instance we need to satisfy the required monoid laws; -- identity, associativity and closure. -- -- Identity : by inspection: diff --git a/src/Distribution/Utils/Path.hs b/src/Distribution/Utils/Path.hs deleted file mode 100644 --- a/src/Distribution/Utils/Path.hs +++ /dev/null @@ -1,103 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE StandaloneDeriving #-} -module Distribution.Utils.Path ( - -- * Symbolic path - SymbolicPath, - getSymbolicPath, - sameDirectory, - unsafeMakeSymbolicPath, - -- * Path ends - PackageDir, - SourceDir, - LicenseFile, - IsDir, -) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Parsec -import Distribution.Pretty -import Distribution.Utils.Generic (isAbsoluteOnAnyPlatform) - -import qualified Distribution.Compat.CharParsing as P --- import qualified Text.PrettyPrint as Disp - -------------------------------------------------------------------------------- --- * SymbolicPath -------------------------------------------------------------------------------- - --- | Symbolic paths. --- --- These paths are system independent and relative. --- They are *symbolic* which means we cannot perform any 'IO' --- until we interpret them. --- -newtype SymbolicPath from to = SymbolicPath FilePath - deriving (Generic, Show, Read, Eq, Ord, Typeable, Data) - -instance Binary (SymbolicPath from to) -instance (Typeable from, Typeable to) => Structured (SymbolicPath from to) -instance NFData (SymbolicPath from to) where rnf = genericRnf - --- | Extract underlying 'FilePath'. --- --- Avoid using this in new code. --- -getSymbolicPath :: SymbolicPath from to -> FilePath -getSymbolicPath (SymbolicPath p) = p - -sameDirectory :: (IsDir from, IsDir to) => SymbolicPath from to -sameDirectory = SymbolicPath "." - --- | Make 'SymbolicPath' without performing any checks. -unsafeMakeSymbolicPath :: FilePath -> SymbolicPath from to -unsafeMakeSymbolicPath = SymbolicPath - -------------------------------------------------------------------------------- --- ** Parsing and pretty printing -------------------------------------------------------------------------------- - -instance Parsec (SymbolicPath from to) where - parsec = do - token <- parsecToken - if null token then P.unexpected "empty FilePath" - else if isAbsoluteOnAnyPlatform token then P.unexpected "absolute FilePath" - else return (SymbolicPath token) -- TODO: normalise - -instance Pretty (SymbolicPath from to) where - pretty = showFilePath . getSymbolicPath - -------------------------------------------------------------------------------- --- * Composition -------------------------------------------------------------------------------- - --- TODO --- infixr 5 --- --- -- | Path composition --- -- --- -- We don't reuse @@ name to not clash with "System.FilePath". --- -- --- () :: path a b -> path b c -> path a c - -------------------------------------------------------------------------------- --- * Path ends -------------------------------------------------------------------------------- - --- | Class telling that index is for directories. -class IsDir dir - -data PackageDir deriving (Typeable) -data SourceDir deriving (Typeable) - -data LicenseFile deriving (Typeable) - --- These instances needs to be derived standalone at least on GHC-7.6 -deriving instance Data PackageDir -deriving instance Data SourceDir -deriving instance Data LicenseFile - -instance IsDir PackageDir -instance IsDir SourceDir diff --git a/src/Distribution/Utils/ShortText.hs b/src/Distribution/Utils/ShortText.hs deleted file mode 100644 --- a/src/Distribution/Utils/ShortText.hs +++ /dev/null @@ -1,159 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} - --- | Compact representation of short 'Strings' --- --- This module is designed to be import qualifeid --- --- @ --- import Distribution.Utils.ShortText (ShortText) --- import qualified Distribution.Utils.ShortText as ShortText --- @ -module Distribution.Utils.ShortText - ( -- * 'ShortText' type - ShortText - , toShortText - , fromShortText - , unsafeFromUTF8BS - - -- * Operations - , null - , length - - -- * internal utilities - , decodeStringUtf8 - , encodeStringUtf8 - ) where - -import Distribution.Compat.Prelude hiding (length, null) -import Prelude () - -import Distribution.Utils.String (decodeStringUtf8, encodeStringUtf8) -import Distribution.Utils.Structured (Structured (..), nominalStructure) - -#if defined(MIN_VERSION_bytestring) -# if MIN_VERSION_bytestring(0,10,4) -# define HAVE_SHORTBYTESTRING 1 -# endif -#endif - --- Hack for GHC bootstrapping --- --- Currently (as of GHC 8.1), GHC bootstraps Cabal by building --- binary and Cabal in one giant ghc --make command. This --- means no MIN_VERSION_binary macro is available. --- --- We could try to cleverly figure something out in this case, --- but there is a better plan: just use the unoptimized version --- of the Binary instance. We're not going to use it for anything --- real in any case. --- --- WARNING: Don't use MIN_VERSION_binary to smooth over a BC-break! --- -#ifndef MIN_VERSION_binary -#define MIN_VERSION_binary(x, y, z) 0 -#endif - -import qualified Data.ByteString as BS -import qualified Data.List as List - -#if HAVE_SHORTBYTESTRING -import qualified Data.ByteString.Short as BS.Short -#else -import Distribution.Utils.Generic (fromUTF8BS) -#endif - --- | Construct 'ShortText' from 'String' -toShortText :: String -> ShortText - --- | Convert 'ShortText' to 'String' -fromShortText :: ShortText -> String - --- | Convert from UTF-8 encoded strict 'ByteString'. --- --- @since 3.2.0.0 -unsafeFromUTF8BS :: BS.ByteString -> ShortText - --- | Text whether 'ShortText' is empty. --- --- @since 3.2.0.0 -null :: ShortText -> Bool - --- | Compact representation of short 'Strings' --- --- The data is stored internally as UTF8 in an --- 'BS.Short.ShortByteString' when compiled against @bytestring >= --- 0.10.4@, and otherwise the fallback is to use plain old non-compat --- '[Char]'. --- --- Note: This type is for internal uses (such as e.g. 'PackageName') --- and shall not be exposed in Cabal's API --- --- @since 2.0.0.2 -#if HAVE_SHORTBYTESTRING -newtype ShortText = ST { unST :: BS.Short.ShortByteString } - deriving (Eq,Ord,Generic,Data,Typeable) - -# if MIN_VERSION_binary(0,8,1) -instance Binary ShortText where - put = put . unST - get = fmap ST get -# else -instance Binary ShortText where - put = put . BS.Short.fromShort . unST - get = fmap (ST . BS.Short.toShort) get -# endif - - -toShortText = ST . BS.Short.pack . encodeStringUtf8 - -fromShortText = decodeStringUtf8 . BS.Short.unpack . unST - -unsafeFromUTF8BS = ST . BS.Short.toShort - -null = BS.Short.null . unST -#else -newtype ShortText = ST { unST :: String } - deriving (Eq,Ord,Generic,Data,Typeable) - -instance Binary ShortText where - put = put . encodeStringUtf8 . unST - get = fmap (ST . decodeStringUtf8) get - -toShortText = ST - -fromShortText = unST - -unsafeFromUTF8BS = ST . fromUTF8BS - -null = List.null . unST -#endif - -instance Structured ShortText where structure = nominalStructure - -instance NFData ShortText where - rnf = rnf . unST - -instance Show ShortText where - show = show . fromShortText - -instance Read ShortText where - readsPrec p = map (first toShortText) . readsPrec p - -instance Semigroup ShortText where - ST a <> ST b = ST (mappend a b) - -instance Monoid ShortText where - mempty = ST mempty - mappend = (<>) - -instance IsString ShortText where - fromString = toShortText - --- | /O(n)/. Length in characters. /Slow/ as converts to string. --- --- @since 3.2.0.0 -length :: ShortText -> Int -length = List.length . fromShortText --- Note: avoid using it, we use it @cabal check@ implementation, where it's ok. diff --git a/src/Distribution/Utils/String.hs b/src/Distribution/Utils/String.hs deleted file mode 100644 --- a/src/Distribution/Utils/String.hs +++ /dev/null @@ -1,93 +0,0 @@ -module Distribution.Utils.String - ( -- * Encode to/from UTF8 - decodeStringUtf8 - , encodeStringUtf8 - ) where - -import Data.Word -import Data.Bits -import Data.Char (chr,ord) - --- | Decode 'String' from UTF8-encoded octets. --- --- Invalid data in the UTF8 stream (this includes code-points @U+D800@ --- through @U+DFFF@) will be decoded as the replacement character (@U+FFFD@). --- --- See also 'encodeStringUtf8' -decodeStringUtf8 :: [Word8] -> String -decodeStringUtf8 = go - where - go :: [Word8] -> String - go [] = [] - go (c : cs) - | c <= 0x7F = chr (fromIntegral c) : go cs - | c <= 0xBF = replacementChar : go cs - | c <= 0xDF = twoBytes c cs - | c <= 0xEF = moreBytes 3 0x800 cs (fromIntegral $ c .&. 0xF) - | c <= 0xF7 = moreBytes 4 0x10000 cs (fromIntegral $ c .&. 0x7) - | c <= 0xFB = moreBytes 5 0x200000 cs (fromIntegral $ c .&. 0x3) - | c <= 0xFD = moreBytes 6 0x4000000 cs (fromIntegral $ c .&. 0x1) - | otherwise = replacementChar : go cs - - twoBytes :: Word8 -> [Word8] -> String - twoBytes c0 (c1:cs') - | c1 .&. 0xC0 == 0x80 - = let d = (fromIntegral (c0 .&. 0x1F) `shiftL` 6) - .|. fromIntegral (c1 .&. 0x3F) - in if d >= 0x80 - then chr d : go cs' - else replacementChar : go cs' - twoBytes _ cs' = replacementChar : go cs' - - moreBytes :: Int -> Int -> [Word8] -> Int -> [Char] - moreBytes 1 overlong cs' acc - | overlong <= acc, acc <= 0x10FFFF, acc < 0xD800 || 0xDFFF < acc - = chr acc : go cs' - - | otherwise - = replacementChar : go cs' - - moreBytes byteCount overlong (cn:cs') acc - | cn .&. 0xC0 == 0x80 - = moreBytes (byteCount-1) overlong cs' - ((acc `shiftL` 6) .|. fromIntegral cn .&. 0x3F) - - moreBytes _ _ cs' _ - = replacementChar : go cs' - - replacementChar = '\xfffd' - - --- | Encode 'String' to a list of UTF8-encoded octets --- --- Code-points in the @U+D800@-@U+DFFF@ range will be encoded --- as the replacement character (i.e. @U+FFFD@). --- --- See also 'decodeUtf8' -encodeStringUtf8 :: String -> [Word8] -encodeStringUtf8 [] = [] -encodeStringUtf8 (c:cs) - | c <= '\x07F' = w8 - : encodeStringUtf8 cs - | c <= '\x7FF' = (0xC0 .|. w8ShiftR 6 ) - : (0x80 .|. (w8 .&. 0x3F)) - : encodeStringUtf8 cs - | c <= '\xD7FF'= (0xE0 .|. w8ShiftR 12 ) - : (0x80 .|. (w8ShiftR 6 .&. 0x3F)) - : (0x80 .|. (w8 .&. 0x3F)) - : encodeStringUtf8 cs - | c <= '\xDFFF'= 0xEF : 0xBF : 0xBD -- U+FFFD - : encodeStringUtf8 cs - | c <= '\xFFFF'= (0xE0 .|. w8ShiftR 12 ) - : (0x80 .|. (w8ShiftR 6 .&. 0x3F)) - : (0x80 .|. (w8 .&. 0x3F)) - : encodeStringUtf8 cs - | otherwise = (0xf0 .|. w8ShiftR 18 ) - : (0x80 .|. (w8ShiftR 12 .&. 0x3F)) - : (0x80 .|. (w8ShiftR 6 .&. 0x3F)) - : (0x80 .|. (w8 .&. 0x3F)) - : encodeStringUtf8 cs - where - w8 = fromIntegral (ord c) :: Word8 - w8ShiftR :: Int -> Word8 - w8ShiftR = fromIntegral . shiftR (ord c) diff --git a/src/Distribution/Utils/Structured.hs b/src/Distribution/Utils/Structured.hs deleted file mode 100644 --- a/src/Distribution/Utils/Structured.hs +++ /dev/null @@ -1,477 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -#if __GLASGOW_HASKELL__ >= 711 -{-# LANGUAGE PatternSynonyms #-} -#endif -#if __GLASGOW_HASKELL__ >= 800 -{-# LANGUAGE TypeInType #-} -#endif --- | --- --- Copyright: (c) 2019 Oleg Grenrus --- --- Structurally tag binary serialisaton stream. --- Useful when most 'Binary' instances are 'Generic' derived. --- --- Say you have a data type --- --- @ --- data Record = Record --- { _recordFields :: HM.HashMap Text (Integer, ByteString) --- , _recordEnabled :: Bool --- } --- deriving (Eq, Show, Generic) --- --- instance 'Binary' Record --- instance 'Structured' Record --- @ --- --- then you can serialise and deserialise @Record@ values with a structure tag by simply --- --- @ --- 'structuredEncode' record :: 'LBS.ByteString' --- 'structuredDecode' lbs :: IO Record --- @ --- --- If structure of @Record@ changes in between, deserialisation will fail early. --- --- Technically, 'Structured' is not related to 'Binary', and may --- be useful in other uses. --- -module Distribution.Utils.Structured ( - -- * Encoding and decoding - -- | These functions operate like @binary@'s counterparts, - -- but the serialised version has a structure hash in front. - structuredEncode, - structuredEncodeFile, - structuredDecode, - structuredDecodeOrFailIO, - structuredDecodeFileOrFail, - -- * Structured class - Structured (structure), - MD5, - structureHash, - structureBuilder, - genericStructure, - GStructured, - nominalStructure, - containerStructure, - -- * Structure type - Structure (..), - Tag (..), - TypeName, - ConstructorName, - TypeVersion, - SopStructure, - hashStructure, - typeVersion, - typeName, - ) where - -import Data.Int (Int16, Int32, Int64, Int8) -import Data.List.NonEmpty (NonEmpty) -import Data.Proxy (Proxy (..)) -import Data.Ratio (Ratio) -import Data.Word (Word, Word16, Word32, Word64, Word8) - -import qualified Control.Monad.Trans.State.Strict as State - -import Control.Exception (ErrorCall (..), catch, evaluate) - -import GHC.Generics - -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as LBS -#if MIN_VERSION_bytestring(0,10,4) -import qualified Data.ByteString.Builder as Builder -#else -import qualified Data.ByteString.Lazy.Builder as Builder -#endif -import qualified Data.IntMap as IM -import qualified Data.IntSet as IS -import qualified Data.Map as Map -import qualified Data.Sequence as Seq -import qualified Data.Set as Set -import qualified Data.Text as T -import qualified Data.Text.Lazy as LT -import qualified Data.Time as Time -import qualified Distribution.Compat.Binary as Binary - -#ifdef MIN_VERSION_aeson -import qualified Data.Aeson as Aeson -#endif - -#if __GLASGOW_HASKELL__ >= 800 -import Data.Kind (Type) -#else -#define Type * -#endif - -import Distribution.Compat.Typeable (Typeable, TypeRep, typeRep) -import Distribution.Utils.MD5 - -import Data.Monoid (mconcat) - -import qualified Data.Semigroup -import qualified Data.Foldable - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative (pure) -import Data.Traversable (traverse) -#endif - -#if !MIN_VERSION_base(4,7,0) -import Data.Typeable (Typeable1, typeOf1) -#endif - - -------------------------------------------------------------------------------- --- Types -------------------------------------------------------------------------------- - -type TypeName = String -type ConstructorName = String - --- | A sematic version of a data type. Usually 0. -type TypeVersion = Word32 - --- | Structure of a datatype. --- --- It can be infinite, as far as 'TypeRep's involved are finite. --- (e.g. polymorphic recursion might cause troubles). --- -data Structure - = Nominal !TypeRep !TypeVersion TypeName [Structure] -- ^ nominal, yet can be parametrised by other structures. - | Newtype !TypeRep !TypeVersion TypeName Structure -- ^ a newtype wrapper - | Structure !TypeRep !TypeVersion TypeName SopStructure -- ^ sum-of-products structure - deriving (Eq, Ord, Show, Generic) - -type SopStructure = [(ConstructorName, [Structure])] - --- | A MD5 hash digest of 'Structure'. -hashStructure :: Structure -> MD5 -hashStructure = md5 . LBS.toStrict . Builder.toLazyByteString . structureBuilder - --- | A van-Laarhoven lens into 'TypeVersion' of 'Structure' --- --- @ --- 'typeVersion' :: Lens' 'Structure' 'TypeVersion' --- @ -typeVersion :: Functor f => (TypeVersion -> f TypeVersion) -> Structure -> f Structure -typeVersion f (Nominal t v n s) = fmap (\v' -> Nominal t v' n s) (f v) -typeVersion f (Newtype t v n s) = fmap (\v' -> Newtype t v' n s) (f v) -typeVersion f (Structure t v n s) = fmap (\v' -> Structure t v' n s) (f v) - --- | A van-Laarhoven lens into 'TypeName' of 'Structure' --- --- @ --- 'typeName' :: Lens' 'Structure' 'TypeName' --- @ -typeName :: Functor f => (TypeName -> f TypeName) -> Structure -> f Structure -typeName f (Nominal t v n s) = fmap (\n' -> Nominal t v n' s) (f n) -typeName f (Newtype t v n s) = fmap (\n' -> Newtype t v n' s) (f n) -typeName f (Structure t v n s) = fmap (\n' -> Structure t v n' s) (f n) - -------------------------------------------------------------------------------- --- Builder -------------------------------------------------------------------------------- - --- | Flatten 'Structure' into something we can calculate hash of. --- --- As 'Structure' can be potentially infinite. For mutually recursive types, --- we keep track of 'TypeRep's, and put just 'TypeRep' name when it's occurred --- another time. -structureBuilder :: Structure -> Builder.Builder -structureBuilder s0 = State.evalState (go s0) Map.empty where - go :: Structure -> State.State (Map.Map String (NonEmpty TypeRep)) Builder.Builder - go (Nominal t v n s) = withTypeRep t $ do - s' <- traverse go s - return $ mconcat $ Builder.word8 1 : Builder.word32LE v : Builder.stringUtf8 n : s' - - go (Newtype t v n s) = withTypeRep t $ do - s' <- go s - return $ mconcat [Builder.word8 2, Builder.word32LE v, Builder.stringUtf8 n, s'] - - go (Structure t v n s) = withTypeRep t $ do - s' <- goSop s - return $ mconcat [Builder.word8 3, Builder.word32LE v, Builder.stringUtf8 n, s'] - - withTypeRep t k = do - acc <- State.get - case insert t acc of - Nothing -> return $ mconcat [ Builder.word8 0, Builder.stringUtf8 (show t) ] - Just acc' -> do - State.put acc' - k - - goSop :: SopStructure -> State.State (Map.Map String (NonEmpty TypeRep)) Builder.Builder - goSop sop = do - parts <- traverse part sop - return $ mconcat parts - - part (cn, s) = do - s' <- traverse go s - return $ Data.Monoid.mconcat [ Builder.stringUtf8 cn, mconcat s' ] - - insert :: TypeRep -> Map.Map String (NonEmpty TypeRep) -> Maybe (Map.Map String (NonEmpty TypeRep)) - insert tr m = case Map.lookup trShown m of - Nothing -> inserted - Just ne | tr `Data.Foldable.elem` ne -> Nothing - | otherwise -> inserted - where - inserted = Just (Map.insertWith (Data.Semigroup.<>) trShown (pure tr) m) - trShown = show tr - -------------------------------------------------------------------------------- --- Classes -------------------------------------------------------------------------------- - --- | Class of types with a known 'Structure'. --- --- For regular data types 'Structured' can be derived generically. --- --- @ --- data Record = Record { a :: Int, b :: Bool, c :: [Char] } deriving ('Generic') --- instance 'Structured' Record --- @ --- --- @since 3.2.0.0 --- -class Typeable a => Structured a where - structure :: Proxy a -> Structure - default structure :: (Generic a, GStructured (Rep a)) => Proxy a -> Structure - structure = genericStructure - - -- This member is hidden. It's there to precalc - structureHash' :: Tagged a MD5 - structureHash' = Tagged (hashStructure (structure (Proxy :: Proxy a))) - --- private Tagged -newtype Tagged a b = Tagged { untag :: b } - --- | Semantically @'hashStructure' . 'structure'@. -structureHash :: forall a. Structured a => Proxy a -> MD5 -structureHash _ = untag (structureHash' :: Tagged a MD5) - -------------------------------------------------------------------------------- --- Functions -------------------------------------------------------------------------------- - --- | Structured 'Binary.encode'. --- Encode a value to using binary serialisation to a lazy 'LBS.ByteString'. --- Encoding starts with 16 byte large structure hash. -structuredEncode - :: forall a. (Binary.Binary a, Structured a) - => a -> LBS.ByteString -structuredEncode x = Binary.encode (Tag :: Tag a, x) - --- | Lazily serialise a value to a file -structuredEncodeFile :: (Binary.Binary a, Structured a) => FilePath -> a -> IO () -structuredEncodeFile f = LBS.writeFile f . structuredEncode - --- | Structured 'Binary.decode'. --- Decode a value from a lazy 'LBS.ByteString', reconstructing the original structure. --- Throws pure exception on invalid inputs. -structuredDecode - :: forall a. (Binary.Binary a, Structured a) - => LBS.ByteString -> a -structuredDecode lbs = snd (Binary.decode lbs :: (Tag a, a)) - -structuredDecodeOrFailIO :: (Binary.Binary a, Structured a) => LBS.ByteString -> IO (Either String a) -structuredDecodeOrFailIO bs = - catch (evaluate (structuredDecode bs) >>= return . Right) handler - where -#if MIN_VERSION_base(4,9,0) - handler (ErrorCallWithLocation str _) = return $ Left str -#else - handler (ErrorCall str) = return $ Left str -#endif - --- | Lazily reconstruct a value previously written to a file. -structuredDecodeFileOrFail :: (Binary.Binary a, Structured a) => FilePath -> IO (Either String a) -structuredDecodeFileOrFail f = structuredDecodeOrFailIO =<< LBS.readFile f - -------------------------------------------------------------------------------- --- Helper data -------------------------------------------------------------------------------- - -data Tag a = Tag - -instance Structured a => Binary.Binary (Tag a) where - get = do - actual <- binaryGetMD5 - if actual == expected - then return Tag - else fail $ concat - [ "Non-matching structured hashes: " - , showMD5 actual - , "; expected: " - , showMD5 expected - ] - where - expected = untag (structureHash' :: Tagged a MD5) - - put _ = binaryPutMD5 expected - where - expected = untag (structureHash' :: Tagged a MD5) - -------------------------------------------------------------------------------- --- Smart constructors -------------------------------------------------------------------------------- - --- | Use 'Typeable' to infer name -nominalStructure :: Typeable a => Proxy a -> Structure -nominalStructure p = Nominal tr 0 (show tr) [] where - tr = typeRep p - -#if MIN_VERSION_base(4,7,0) -containerStructure :: forall f a. (Typeable f, Structured a) => Proxy (f a) -> Structure -containerStructure _ = Nominal faTypeRep 0 (show fTypeRep) - [ structure (Proxy :: Proxy a) - ] - where - fTypeRep = typeRep (Proxy :: Proxy f) - faTypeRep = typeRep (Proxy :: Proxy (f a)) - -#else -containerStructure :: forall f a. (Typeable1 f, Structured a) => Proxy (f a) -> Structure -containerStructure _ = Nominal faTypeRep 0 (show fTypeRep) - [ structure (Proxy :: Proxy a) - ] - where - fTypeRep = typeOf1 (undefined :: f ()) - faTypeRep = typeRep (Proxy :: Proxy (f a)) -#endif - -------------------------------------------------------------------------------- --- Generic -------------------------------------------------------------------------------- - --- | Derive 'structure' genrically. -genericStructure :: forall a. (Typeable a, Generic a, GStructured (Rep a)) => Proxy a -> Structure -genericStructure _ = gstructured (typeRep (Proxy :: Proxy a)) (Proxy :: Proxy (Rep a)) 0 - --- | Used to implement 'genericStructure'. -class GStructured (f :: Type -> Type) where - gstructured :: TypeRep -> Proxy f -> TypeVersion -> Structure - -instance (i ~ D, Datatype c, GStructuredSum f) => GStructured (M1 i c f) where - gstructured tr _ v = case sop of -#if MIN_VERSION_base(4,7,0) - [(_, [s])] | isNewtype p -> Newtype tr v name s -#endif - _ -> Structure tr v name sop - where - p = undefined :: M1 i c f () - name = datatypeName p - sop = gstructuredSum (Proxy :: Proxy f) [] - -class GStructuredSum (f :: Type -> Type) where - gstructuredSum :: Proxy f -> SopStructure -> SopStructure - -instance (i ~ C, Constructor c, GStructuredProd f) => GStructuredSum (M1 i c f) where - gstructuredSum _ xs = (name, prod) : xs - where - name = conName (undefined :: M1 i c f ()) - prod = gstructuredProd (Proxy :: Proxy f) [] - -instance (GStructuredSum f, GStructuredSum g) => GStructuredSum (f :+: g) where - gstructuredSum _ xs - = gstructuredSum (Proxy :: Proxy f) - $ gstructuredSum (Proxy :: Proxy g) xs - -instance GStructuredSum V1 where - gstructuredSum _ = id - -class GStructuredProd (f :: Type -> Type) where - gstructuredProd :: Proxy f -> [Structure] -> [Structure] - -instance (i ~ S, GStructuredProd f) => GStructuredProd (M1 i c f) where - gstructuredProd _ = gstructuredProd (Proxy :: Proxy f) - -instance Structured c => GStructuredProd (K1 i c) where - gstructuredProd _ xs = structure (Proxy :: Proxy c) : xs - -instance GStructuredProd U1 where - gstructuredProd _ = id - -instance (GStructuredProd f, GStructuredProd g) => GStructuredProd (f :*: g) where - gstructuredProd _ xs - = gstructuredProd (Proxy :: Proxy f) - $ gstructuredProd (Proxy :: Proxy g) xs - -------------------------------------------------------------------------------- --- instances -------------------------------------------------------------------------------- - -instance Structured () -instance Structured Bool -instance Structured Ordering - -instance Structured Char where structure = nominalStructure -instance Structured Int where structure = nominalStructure -instance Structured Integer where structure = nominalStructure - -instance Structured Data.Word.Word where structure = nominalStructure - -instance Structured Int8 where structure = nominalStructure -instance Structured Int16 where structure = nominalStructure -instance Structured Int32 where structure = nominalStructure -instance Structured Int64 where structure = nominalStructure - -instance Structured Word8 where structure = nominalStructure -instance Structured Word16 where structure = nominalStructure -instance Structured Word32 where structure = nominalStructure -instance Structured Word64 where structure = nominalStructure - -instance Structured Float where structure = nominalStructure -instance Structured Double where structure = nominalStructure - -instance Structured a => Structured (Maybe a) -instance (Structured a, Structured b) => Structured (Either a b) -instance Structured a => Structured (Ratio a) where structure = containerStructure -instance Structured a => Structured [a] where structure = containerStructure -instance Structured a => Structured (NonEmpty a) where structure = containerStructure - -instance (Structured a1, Structured a2) => Structured (a1, a2) -instance (Structured a1, Structured a2, Structured a3) => Structured (a1, a2, a3) -instance (Structured a1, Structured a2, Structured a3, Structured a4) => Structured (a1, a2, a3, a4) -instance (Structured a1, Structured a2, Structured a3, Structured a4, Structured a5) => Structured (a1, a2, a3, a4, a5) -instance (Structured a1, Structured a2, Structured a3, Structured a4, Structured a5, Structured a6) => Structured (a1, a2, a3, a4, a5, a6) -instance (Structured a1, Structured a2, Structured a3, Structured a4, Structured a5, Structured a6, Structured a7) => Structured (a1, a2, a3, a4, a5, a6, a7) - -instance Structured BS.ByteString where structure = nominalStructure -instance Structured LBS.ByteString where structure = nominalStructure - -instance Structured T.Text where structure = nominalStructure -instance Structured LT.Text where structure = nominalStructure - -instance (Structured k, Structured v) => Structured (Map.Map k v) where structure _ = Nominal (typeRep (Proxy :: Proxy (Map.Map k v))) 0 "Map" [ structure (Proxy :: Proxy k), structure (Proxy :: Proxy v) ] -instance (Structured k) => Structured (Set.Set k) where structure = containerStructure -instance (Structured v) => Structured (IM.IntMap v) where structure = containerStructure -instance Structured IS.IntSet where structure = nominalStructure -instance (Structured v) => Structured (Seq.Seq v) where structure = containerStructure - -instance Structured Time.UTCTime where structure = nominalStructure -instance Structured Time.DiffTime where structure = nominalStructure -instance Structured Time.UniversalTime where structure = nominalStructure -instance Structured Time.NominalDiffTime where structure = nominalStructure -instance Structured Time.Day where structure = nominalStructure -instance Structured Time.TimeZone where structure = nominalStructure -instance Structured Time.TimeOfDay where structure = nominalStructure -instance Structured Time.LocalTime where structure = nominalStructure - --- Proxy isn't Typeable in base-4.8 / base - --- #if __GLASGOW_HASKELL__ >= 800 --- instance (Typeable k, Typeable (a :: k)) => Structured (Proxy a) --- #else --- instance (Typeable a) => Structured (Proxy a) where --- structure p = Structure (typeRep p) 0 "Proxy" [("Proxy",[])] --- #endif diff --git a/src/Distribution/Verbosity.hs b/src/Distribution/Verbosity.hs --- a/src/Distribution/Verbosity.hs +++ b/src/Distribution/Verbosity.hs @@ -42,16 +42,19 @@ verboseMarkOutput, isVerboseMarkOutput, verboseUnmarkOutput, - -- * line-wrapping + -- * Line wrapping verboseNoWrap, isVerboseNoWrap, - -- * timestamps + -- * Time stamps verboseTimestamp, isVerboseTimestamp, verboseNoTimestamp, -- * Stderr verboseStderr, isVerboseStderr, verboseNoStderr, + + -- * No warnings + verboseNoWarn, isVerboseNoWarn ) where import Prelude () @@ -95,23 +98,24 @@ instance Binary Verbosity instance Structured Verbosity --- We shouldn't print /anything/ unless an error occurs in silent mode +-- | In 'silent' mode, we should not print /anything/ unless an error occurs. silent :: Verbosity silent = mkVerbosity Silent --- Print stuff we want to see by default +-- | Print stuff we want to see by default. normal :: Verbosity normal = mkVerbosity Normal --- Be more verbose about what's going on +-- | Be more verbose about what's going on. verbose :: Verbosity verbose = mkVerbosity Verbose --- Not only are we verbose ourselves (perhaps even noisier than when --- being "verbose"), but we tell everything we run to be verbose too +-- | Not only are we verbose ourselves (perhaps even noisier than when +-- being 'verbose'), but we tell everything we run to be verbose too. deafening :: Verbosity deafening = mkVerbosity Deafening +-- | Increase verbosity level, but stay 'silent' if we are. moreVerbose :: Verbosity -> Verbosity moreVerbose v = case vLevel v of @@ -120,6 +124,7 @@ Verbose -> v { vLevel = Deafening } Deafening -> v +-- | Decrease verbosity level, but stay 'deafening' if we are. lessVerbose :: Verbosity -> Verbosity lessVerbose v = verboseQuiet $ @@ -143,6 +148,7 @@ modifyVerbosity :: (Verbosity -> Verbosity) -> Verbosity -> Verbosity modifyVerbosity f v = v { vLevel = vLevel (f v) } +-- | Numeric verbosity level @0..3@: @0@ is 'silent', @3@ is 'deafening'. intToVerbosity :: Int -> Maybe Verbosity intToVerbosity 0 = Just (mkVerbosity Silent) intToVerbosity 1 = Just (mkVerbosity Normal) @@ -213,6 +219,7 @@ "timestamp" -> return verboseTimestamp "stderr" -> return verboseStderr "stdout" -> return verboseNoStderr + "nowarn" -> return verboseNoWarn _ -> P.unexpected $ "Bad verbosity flag: " ++ token flagToVerbosity :: ReadE Verbosity @@ -239,6 +246,7 @@ showFlag VMarkOutput = ["+markoutput"] showFlag VTimestamp = ["+timestamp"] showFlag VStderr = ["+stderr"] + showFlag VNoWarn = ["+nowarn"] showForGHC :: Verbosity -> String showForGHC v = maybe (error "unknown verbosity") show $ @@ -266,7 +274,7 @@ verboseNoWrap :: Verbosity -> Verbosity verboseNoWrap = verboseFlag VNoWrap --- | Mark the verbosity as quiet +-- | Mark the verbosity as quiet. verboseQuiet :: Verbosity -> Verbosity verboseQuiet v = v { vQuiet = True } @@ -278,27 +286,31 @@ verboseNoTimestamp :: Verbosity -> Verbosity verboseNoTimestamp = verboseNoFlag VTimestamp --- | Turn on timestamps for log messages. +-- | Switch logging to 'stderr'. -- -- @since 3.4.0.0 verboseStderr :: Verbosity -> Verbosity verboseStderr = verboseFlag VStderr --- | Turn off timestamps for log messages. +-- | Switch logging to 'stdout'. -- -- @since 3.4.0.0 verboseNoStderr :: Verbosity -> Verbosity verboseNoStderr = verboseNoFlag VStderr --- | Helper function for flag enabling functions +-- | Turn off warnings for log messages. +verboseNoWarn :: Verbosity -> Verbosity +verboseNoWarn = verboseFlag VNoWarn + +-- | Helper function for flag enabling functions. verboseFlag :: VerbosityFlag -> (Verbosity -> Verbosity) verboseFlag flag v = v { vFlags = Set.insert flag (vFlags v) } --- | Helper function for flag disabling functions +-- | Helper function for flag disabling functions. verboseNoFlag :: VerbosityFlag -> (Verbosity -> Verbosity) verboseNoFlag flag v = v { vFlags = Set.delete flag (vFlags v) } --- | Turn off all flags +-- | Turn off all flags. verboseNoFlags :: Verbosity -> Verbosity verboseNoFlags v = v { vFlags = Set.empty } @@ -321,7 +333,7 @@ isVerboseNoWrap :: Verbosity -> Bool isVerboseNoWrap = isVerboseFlag VNoWrap --- | Test if we had called 'lessVerbose' on the verbosity +-- | Test if we had called 'lessVerbose' on the verbosity. isVerboseQuiet :: Verbosity -> Bool isVerboseQuiet = vQuiet @@ -329,11 +341,15 @@ isVerboseTimestamp :: Verbosity -> Bool isVerboseTimestamp = isVerboseFlag VTimestamp --- | Test if we should output to stderr when we log. +-- | Test if we should output to 'stderr' when we log. -- -- @since 3.4.0.0 isVerboseStderr :: Verbosity -> Bool isVerboseStderr = isVerboseFlag VStderr + +-- | Test if we should output warnings when we log. +isVerboseNoWarn :: Verbosity -> Bool +isVerboseNoWarn = isVerboseFlag VNoWarn -- | Helper function for flag testing functions. isVerboseFlag :: VerbosityFlag -> Verbosity -> Bool diff --git a/src/Distribution/Verbosity/Internal.hs b/src/Distribution/Verbosity/Internal.hs --- a/src/Distribution/Verbosity/Internal.hs +++ b/src/Distribution/Verbosity/Internal.hs @@ -21,6 +21,7 @@ | VMarkOutput | VTimestamp | VStderr -- ^ @since 3.4.0.0 + | VNoWarn deriving (Generic, Show, Read, Eq, Ord, Enum, Bounded, Typeable) instance Binary VerbosityFlag diff --git a/src/Distribution/Version.hs b/src/Distribution/Version.hs deleted file mode 100644 --- a/src/Distribution/Version.hs +++ /dev/null @@ -1,185 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Version --- Copyright : Isaac Jones, Simon Marlow 2003-2004 --- Duncan Coutts 2008 --- License : BSD3 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- Exports the 'Version' type along with a parser and pretty printer. A version --- is something like @\"1.3.3\"@. It also defines the 'VersionRange' data --- types. Version ranges are like @\">= 1.2 && < 2\"@. - -module Distribution.Version ( - -- * Package versions - Version, - version0, - mkVersion, - mkVersion', - versionNumbers, - nullVersion, - alterVersion, - - -- * Version ranges - VersionRange, - - -- ** Constructing - anyVersion, noVersion, - thisVersion, notThisVersion, - laterVersion, earlierVersion, - orLaterVersion, orEarlierVersion, - unionVersionRanges, intersectVersionRanges, - withinVersion, - majorBoundVersion, - - -- ** Inspection - withinRange, - isAnyVersion, - isNoVersion, - isSpecificVersion, - simplifyVersionRange, - foldVersionRange, - normaliseVersionRange, - stripParensVersionRange, - hasUpperBound, - hasLowerBound, - - -- ** Cata & ana - VersionRangeF (..), - cataVersionRange, - anaVersionRange, - hyloVersionRange, - projectVersionRange, - embedVersionRange, - - -- ** Utilities - wildcardUpperBound, - majorUpperBound, - - -- ** Modification - removeUpperBound, - removeLowerBound, - transformCaret, - transformCaretUpper, - transformCaretLower, - - -- * Version intervals view - asVersionIntervals, - VersionInterval(..), - LowerBound(..), - UpperBound(..), - Bound(..), - - -- ** 'VersionIntervals' abstract type - -- | The 'VersionIntervals' type and the accompanying functions are exposed - -- primarily for completeness and testing purposes. In practice - -- 'asVersionIntervals' is the main function to use to - -- view a 'VersionRange' as a bunch of 'VersionInterval's. - -- - VersionIntervals, - toVersionIntervals, - fromVersionIntervals, - unVersionIntervals, - - ) where - -import Distribution.Types.Version -import Distribution.Types.VersionRange -import Distribution.Types.VersionInterval - -------------------------------------------------------------------------------- --- Utilities on VersionRange requiring VersionInterval -------------------------------------------------------------------------------- - --- | This is the converse of 'isAnyVersion'. It check if the version range is --- empty, if there is no possible version that satisfies the version range. --- --- For example this is @True@ (for all @v@): --- --- > isNoVersion (EarlierVersion v `IntersectVersionRanges` LaterVersion v) --- -isNoVersion :: VersionRange -> Bool -isNoVersion vr = case asVersionIntervals vr of - [] -> True - _ -> False - --- | Is this version range in fact just a specific version? --- --- For example the version range @\">= 3 && <= 3\"@ contains only the version --- @3@. --- -isSpecificVersion :: VersionRange -> Maybe Version -isSpecificVersion vr = case asVersionIntervals vr of - [VersionInterval (LowerBound v InclusiveBound) (UpperBound v' InclusiveBound)] - | v == v' -> Just v - _ -> Nothing - -------------------------------------------------------------------------------- --- Transformations -------------------------------------------------------------------------------- - --- | Simplify a 'VersionRange' expression. For non-empty version ranges --- this produces a canonical form. Empty or inconsistent version ranges --- are left as-is because that provides more information. --- --- If you need a canonical form use --- @fromVersionIntervals . toVersionIntervals@ --- --- It satisfies the following properties: --- --- > withinRange v (simplifyVersionRange r) = withinRange v r --- --- > withinRange v r = withinRange v r' --- > ==> simplifyVersionRange r = simplifyVersionRange r' --- > || isNoVersion r --- > || isNoVersion r' --- -simplifyVersionRange :: VersionRange -> VersionRange -simplifyVersionRange vr - -- If the version range is inconsistent then we just return the - -- original since that has more information than ">1 && < 1", which - -- is the canonical inconsistent version range. - | null (unVersionIntervals vi) = vr - | otherwise = fromVersionIntervals vi - where - vi = toVersionIntervals vr - --- | Given a version range, remove the highest upper bound. Example: @(>= 1 && < --- 3) || (>= 4 && < 5)@ is converted to @(>= 1 && < 3) || (>= 4)@. -removeUpperBound :: VersionRange -> VersionRange -removeUpperBound = fromVersionIntervals . relaxLastInterval . toVersionIntervals - --- | Given a version range, remove the lowest lower bound. --- Example: @(>= 1 && < 3) || (>= 4 && < 5)@ is converted to --- @(>= 0 && < 3) || (>= 4 && < 5)@. -removeLowerBound :: VersionRange -> VersionRange -removeLowerBound = fromVersionIntervals . relaxHeadInterval . toVersionIntervals - --- | Rewrite @^>= x.y.z@ into @>= x.y.z && < x.(y+1)@ --- --- @since 3.6.0.0 --- -transformCaret :: VersionRange -> VersionRange -transformCaret = hyloVersionRange embed projectVersionRange where - embed (MajorBoundVersionF v) = orLaterVersion v `intersectVersionRanges` earlierVersion (majorUpperBound v) - embed vr = embedVersionRange vr - --- | Rewrite @^>= x.y.z@ into @>= x.y.z@ --- --- @since 3.6.0.0 --- -transformCaretUpper :: VersionRange -> VersionRange -transformCaretUpper = hyloVersionRange embed projectVersionRange where - embed (MajorBoundVersionF v) = orLaterVersion v - embed vr = embedVersionRange vr - --- | Rewrite @^>= x.y.z@ into @ VersionRange -transformCaretLower = hyloVersionRange embed projectVersionRange where - embed (MajorBoundVersionF v) = earlierVersion (majorUpperBound v) - embed vr = embedVersionRange vr diff --git a/src/Language/Haskell/Extension.hs b/src/Language/Haskell/Extension.hs deleted file mode 100644 --- a/src/Language/Haskell/Extension.hs +++ /dev/null @@ -1,933 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} - ------------------------------------------------------------------------------ --- | --- Module : Language.Haskell.Extension --- Copyright : Isaac Jones 2003-2004 --- License : BSD3 --- --- Maintainer : libraries@haskell.org --- Portability : portable --- --- Haskell language dialects and extensions - -module Language.Haskell.Extension ( - Language(..), - knownLanguages, - classifyLanguage, - - Extension(..), - KnownExtension(..), - deprecatedExtensions, - classifyExtension, - ) where - -import qualified Prelude (head) -import Distribution.Compat.Prelude - -import Data.Array (Array, accumArray, bounds, Ix(inRange), (!)) - -import Distribution.Parsec -import Distribution.Pretty - -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp - --- ------------------------------------------------------------ --- * Language --- ------------------------------------------------------------ - --- | This represents a Haskell language dialect. --- --- Language 'Extension's are interpreted relative to one of these base --- languages. --- -data Language = - - -- | The Haskell 98 language as defined by the Haskell 98 report. - -- - Haskell98 - - -- | The Haskell 2010 language as defined by the Haskell 2010 report. - -- - | Haskell2010 - - -- | The GHC2021 collection of language extensions. - -- - | GHC2021 - - -- | An unknown language, identified by its name. - | UnknownLanguage String - deriving (Generic, Show, Read, Eq, Typeable, Data) - -instance Binary Language -instance Structured Language - -instance NFData Language where rnf = genericRnf - --- | List of known (supported) languages for GHC -knownLanguages :: [Language] -knownLanguages = [Haskell98, Haskell2010, GHC2021] - -instance Pretty Language where - pretty (UnknownLanguage other) = Disp.text other - pretty other = Disp.text (show other) - -instance Parsec Language where - parsec = classifyLanguage <$> P.munch1 isAlphaNum - -classifyLanguage :: String -> Language -classifyLanguage = \str -> case lookup str langTable of - Just lang -> lang - Nothing -> UnknownLanguage str - where - langTable = [ (show lang, lang) - | lang <- knownLanguages ] - --- ------------------------------------------------------------ --- * Extension --- ------------------------------------------------------------ - --- Note: if you add a new 'KnownExtension': --- --- * also add it to the Distribution.Simple.X.languageExtensions lists --- (where X is each compiler: GHC, UHC, HaskellSuite) --- --- | This represents language extensions beyond a base 'Language' definition --- (such as 'Haskell98') that are supported by some implementations, usually --- in some special mode. --- --- Where applicable, references are given to an implementation's --- official documentation. - -data Extension = - -- | Enable a known extension - EnableExtension KnownExtension - - -- | Disable a known extension - | DisableExtension KnownExtension - - -- | An unknown extension, identified by the name of its @LANGUAGE@ - -- pragma. - | UnknownExtension String - - deriving (Generic, Show, Read, Eq, Ord, Typeable, Data) - -instance Binary Extension -instance Structured Extension - -instance NFData Extension where rnf = genericRnf - -data KnownExtension = - - -- | Allow overlapping class instances, provided there is a unique - -- most specific instance for each use. - -- - -- * - OverlappingInstances - - -- | Ignore structural rules guaranteeing the termination of class - -- instance resolution. Termination is guaranteed by a fixed-depth - -- recursion stack, and compilation may fail if this depth is - -- exceeded. - -- - -- * - | UndecidableInstances - - -- | Implies 'OverlappingInstances'. Allow the implementation to - -- choose an instance even when it is possible that further - -- instantiation of types will lead to a more specific instance - -- being applicable. - -- - -- * - | IncoherentInstances - - -- | /(deprecated)/ Deprecated in favour of 'RecursiveDo'. - -- - -- Old description: Allow recursive bindings in @do@ blocks, using - -- the @rec@ keyword. See also 'RecursiveDo'. - | DoRec - - -- | Allow recursive bindings in @do@ blocks, using the @rec@ - -- keyword, or @mdo@, a variant of @do@. - -- - -- * - | RecursiveDo - - -- | Provide syntax for writing list comprehensions which iterate - -- over several lists together, like the 'zipWith' family of - -- functions. - -- - -- * - | ParallelListComp - - -- | Allow multiple parameters in a type class. - -- - -- * - | MultiParamTypeClasses - - -- | Enable the dreaded monomorphism restriction. - -- - -- * - | MonomorphismRestriction - - -- | Allow a specification attached to a multi-parameter type class - -- which indicates that some parameters are entirely determined by - -- others. The implementation will check that this property holds - -- for the declared instances, and will use this property to reduce - -- ambiguity in instance resolution. - -- - -- * - | FunctionalDependencies - - -- | /(deprecated)/ A synonym for 'RankNTypes'. - -- - -- Old description: Like 'RankNTypes' but does not allow a - -- higher-rank type to itself appear on the left of a function - -- arrow. - -- - -- * - | Rank2Types - - -- | Allow a universally-quantified type to occur on the left of a - -- function arrow. - -- - -- * - | RankNTypes - - -- | /(deprecated)/ A synonym for 'RankNTypes'. - -- - -- Old description: Allow data constructors to have polymorphic - -- arguments. Unlike 'RankNTypes', does not allow this for ordinary - -- functions. - -- - -- * - | PolymorphicComponents - - -- | Allow existentially-quantified data constructors. - -- - -- * - | ExistentialQuantification - - -- | Cause a type variable in a signature, which has an explicit - -- @forall@ quantifier, to scope over the definition of the - -- accompanying value declaration. - -- - -- * - | ScopedTypeVariables - - -- | Deprecated, use 'ScopedTypeVariables' instead. - | PatternSignatures - - -- | Enable implicit function parameters with dynamic scope. - -- - -- * - | ImplicitParams - - -- | Relax some restrictions on the form of the context of a type - -- signature. - -- - -- * - | FlexibleContexts - - -- | Relax some restrictions on the form of the context of an - -- instance declaration. - -- - -- * - | FlexibleInstances - - -- | Allow data type declarations with no constructors. - -- - -- * - | EmptyDataDecls - - -- | Run the C preprocessor on Haskell source code. - -- - -- * - | CPP - - -- | Allow an explicit kind signature giving the kind of types over - -- which a type variable ranges. - -- - -- * - | KindSignatures - - -- | Enable a form of pattern which forces evaluation before an - -- attempted match, and a form of strict @let@/@where@ binding. - -- - -- * - | BangPatterns - - -- | Allow type synonyms in instance heads. - -- - -- * - | TypeSynonymInstances - - -- | Enable Template Haskell, a system for compile-time - -- metaprogramming. - -- - -- * - | TemplateHaskell - - -- | Enable the Foreign Function Interface. In GHC, implements the - -- standard Haskell 98 Foreign Function Interface Addendum, plus - -- some GHC-specific extensions. - -- - -- * - | ForeignFunctionInterface - - -- | Enable arrow notation. - -- - -- * - | Arrows - - -- | /(deprecated)/ Enable generic type classes, with default instances defined in - -- terms of the algebraic structure of a type. - -- - -- * - | Generics - - -- | Enable the implicit importing of the module "Prelude". When - -- disabled, when desugaring certain built-in syntax into ordinary - -- identifiers, use whatever is in scope rather than the "Prelude" - -- -- version. - -- - -- * - | ImplicitPrelude - - -- | Enable syntax for implicitly binding local names corresponding - -- to the field names of a record. Puns bind specific names, unlike - -- 'RecordWildCards'. - -- - -- * - | NamedFieldPuns - - -- | Enable a form of guard which matches a pattern and binds - -- variables. - -- - -- * - | PatternGuards - - -- | Allow a type declared with @newtype@ to use @deriving@ for any - -- class with an instance for the underlying type. - -- - -- * - | GeneralizedNewtypeDeriving - - -- Synonym for GeneralizedNewtypeDeriving added in GHC 8.6.1. - | GeneralisedNewtypeDeriving - - -- | Enable the \"Trex\" extensible records system. - -- - -- * - | ExtensibleRecords - - -- | Enable type synonyms which are transparent in some definitions - -- and opaque elsewhere, as a way of implementing abstract - -- datatypes. - -- - -- * - | RestrictedTypeSynonyms - - -- | Enable an alternate syntax for string literals, - -- with string templating. - -- - -- * - | HereDocuments - - -- | Allow the character @#@ as a postfix modifier on identifiers. - -- Also enables literal syntax for unboxed values. - -- - -- * - | MagicHash - - -- | Allow data types and type synonyms which are indexed by types, - -- i.e. ad-hoc polymorphism for types. - -- - -- * - | TypeFamilies - - -- | Allow a standalone declaration which invokes the type class - -- @deriving@ mechanism. - -- - -- * - | StandaloneDeriving - - -- | Allow certain Unicode characters to stand for certain ASCII - -- character sequences, e.g. keywords and punctuation. - -- - -- * - | UnicodeSyntax - - -- | Allow the use of unboxed types as foreign types, e.g. in - -- @foreign import@ and @foreign export@. - -- - -- * - | UnliftedFFITypes - - -- | Enable interruptible FFI. - -- - -- * - | InterruptibleFFI - - -- | Allow use of CAPI FFI calling convention (@foreign import capi@). - -- - -- * - | CApiFFI - - -- | Defer validity checking of types until after expanding type - -- synonyms, relaxing the constraints on how synonyms may be used. - -- - -- * - | LiberalTypeSynonyms - - -- | Allow the name of a type constructor, type class, or type - -- variable to be an infix operator. - -- * - | TypeOperators - - -- | Enable syntax for implicitly binding local names corresponding - -- to the field names of a record. A wildcard binds all unmentioned - -- names, unlike 'NamedFieldPuns'. - -- - -- * - | RecordWildCards - - -- | Deprecated, use 'NamedFieldPuns' instead. - | RecordPuns - - -- | Allow a record field name to be disambiguated by the type of - -- the record it's in. - -- - -- * - | DisambiguateRecordFields - - -- | Enable traditional record syntax (as supported by Haskell 98) - -- - -- * - | TraditionalRecordSyntax - - -- | Enable overloading of string literals using a type class, much - -- like integer literals. - -- - -- * - | OverloadedStrings - - -- | Enable generalized algebraic data types, in which type - -- variables may be instantiated on a per-constructor basis. Implies - -- 'GADTSyntax'. - -- - -- * - | GADTs - - -- | Enable GADT syntax for declaring ordinary algebraic datatypes. - -- - -- * - | GADTSyntax - - -- | /(deprecated)/ Has no effect. - -- - -- Old description: Make pattern bindings monomorphic. - -- - -- * - | MonoPatBinds - - -- | Relax the requirements on mutually-recursive polymorphic - -- functions. - -- - -- * - | RelaxedPolyRec - - -- | Allow default instantiation of polymorphic types in more - -- situations. - -- - -- * - | ExtendedDefaultRules - - -- | Enable unboxed tuples. - -- - -- * - | UnboxedTuples - - -- | Enable @deriving@ for classes 'Data.Typeable.Typeable' and - -- 'Data.Generics.Data'. - -- - -- * - | DeriveDataTypeable - - -- | Enable @deriving@ for 'GHC.Generics.Generic' and 'GHC.Generics.Generic1'. - -- - -- * - | DeriveGeneric - - -- | Enable support for default signatures. - -- - -- * - | DefaultSignatures - - -- | Allow type signatures to be specified in instance declarations. - -- - -- * - | InstanceSigs - - -- | Allow a class method's type to place additional constraints on - -- a class type variable. - -- - -- * - | ConstrainedClassMethods - - -- | Allow imports to be qualified by the package name the module is - -- intended to be imported from, e.g. - -- - -- > import "network" Network.Socket - -- - -- * - | PackageImports - - -- | /(deprecated)/ Allow a type variable to be instantiated at a - -- polymorphic type. - -- - -- * - | ImpredicativeTypes - - -- | /(deprecated)/ Change the syntax for qualified infix operators. - -- - -- * - | NewQualifiedOperators - - -- | Relax the interpretation of left operator sections to allow - -- unary postfix operators. - -- - -- * - | PostfixOperators - - -- | Enable quasi-quotation, a mechanism for defining new concrete - -- syntax for expressions and patterns. - -- - -- * - | QuasiQuotes - - -- | Enable generalized list comprehensions, supporting operations - -- such as sorting and grouping. - -- - -- * - | TransformListComp - - -- | Enable monad comprehensions, which generalise the list - -- comprehension syntax to work for any monad. - -- - -- * - | MonadComprehensions - - -- | Enable view patterns, which match a value by applying a - -- function and matching on the result. - -- - -- * - | ViewPatterns - - -- | Allow concrete XML syntax to be used in expressions and patterns, - -- as per the Haskell Server Pages extension language: - -- . The ideas behind it are - -- discussed in the paper \"Haskell Server Pages through Dynamic Loading\" - -- by Niklas Broberg, from Haskell Workshop '05. - | XmlSyntax - - -- | Allow regular pattern matching over lists, as discussed in the - -- paper \"Regular Expression Patterns\" by Niklas Broberg, Andreas Farre - -- and Josef Svenningsson, from ICFP '04. - | RegularPatterns - - -- | Enable the use of tuple sections, e.g. @(, True)@ desugars into - -- @\x -> (x, True)@. - -- - -- * - | TupleSections - - -- | Allow GHC primops, written in C--, to be imported into a Haskell - -- file. - | GHCForeignImportPrim - - -- | Support for patterns of the form @n + k@, where @k@ is an - -- integer literal. - -- - -- * - | NPlusKPatterns - - -- | Improve the layout rule when @if@ expressions are used in a @do@ - -- block. - | DoAndIfThenElse - - -- | Enable support for multi-way @if@-expressions. - -- - -- * - | MultiWayIf - - -- | Enable support lambda-@case@ expressions. - -- - -- * - | LambdaCase - - -- | Makes much of the Haskell sugar be desugared into calls to the - -- function with a particular name that is in scope. - -- - -- * - | RebindableSyntax - - -- | Make @forall@ a keyword in types, which can be used to give the - -- generalisation explicitly. - -- - -- * - | ExplicitForAll - - -- | Allow contexts to be put on datatypes, e.g. the @Eq a@ in - -- @data Eq a => Set a = NilSet | ConsSet a (Set a)@. - -- - -- * - | DatatypeContexts - - -- | Local (@let@ and @where@) bindings are monomorphic. - -- - -- * - | MonoLocalBinds - - -- | Enable @deriving@ for the 'Data.Functor.Functor' class. - -- - -- * - | DeriveFunctor - - -- | Enable @deriving@ for the 'Data.Traversable.Traversable' class. - -- - -- * - | DeriveTraversable - - -- | Enable @deriving@ for the 'Data.Foldable.Foldable' class. - -- - -- * - | DeriveFoldable - - -- | Enable non-decreasing indentation for @do@ blocks. - -- - -- * - | NondecreasingIndentation - - -- | Allow imports to be qualified with a safe keyword that requires - -- the imported module be trusted as according to the Safe Haskell - -- definition of trust. - -- - -- > import safe Network.Socket - -- - -- * - | SafeImports - - -- | Compile a module in the Safe, Safe Haskell mode -- a restricted - -- form of the Haskell language to ensure type safety. - -- - -- * - | Safe - - -- | Compile a module in the Trustworthy, Safe Haskell mode -- no - -- restrictions apply but the module is marked as trusted as long as - -- the package the module resides in is trusted. - -- - -- * - | Trustworthy - - -- | Compile a module in the Unsafe, Safe Haskell mode so that - -- modules compiled using Safe, Safe Haskell mode can't import it. - -- - -- * - | Unsafe - - -- | Allow type class/implicit parameter/equality constraints to be - -- used as types with the special kind constraint. Also generalise - -- the @(ctxt => ty)@ syntax so that any type of kind constraint can - -- occur before the arrow. - -- - -- * - | ConstraintKinds - - -- | Enable kind polymorphism. - -- - -- * - | PolyKinds - - -- | Enable datatype promotion. - -- - -- * - | DataKinds - - -- | Enable parallel arrays syntax (@[:@, @:]@) for /Data Parallel Haskell/. - -- - -- * - | ParallelArrays - - -- | Enable explicit role annotations, like in (@type role Foo representational representational@). - -- - -- * - | RoleAnnotations - - -- | Enable overloading of list literals, arithmetic sequences and - -- list patterns using the 'IsList' type class. - -- - -- * - | OverloadedLists - - -- | Enable case expressions that have no alternatives. Also applies to lambda-case expressions if they are enabled. - -- - -- * - | EmptyCase - - -- | /(deprecated)/ Deprecated in favour of 'DeriveDataTypeable'. - -- - -- Old description: Triggers the generation of derived 'Typeable' - -- instances for every datatype and type class declaration. - -- - -- * - | AutoDeriveTypeable - - -- | Desugars negative literals directly (without using negate). - -- - -- * - | NegativeLiterals - - -- | Allow the use of binary integer literal syntax (e.g. @0b11001001@ to denote @201@). - -- - -- * - | BinaryLiterals - - -- | Allow the use of floating literal syntax for all instances of 'Num', including 'Int' and 'Integer'. - -- - -- * - | NumDecimals - - -- | Enable support for type classes with no type parameter. - -- - -- * - | NullaryTypeClasses - - -- | Enable explicit namespaces in module import/export lists. - -- - -- * - | ExplicitNamespaces - - -- | Allow the user to write ambiguous types, and the type inference engine to infer them. - -- - -- * - | AllowAmbiguousTypes - - -- | Enable @foreign import javascript@. - | JavaScriptFFI - - -- | Allow giving names to and abstracting over patterns. - -- - -- * - | PatternSynonyms - - -- | Allow anonymous placeholders (underscore) inside type signatures. The - -- type inference engine will generate a message describing the type inferred - -- at the hole's location. - -- - -- * - | PartialTypeSignatures - - -- | Allow named placeholders written with a leading underscore inside type - -- signatures. Wildcards with the same name unify to the same type. - -- - -- * - | NamedWildCards - - -- | Enable @deriving@ for any class. - -- - -- * - | DeriveAnyClass - - -- | Enable @deriving@ for the 'Language.Haskell.TH.Syntax.Lift' class. - -- - -- * - | DeriveLift - - -- | Enable support for 'static pointers' (and the @static@ - -- keyword) to refer to globally stable names, even across - -- different programs. - -- - -- * - | StaticPointers - - -- | Switches data type declarations to be strict by default (as if - -- they had a bang using @BangPatterns@), and allow opt-in field - -- laziness using @~@. - -- - -- * - | StrictData - - -- | Switches all pattern bindings to be strict by default (as if - -- they had a bang using @BangPatterns@), ordinary patterns are - -- recovered using @~@. Implies @StrictData@. - -- - -- * - | Strict - - -- | Allows @do@-notation for types that are @'Applicative'@ as well - -- as @'Monad'@. When enabled, desugaring @do@ notation tries to use - -- @(<*>)@ and @'fmap'@ and @'join'@ as far as possible. - | ApplicativeDo - - -- | Allow records to use duplicated field labels for accessors. - | DuplicateRecordFields - - -- | Enable explicit type applications with the syntax @id \@Int@. - | TypeApplications - - -- | Dissolve the distinction between types and kinds, allowing the compiler - -- to reason about kind equality and therefore enabling GADTs to be promoted - -- to the type-level. - | TypeInType - - -- | Allow recursive (and therefore undecidable) super-class relationships. - | UndecidableSuperClasses - - -- | A temporary extension to help library authors check if their - -- code will compile with the new planned desugaring of fail. - | MonadFailDesugaring - - -- | A subset of @TemplateHaskell@ including only quoting. - | TemplateHaskellQuotes - - -- | Allows use of the @#label@ syntax. - | OverloadedLabels - - -- | Allow functional dependency annotations on type families to declare them - -- as injective. - | TypeFamilyDependencies - - -- | Allow multiple @deriving@ clauses, each optionally qualified with a - -- /strategy/. - | DerivingStrategies - - -- | Enable deriving instances via types of the same runtime representation. - -- Implies 'DerivingStrategies'. - | DerivingVia - - -- | Enable the use of unboxed sum syntax. - | UnboxedSums - - -- | Allow use of hexadecimal literal notation for floating-point values. - | HexFloatLiterals - - -- | Allow @do@ blocks etc. in argument position. - | BlockArguments - - -- | Allow use of underscores in numeric literals. - | NumericUnderscores - - -- | Allow @forall@ in constraints. - | QuantifiedConstraints - - -- | Have @*@ refer to @Type@. - | StarIsType - - -- | Liberalises deriving to provide instances for empty data types. - -- - -- * - | EmptyDataDeriving - - -- | Enable detection of complete user-supplied kind signatures. - | CUSKs - - -- | Allows the syntax @import M qualified@. - | ImportQualifiedPost - - -- | Allow the use of standalone kind signatures. - | StandaloneKindSignatures - - -- | Enable unlifted newtypes. - | UnliftedNewtypes - - -- | Use whitespace to determine whether the minus sign stands for negation or subtraction. - | LexicalNegation - - -- | Enable qualified do-notation desugaring. - | QualifiedDo - - -- | Enable linear types. - | LinearTypes - - -- | Enable the generation of selector functions corresponding to record fields. - | FieldSelectors - - -- | Enable the use of record dot-accessor and updater syntax - | OverloadedRecordDot - - -- | Enable data types for which an unlifted or levity-polymorphic result kind is inferred. - | UnliftedDatatypes - - deriving (Generic, Show, Read, Eq, Ord, Enum, Bounded, Typeable, Data) - -instance Binary KnownExtension -instance Structured KnownExtension - -instance NFData KnownExtension where rnf = genericRnf - --- | Extensions that have been deprecated, possibly paired with another --- extension that replaces it. --- -deprecatedExtensions :: [(Extension, Maybe Extension)] -deprecatedExtensions = - [ (EnableExtension RecordPuns, Just (EnableExtension NamedFieldPuns)) - , (EnableExtension PatternSignatures, Just (EnableExtension ScopedTypeVariables)) - ] --- NOTE: when adding deprecated extensions that have new alternatives --- we must be careful to make sure that the deprecation messages are --- valid. We must not recommend aliases that cannot be used with older --- compilers, perhaps by adding support in Cabal to translate the new --- name to the old one for older compilers. Otherwise we are in danger --- of the scenario in ticket #689. - -instance Pretty Extension where - pretty (UnknownExtension other) = Disp.text other - pretty (EnableExtension ke) = Disp.text (show ke) - pretty (DisableExtension ke) = Disp.text ("No" ++ show ke) - -instance Parsec Extension where - parsec = classifyExtension <$> P.munch1 isAlphaNum - -instance Pretty KnownExtension where - pretty ke = Disp.text (show ke) - -classifyExtension :: String -> Extension -classifyExtension string - = case classifyKnownExtension string of - Just ext -> EnableExtension ext - Nothing -> - case string of - 'N':'o':string' -> - case classifyKnownExtension string' of - Just ext -> DisableExtension ext - Nothing -> UnknownExtension string - _ -> UnknownExtension string - --- | 'read' for 'KnownExtension's is really really slow so for the Text --- instance --- what we do is make a simple table indexed off the first letter in the --- extension name. The extension names actually cover the range @'A'-'Z'@ --- pretty densely and the biggest bucket is 7 so it's not too bad. We just do --- a linear search within each bucket. --- --- This gives an order of magnitude improvement in parsing speed, and it'll --- also allow us to do case insensitive matches in future if we prefer. --- -classifyKnownExtension :: String -> Maybe KnownExtension -classifyKnownExtension "" = Nothing -classifyKnownExtension string@(c : _) - | inRange (bounds knownExtensionTable) c - = lookup string (knownExtensionTable ! c) - | otherwise = Nothing - -knownExtensionTable :: Array Char [(String, KnownExtension)] -knownExtensionTable = - accumArray (flip (:)) [] ('A', 'Z') - [ (Prelude.head str, (str, extension)) -- assume KnownExtension's Show returns a non-empty string - | extension <- [toEnum 0 ..] - , let str = show extension ]