Cabal 3.0.2.0 → 3.2.0.0

raw patch · 172 files changed

+2485/−1058 lines, 172 filesdep ~semigroupsdep ~taggedPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: semigroups, tagged

API changes (from Hackage documentation)

Files

• Cabal.cabal +23/−3
• ChangeLog.md +17/−0
• Distribution/Backpack.hs +2/−2
• Distribution/Backpack/ComponentsGraph.hs +2/−1
• Distribution/Backpack/Configure.hs +2/−1
• Distribution/Backpack/ModSubst.hs +1/−3
• Distribution/Backpack/ModuleShape.hs +3/−2
• Distribution/Backpack/PreModuleShape.hs +0/−1
• Distribution/Compat/Async.hs +148/−0
• Distribution/Compat/Binary.hs +8/−8
• Distribution/Compat/DList.hs +1/−1
• Distribution/Compat/Graph.hs +21/−16
• Distribution/Compat/Lens.hs +0/−1
• Distribution/Compat/Parsing.hs +6/−32
• Distribution/Compat/Prelude.hs +17/−5
• Distribution/Compat/Semigroup.hs +9/−2
• Distribution/Compat/Time.hs +5/−1
• Distribution/Compat/Typeable.hs +18/−0
• Distribution/Compiler.hs +6/−4
• Distribution/FieldGrammar.hs +1/−0
• Distribution/FieldGrammar/Class.hs +20/−2
• Distribution/FieldGrammar/FieldDescrs.hs +2/−0
• Distribution/FieldGrammar/Parsec.hs +54/−37
• Distribution/FieldGrammar/Pretty.hs +2/−0
• Distribution/Fields/ConfVar.hs +1/−1
• Distribution/Fields/Field.hs +1/−1
• Distribution/Fields/LexerMonad.hs +6/−5
• Distribution/Fields/ParseResult.hs +5/−4
• Distribution/Fields/Pretty.hs +0/−1
• Distribution/InstalledPackageInfo.hs +11/−10
• Distribution/License.hs +1/−1
• Distribution/ModuleName.hs +10/−8
• Distribution/PackageDescription.hs +2/−0
• Distribution/PackageDescription/Check.hs +24/−21
• Distribution/PackageDescription/Configuration.hs +0/−1
• Distribution/PackageDescription/FieldGrammar.hs +10/−10
• Distribution/PackageDescription/Parsec.hs +3/−4
• Distribution/PackageDescription/PrettyPrint.hs +4/−11
• Distribution/PackageDescription/Quirks.hs +6/−14
• Distribution/Parsec.hs +8/−7
• Distribution/Parsec/Newtypes.hs +45/−10
• Distribution/Pretty.hs +0/−1
• Distribution/SPDX/License.hs +1/−0
• Distribution/SPDX/LicenseExceptionId.hs +6/−0
• Distribution/SPDX/LicenseExpression.hs +2/−0
• Distribution/SPDX/LicenseId.hs +6/−0
• Distribution/SPDX/LicenseReference.hs +1/−0
• Distribution/Simple.hs +2/−2
• Distribution/Simple/Build.hs +5/−2
• Distribution/Simple/Build/Macros.hs +8/−4
• Distribution/Simple/BuildTarget.hs +4/−2
• Distribution/Simple/Compiler.hs +12/−6
• Distribution/Simple/Configure.hs +20/−15
• Distribution/Simple/Flag.hs +3/−1
• Distribution/Simple/GHC.hs +18/−16
• Distribution/Simple/GHCJS.hs +15/−12
• Distribution/Simple/Glob.hs +3/−1
• Distribution/Simple/Haddock.hs +23/−15
• Distribution/Simple/HaskellSuite.hs +8/−7
• Distribution/Simple/InstallDirs.hs +5/−2
• Distribution/Simple/InstallDirs/Internal.hs +5/−2
• Distribution/Simple/PackageIndex.hs +10/−7
• Distribution/Simple/PreProcess.hs +4/−5
• Distribution/Simple/PreProcess/Unlit.hs +4/−5
• Distribution/Simple/Program.hs +1/−0
• Distribution/Simple/Program/Db.hs +16/−8
• Distribution/Simple/Program/Find.hs +3/−1
• Distribution/Simple/Program/GHC.hs +9/−3
• Distribution/Simple/Program/HcPkg.hs +78/−55
• Distribution/Simple/Program/Internal.hs +2/−1
• Distribution/Simple/Program/Run.hs +51/−36
• Distribution/Simple/Program/Script.hs +9/−3
• Distribution/Simple/Program/Types.hs +4/−1
• Distribution/Simple/Setup.hs +46/−38
• Distribution/Simple/ShowBuildInfo.hs +4/−1
• Distribution/Simple/Test/LibV09.hs +3/−1
• Distribution/Simple/Test/Log.hs +1/−1
• Distribution/Simple/UHC.hs +5/−4
• Distribution/Simple/Utils.hs +57/−55
• Distribution/System.hs +3/−3
• Distribution/Types/AbiDependency.hs +3/−1
• Distribution/Types/AbiHash.hs +2/−2
• Distribution/Types/Benchmark.hs +1/−1
• Distribution/Types/BenchmarkInterface.hs +1/−1
• Distribution/Types/BenchmarkType.hs +1/−1
• Distribution/Types/BuildInfo.hs +2/−2
• Distribution/Types/BuildType.hs +1/−1
• Distribution/Types/ComponentId.hs +1/−0
• Distribution/Types/ComponentLocalBuildInfo.hs +3/−1
• Distribution/Types/ComponentName.hs +1/−0
• Distribution/Types/ComponentRequestedSpec.hs +4/−1
• Distribution/Types/CondTree.hs +3/−2
• Distribution/Types/Condition.hs +1/−1
• Distribution/Types/ConfVar.hs +25/−0
• Distribution/Types/Dependency.hs +1/−1
• Distribution/Types/DependencyMap.hs +0/−1
• Distribution/Types/ExeDependency.hs +1/−0
• Distribution/Types/Executable.hs +1/−1
• Distribution/Types/ExecutableScope.hs +1/−1
• Distribution/Types/ExposedModule.hs +3/−2
• Distribution/Types/Flag.hs +249/−0
• Distribution/Types/ForeignLib.hs +2/−2
• Distribution/Types/ForeignLibOption.hs +1/−1
• Distribution/Types/ForeignLibType.hs +1/−1
• Distribution/Types/GenericPackageDescription.hs +7/−260
• Distribution/Types/GenericPackageDescription/Lens.hs +3/−3
• Distribution/Types/GivenComponent.hs +1/−1
• Distribution/Types/IncludeRenaming.hs +1/−0
• Distribution/Types/InstalledPackageInfo.hs +12/−9
• Distribution/Types/InstalledPackageInfo/FieldGrammar.hs +9/−9
• Distribution/Types/InstalledPackageInfo/Lens.hs +11/−9
• Distribution/Types/LegacyExeDependency.hs +2/−1
• Distribution/Types/Library.hs +1/−1
• Distribution/Types/LibraryName.hs +1/−0
• Distribution/Types/LibraryVisibility.hs +1/−0
• Distribution/Types/LocalBuildInfo.hs +3/−1
• Distribution/Types/Mixin.hs +1/−0
• Distribution/Types/Module.hs +1/−0
• Distribution/Types/ModuleReexport.hs +1/−1
• Distribution/Types/ModuleRenaming.hs +1/−0
• Distribution/Types/MungedPackageId.hs +1/−0
• Distribution/Types/MungedPackageName.hs +4/−3
• Distribution/Types/PackageDescription.hs +23/−21
• Distribution/Types/PackageDescription/Lens.hs +44/−43
• Distribution/Types/PackageId.hs +6/−4
• Distribution/Types/PackageName.hs +1/−0
• Distribution/Types/PackageVersionConstraint.hs +1/−0
• Distribution/Types/PkgconfigDependency.hs +1/−0
• Distribution/Types/PkgconfigName.hs +1/−0
• Distribution/Types/PkgconfigVersion.hs +1/−0
• Distribution/Types/PkgconfigVersionRange.hs +1/−0
• Distribution/Types/SetupBuildInfo.hs +1/−1
• Distribution/Types/SourceRepo.hs +3/−3
• Distribution/Types/TestSuite.hs +1/−0
• Distribution/Types/TestSuiteInterface.hs +1/−0
• Distribution/Types/TestType.hs +1/−0
• Distribution/Types/UnitId.hs +3/−0
• Distribution/Types/UnqualComponentName.hs +1/−0
• Distribution/Types/Version.hs +2/−1
• Distribution/Types/VersionInterval.hs +3/−3
• Distribution/Types/VersionRange.hs +4/−1
• Distribution/Types/VersionRange/Internal.hs +2/−2
• Distribution/Utils/Generic.hs +64/−2
• Distribution/Utils/IOData.hs +58/−33
• Distribution/Utils/MD5.hs +54/−0
• Distribution/Utils/NubList.hs +7/−4
• Distribution/Utils/ShortText.hs +52/−4
• Distribution/Utils/Structured.hs +472/−0
• Distribution/Verbosity.hs +3/−2
• Distribution/Verbosity/Internal.hs +5/−2
• Language/Haskell/Extension.hs +17/−2
• doc/conf.py +1/−1
• doc/developing-packages.rst +16/−2
• doc/installing-packages.rst +60/−12
• doc/nix-local-build.rst +35/−5
• tests/CheckTests.hs +3/−1
• tests/HackageTests.hs +33/−15
• tests/Instances/TreeDiff.hs +3/−0
• tests/ParserTests.hs +11/−10
• tests/ParserTests/errors/big-version.cabal +1/−1
• tests/ParserTests/regressions/assoc-cpp-options.cabal +48/−0
• tests/ParserTests/regressions/assoc-cpp-options.check +1/−0
• tests/ParserTests/regressions/big-version.cabal +1/−1
• tests/ParserTests/regressions/big-version.expr +1/−1
• tests/ParserTests/regressions/big-version.format +1/−1
• tests/Test/Laws.hs +1/−1
• tests/UnitTests.hs +2/−0
• tests/UnitTests/Distribution/Simple/Program/GHC.hs +50/−1
• tests/UnitTests/Distribution/Simple/Utils.hs +3/−3
• tests/UnitTests/Distribution/Utils/Structured.hs +28/−0
• tests/UnitTests/Distribution/Version.hs +11/−6
• tests/UnitTests/Orphans.hs +10/−0

@@ -1,7 +1,7 @@ cabal-version: >=1.10 name:          Cabal-version:       3.0.2.0-copyright:     2003-2019, Cabal Development Team (see AUTHORS file)+version:       3.2.0.0+copyright:     2003-2020, Cabal Development Team (see AUTHORS file) license:       BSD3 license-file:  LICENSE author:        Cabal Development Team <cabal-devel@haskell.org>@@ -110,6 +110,8 @@   tests/ParserTests/regressions/Octree-0.5.cabal   tests/ParserTests/regressions/Octree-0.5.expr   tests/ParserTests/regressions/Octree-0.5.format+  tests/ParserTests/regressions/assoc-cpp-options.cabal+  tests/ParserTests/regressions/assoc-cpp-options.check   tests/ParserTests/regressions/bad-glob-syntax.cabal   tests/ParserTests/regressions/bad-glob-syntax.check   tests/ParserTests/regressions/big-version.cabal@@ -289,9 +291,10 @@   else     build-depends: unix  >= 2.6.0.0 && < 2.8 -  ghc-options: -Wall -fno-ignore-asserts -fwarn-tabs+  ghc-options: -Wall -fno-ignore-asserts -fwarn-tabs -fwarn-incomplete-uni-patterns   if impl(ghc >= 8.0)     ghc-options: -Wcompat -Wnoncanonical-monad-instances+     if impl(ghc <8.8)       ghc-options: -Wnoncanonical-monadfail-instances @@ -300,6 +303,10 @@     -- already depends on `fail` and `semigroups` transitively     build-depends: fail == 4.9.*, semigroups >= 0.18.3 && < 0.20 +  if !impl(ghc >= 7.8)+    -- semigroups depends on tagged.+    build-depends:  tagged >=0.8.6 && <0.9+   exposed-modules:     Distribution.Backpack     Distribution.Backpack.Configure@@ -315,6 +322,8 @@     Distribution.Utils.IOData     Distribution.Utils.LogProgress     Distribution.Utils.MapAccum+    Distribution.Utils.MD5+    Distribution.Utils.Structured     Distribution.Compat.CreatePipe     Distribution.Compat.Directory     Distribution.Compat.Environment@@ -328,6 +337,7 @@     Distribution.Compat.Semigroup     Distribution.Compat.Stack     Distribution.Compat.Time+    Distribution.Compat.Typeable     Distribution.Compat.DList     Distribution.Compiler     Distribution.InstalledPackageInfo@@ -417,6 +427,7 @@     Distribution.Types.BuildInfo     Distribution.Types.BuildType     Distribution.Types.ComponentInclude+    Distribution.Types.ConfVar     Distribution.Types.Dependency     Distribution.Types.ExeDependency     Distribution.Types.LegacyExeDependency@@ -430,6 +441,7 @@     Distribution.Types.ExecutableScope     Distribution.Types.Library     Distribution.Types.LibraryVisibility+    Distribution.Types.Flag     Distribution.Types.ForeignLib     Distribution.Types.ForeignLibType     Distribution.Types.ForeignLibOption@@ -538,6 +550,7 @@     Distribution.Backpack.Id     Distribution.Utils.UnionFind     Distribution.Utils.Base62+    Distribution.Compat.Async     Distribution.Compat.CopyFile     Distribution.Compat.GetShortPathName     Distribution.Compat.MonadFail@@ -608,8 +621,10 @@     UnitTests.Distribution.Utils.Generic     UnitTests.Distribution.Utils.NubList     UnitTests.Distribution.Utils.ShortText+    UnitTests.Distribution.Utils.Structured     UnitTests.Distribution.Version     UnitTests.Distribution.PkgconfigVersion+    UnitTests.Orphans   main-is: UnitTests.hs   build-depends:     array,@@ -652,6 +667,9 @@   ghc-options: -Wall   default-language: Haskell2010 +  if !impl(ghc >= 8.0)+    build-depends:  semigroups+   if impl(ghc >= 7.8)     build-depends:       tree-diff      >= 0.1 && <0.2@@ -676,6 +694,8 @@     Cabal   ghc-options: -Wall   default-language: Haskell2010+  if !impl(ghc >= 8.0)+    build-depends:  semigroups  test-suite custom-setup-tests   type: exitcode-stdio-1.0

@@ -1,3 +1,20 @@+# 3.2.0.0 [Herbert Valerio Riedel](mailto:hvr@gnu.org) April 2020+  * Change free text `String` fields to use `ShortText` in package description+    and installed packge info.+  * Split `Distribution.Types.Flag` and `Distribution.Types.ConfVar`+    `Distribution.Types.GenericPackageDescription`.+  * Add GHC-8.10 support, including new extensions to+    `Language.Haskell.Extension`.+  * Use more `NonEmpty` instead of ordinary lists.+  * Add `Distribution.Utils.Structured` for fingeprinting `Binary` blobs.+  * Add `null`, `length` and `unsafeFromUTF8BS` to `Distribution.Utils.ShortText`.+  * Refactor `Distribution.Utils.IOData` module.+  * Rename `Distribution.Compat.MD5` to `Distribution.Utils.MD5`.+  * Add `safeHead`, `safeTail`, `safeLast` to `Distribution.Utils.Generic`.+  * Add `unsnoc` and `unsnocNE` to `Distribution.Utils.Generic`.+  * Add `Set'` modifier to `Distribution.Parsec.Newtypes`.+  * Add `Distribution.Compat.Async`.+ # 3.0.2.0 [Herbert Valerio Riedel](mailto:hvr@gnu.org) April 2020   * Disallow spaces around colon `:` in Dependency `build-depends` syntax     ([#6538](https://github.com/haskell/cabal/pull/6538)).

@@ -54,7 +54,6 @@ import Distribution.Utils.Base62  import qualified Data.Map as Map-import           Data.Set (Set) import qualified Data.Set as Set  -----------------------------------------------------------------------@@ -99,7 +98,7 @@ -- 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@@ -166,6 +165,7 @@   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

@@ -19,6 +19,7 @@ import Distribution.Types.UnqualComponentName import Distribution.Compat.Graph (Graph, Node(..)) import qualified Distribution.Compat.Graph as Graph+import Distribution.Utils.Generic  import Distribution.Pretty (pretty) import Text.PrettyPrint@@ -94,4 +95,4 @@     text $ "Components in the package depend on each other in a cyclic way:\n  "        ++ intercalate " depends on "             [ "'" ++ showComponentName cname ++ "'"-            | cname <- cnames ++ [head cnames] ]+            | cname <- cnames ++ maybeToList (safeHead cnames) ]

@@ -162,7 +162,8 @@                        . map Right                        $ graph         combined_graph = Graph.unionRight external_graph internal_graph-        Just local_graph = Graph.closure combined_graph (map nodeKey graph)+        local_graph = fromMaybe (error "toComponentLocalBuildInfos: closure returned Nothing")+                    $ Graph.closure combined_graph (map nodeKey graph)         -- The database of transitively reachable installed packages that the         -- external components the package (as a whole) depends on.  This will be         -- used in several ways:

@@ -13,12 +13,10 @@ import Prelude () import Distribution.Compat.Prelude hiding (mod) -import Distribution.ModuleName- import Distribution.Backpack+import Distribution.ModuleName  import qualified Data.Map as Map-import Data.Set (Set) import qualified Data.Set as Set  -- | Applying module substitutions to semantic objects.

@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} -- | See <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst> module Distribution.Backpack.ModuleShape (@@ -17,7 +18,6 @@ import Distribution.Backpack  import qualified Data.Map as Map-import Data.Set (Set) import qualified Data.Set as Set  -----------------------------------------------------------------------@@ -30,9 +30,10 @@     modShapeProvides :: OpenModuleSubst,     modShapeRequires :: Set ModuleName     }-    deriving (Eq, Show, Generic)+    deriving (Eq, Show, Generic, Typeable)  instance Binary ModuleShape+instance Structured ModuleShape  instance ModSubst ModuleShape where     modSubst subst (ModuleShape provs reqs)

@@ -11,7 +11,6 @@ import Prelude () import Distribution.Compat.Prelude -import Data.Set (Set) import qualified Data.Set as Set import qualified Data.Map as Map 

@@ -0,0 +1,148 @@+{-# LANGUAGE CPP                #-}+{-# LANGUAGE DeriveDataTypeable #-}+-- | 'Async', yet using 'MVar's.+--+-- Adopted from @async@ library+-- Copyright (c) 2012, Simon Marlow+-- Licensed under BSD-3-Clause+--+-- @since 3.2.0.0+--+module Distribution.Compat.Async (+    AsyncM,+    withAsync, waitCatch,+    wait, asyncThreadId,+    cancel, uninterruptibleCancel, AsyncCancelled (..),+    -- * Cabal extras+    withAsyncNF,+    ) where++import Control.Concurrent      (ThreadId, forkIO)+import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, readMVar)+import Control.DeepSeq         (NFData, force)+import Control.Exception+       (BlockedIndefinitelyOnMVar (..), Exception (..), SomeException (..), catch, evaluate, mask, throwIO, throwTo, try, uninterruptibleMask_)+import Control.Monad           (void)+import Data.Typeable           (Typeable)+import GHC.Exts                (inline)++#if MIN_VERSION_base(4,7,0)+import Control.Exception (asyncExceptionFromException, asyncExceptionToException)+#endif++-- | Async, but based on 'MVar', as we don't depend on @stm@.+data AsyncM a = Async+  { asyncThreadId :: {-# UNPACK #-} !ThreadId+                  -- ^ Returns the 'ThreadId' of the thread running+                  -- the given 'Async'.+  , _asyncMVar    :: MVar (Either SomeException a)+  }++-- | Spawn an asynchronous action in a separate thread, and pass its+-- @Async@ handle to the supplied function.  When the function returns+-- or throws an exception, 'uninterruptibleCancel' is called on the @Async@.+--+-- > withAsync action inner = mask $ \restore -> do+-- >   a <- async (restore action)+-- >   restore (inner a) `finally` uninterruptibleCancel a+--+-- This is a useful variant of 'async' that ensures an @Async@ is+-- never left running unintentionally.+--+-- Note: a reference to the child thread is kept alive until the call+-- to `withAsync` returns, so nesting many `withAsync` calls requires+-- linear memory.+--+withAsync :: IO a -> (AsyncM a -> IO b) -> IO b+withAsync = inline withAsyncUsing forkIO++withAsyncNF :: NFData a => IO a -> (AsyncM a -> IO b) -> IO b+withAsyncNF m = inline withAsyncUsing forkIO (m >>= evaluateNF) where+    evaluateNF = evaluate . force++withAsyncUsing :: (IO () -> IO ThreadId) -> IO a -> (AsyncM a -> IO b) -> IO b+-- The bracket version works, but is slow.  We can do better by+-- hand-coding it:+withAsyncUsing doFork = \action inner -> do+  var <- newEmptyMVar+  mask $ \restore -> do+    t <- doFork $ try (restore action) >>= putMVar var+    let a = Async t var+    r <- restore (inner a) `catchAll` \e -> do+        uninterruptibleCancel a+        throwIO e+    uninterruptibleCancel a+    return r++-- | Wait for an asynchronous action to complete, and return its+-- value.  If the asynchronous action threw an exception, then the+-- exception is re-thrown by 'wait'.+--+-- > wait = atomically . waitSTM+--+{-# INLINE wait #-}+wait :: AsyncM a -> IO a+wait a = do+    res <- waitCatch a+    case res of+        Left (SomeException e) -> throwIO e+        Right x                -> return x++-- | Wait for an asynchronous action to complete, and return either+-- @Left e@ if the action raised an exception @e@, or @Right a@ if it+-- returned a value @a@.+--+-- > waitCatch = atomically . waitCatchSTM+--+{-# INLINE waitCatch #-}+waitCatch :: AsyncM a -> IO (Either SomeException a)+waitCatch (Async _ var) = tryAgain (readMVar var)+  where+    -- See: https://github.com/simonmar/async/issues/14+    tryAgain f = f `catch` \BlockedIndefinitelyOnMVar -> f++catchAll :: IO a -> (SomeException -> IO a) -> IO a+catchAll = catch++-- | Cancel an asynchronous action by throwing the @AsyncCancelled@+-- exception to it, and waiting for the `Async` thread to quit.+-- Has no effect if the 'Async' has already completed.+--+-- > cancel a = throwTo (asyncThreadId a) AsyncCancelled <* waitCatch a+--+-- Note that 'cancel' will not terminate until the thread the 'Async'+-- refers to has terminated. This means that 'cancel' will block for+-- as long said thread blocks when receiving an asynchronous exception.+--+-- For example, it could block if:+--+-- * It's executing a foreign call, and thus cannot receive the asynchronous+-- exception;+-- * It's executing some cleanup handler after having received the exception,+-- and the handler is blocking.+{-# INLINE cancel #-}+cancel :: AsyncM a -> IO ()+cancel a@(Async t _) = do+    throwTo t AsyncCancelled+    void (waitCatch a)++-- | The exception thrown by `cancel` to terminate a thread.+data AsyncCancelled = AsyncCancelled+  deriving (Show, Eq+    , Typeable+    )++instance Exception AsyncCancelled where+#if MIN_VERSION_base(4,7,0)+  -- wraps in SomeAsyncException+  -- See https://github.com/ghc/ghc/commit/756a970eacbb6a19230ee3ba57e24999e4157b09+  fromException = asyncExceptionFromException+  toException = asyncExceptionToException+#endif++-- | Cancel an asynchronous action+--+-- This is a variant of `cancel`, but it is not interruptible.+{-# INLINE uninterruptibleCancel #-}+uninterruptibleCancel :: AsyncM a -> IO ()+uninterruptibleCancel = uninterruptibleMask_ . cancel

@@ -18,12 +18,7 @@ #endif        ) where -import Control.Exception (catch, evaluate)-#if __GLASGOW_HASKELL__ >= 711-import Control.Exception (pattern ErrorCall)-#else-import Control.Exception (ErrorCall(..))-#endif+import Control.Exception (ErrorCall (..), catch, evaluate) import Data.ByteString.Lazy (ByteString)  #if __GLASGOW_HASKELL__ >= 708 || MIN_VERSION_binary(0,7,0)@@ -67,5 +62,10 @@  decodeOrFailIO :: Binary a => ByteString -> IO (Either String a) decodeOrFailIO bs =-  catch (evaluate (decode bs) >>= return . Right)-  $ \(ErrorCall str) -> return $ Left str+    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

@@ -19,7 +19,7 @@ ) where  import Prelude ()-import Distribution.Compat.Prelude+import Distribution.Compat.Prelude hiding (toList)  -- | Difference list. newtype DList a = DList ([a] -> [a])

@@ -1,9 +1,10 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE BangPatterns         #-}+{-# LANGUAGE CPP                  #-}+{-# LANGUAGE DeriveDataTypeable   #-}+{-# LANGUAGE FlexibleContexts     #-}+{-# LANGUAGE ScopedTypeVariables  #-}+{-# LANGUAGE TypeFamilies         #-} {-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE BangPatterns #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Compat.Graph@@ -83,20 +84,21 @@     nodeValue, ) where +import Distribution.Compat.Prelude hiding (empty, lookup, null, toList) import Prelude ()-import qualified Distribution.Compat.Prelude as Prelude-import Distribution.Compat.Prelude hiding (lookup, null, empty) -import Data.Graph (SCC(..))-import qualified Data.Graph as G+import Data.Array                    ((!))+import Data.Either                   (partitionEithers)+import Data.Graph                    (SCC (..))+import Distribution.Utils.Structured (Structure (..), Structured (..)) -import qualified Data.Map.Strict as Map-import qualified Data.Set as Set-import qualified Data.Array as Array-import Data.Array ((!))-import qualified Data.Tree as Tree-import Data.Either (partitionEithers)-import qualified Data.Foldable as Foldable+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'.@@ -128,6 +130,9 @@ 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

@@ -51,7 +51,6 @@ import Distribution.Compat.Prelude  import Control.Applicative (Const (..))-import Data.Functor.Identity (Identity (..)) import Control.Monad.State.Class (MonadState (..), gets, modify)  import qualified Distribution.Compat.DList as DList

@@ -25,13 +25,10 @@   , some     -- from Control.Applicative, parsec many1   , many     -- from Control.Applicative   , sepBy-  , sepBy1   , sepByNonEmpty-  , sepEndBy1-  -- , sepEndByNonEmpty+  , sepEndByNonEmpty   , sepEndBy-  , endBy1-  -- , endByNonEmpty+  , endByNonEmpty   , endBy   , count   , chainl@@ -58,6 +55,7 @@ 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,@@ -96,36 +94,20 @@ -- -- >  commaSep p  = p `sepBy` (symbol ",") sepBy :: Alternative m => m a -> m sep -> m [a]-sepBy p sep = sepBy1 p sep <|> pure []+sepBy p sep = toList <$> sepByNonEmpty p sep <|> pure [] {-# INLINE sepBy #-} --- | @sepBy1 p sep@ parses /one/ or more occurrences of @p@, separated--- by @sep@. Returns a list of values returned by @p@.-sepBy1 :: Alternative m => m a -> m sep -> m [a]-sepBy1 p sep = (:) <$> p <*> many (sep *> p)--- toList <$> sepByNonEmpty p sep-{-# INLINE sepBy1 #-}- -- | @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 #-} --- | @sepEndBy1 p sep@ parses /one/ or more occurrences of @p@,--- separated and optionally ended by @sep@. Returns a list of values--- returned by @p@.-sepEndBy1 :: Alternative m => m a -> m sep -> m [a]-sepEndBy1 p sep = (:) <$> p <*> ((sep *> sepEndBy p sep) <|> pure [])--- toList <$> sepEndByNonEmpty p sep--{- -- | @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@@ -133,22 +115,14 @@ -- -- >  haskellStatements  = haskellStatement `sepEndBy` semi sepEndBy :: Alternative m => m a -> m sep -> m [a]-sepEndBy p sep = sepEndBy1 p sep <|> pure []+sepEndBy p sep = toList <$> sepEndByNonEmpty p sep <|> pure [] {-# INLINE sepEndBy #-} --- | @endBy1 p sep@ parses /one/ or more occurrences of @p@, separated--- and ended by @sep@. Returns a list of values returned by @p@.-endBy1 :: Alternative m => m a -> m sep -> m [a]-endBy1 p sep = some (p <* sep)-{-# INLINE endBy1 #-}--{- -- | @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 = some1 (p <* sep)+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@.

@@ -33,11 +33,12 @@     -- * Common type-classes     Semigroup (..),     gmappend, gmempty,-    Typeable,+    Typeable, TypeRep, typeRep,     Data,     Generic,     NFData (..), genericRnf,     Binary (..),+    Structured,     Alternative (..),     MonadPlus (..),     IsString (..),@@ -45,6 +46,9 @@     -- * Some types     IO, NoCallStackIO,     Map,+    Set,+    Identity (..),+    Proxy (..),      -- * Data.Maybe     catMaybes, mapMaybe,@@ -61,6 +65,7 @@      -- * Data.List.NonEmpty     NonEmpty((:|)), foldl1, foldr1,+    head, tail, last, init,      -- * Data.Foldable     Foldable, foldMap, foldr,@@ -68,6 +73,7 @@     find, foldl',     traverse_, for_,     any, all,+    toList,      -- * Data.Traversable     Traversable, traverse, sequenceA,@@ -100,7 +106,7 @@     ) where -- We also could hide few partial function import Prelude                       as BasePrelude hiding-  ( IO, mapM, mapM_, sequence, null, length, foldr, any, all+  ( IO, mapM, mapM_, sequence, null, length, foldr, any, all, head, tail, last, init   -- partial functions   , read   , foldr1, foldl1@@ -120,8 +126,9 @@ #if !MINVER_base_48 import Control.Applicative           (Applicative (..), (<$), (<$>)) import Distribution.Compat.Semigroup (Monoid (..))+import Data.Foldable                 (toList) #else-import Data.Foldable                 (length, null)+import Data.Foldable                 (length, null, Foldable(toList)) #endif  import Data.Foldable                 (Foldable (foldMap, foldr), find, foldl', for_, traverse_, any, all)@@ -131,14 +138,17 @@ import Control.Applicative           (Alternative (..)) import Control.DeepSeq               (NFData (..)) import Data.Data                     (Data)-import Data.Typeable                 (Typeable)+import Distribution.Compat.Typeable  (Typeable, TypeRep, typeRep) import Distribution.Compat.Binary    (Binary (..)) import Distribution.Compat.Semigroup (Semigroup (..), gmappend, gmempty) import GHC.Generics                  (Generic, Rep(..),                                       V1, U1(U1), K1(unK1), M1(unM1),                                       (:*:)((:*:)), (:+:)(L1,R1)) +import Data.Functor.Identity         (Identity (..)) import Data.Map                      (Map)+import Data.Proxy                    (Proxy (..))+import Data.Set                      (Set)  import Control.Arrow                 (first) import Control.Monad                 hiding (mapM)@@ -146,7 +156,7 @@ import Data.List                     (intercalate, intersperse, isPrefixOf,                                       isSuffixOf, nub, nubBy, sort, sortBy,                                       unfoldr)-import Data.List.NonEmpty            (NonEmpty((:|)))+import Data.List.NonEmpty            (NonEmpty((:|)), head, tail, init, last) import Data.Maybe import Data.String                   (IsString (..)) import Data.Int@@ -157,6 +167,8 @@  import qualified Prelude as OrigPrelude import Distribution.Compat.Stack++import Distribution.Utils.Structured (Structured)  type IO a = WithCallStack (OrigPrelude.IO a) type NoCallStackIO a = OrigPrelude.IO a

@@ -1,4 +1,5 @@ {-# LANGUAGE CPP                         #-}+{-# LANGUAGE DeriveDataTypeable          #-} {-# LANGUAGE DeriveGeneric               #-} {-# LANGUAGE FlexibleContexts            #-} {-# LANGUAGE GeneralizedNewtypeDeriving  #-}@@ -21,6 +22,8 @@     ) 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`@@ -38,8 +41,10 @@  -- | A copy of 'Data.Semigroup.Last'. newtype Last' a = Last' { getLast' :: a }-  deriving (Eq, Ord, Read, Show, Binary)+  deriving (Eq, Ord, Read, Show, Generic, Binary, Typeable) +instance Structured a => Structured (Last' a)+ instance Semigroup (Last' a) where   _ <> b = b @@ -49,7 +54,9 @@ -- | 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, Functor)+  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))

@@ -1,4 +1,6 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE FlexibleContexts #-}@@ -55,7 +57,9 @@ -- | An opaque type representing a file's modification time, represented -- internally as a 64-bit unsigned integer in the Windows UTC format. newtype ModTime = ModTime Word64-                deriving (Binary, Bounded, Eq, Ord)+                deriving (Binary, Generic, Bounded, Eq, Ord, Typeable)++instance Structured ModTime  instance Show ModTime where   show (ModTime x) = show x

@@ -0,0 +1,18 @@+{-# 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

@@ -66,7 +66,7 @@   deriving (Generic, Show, Read, Eq, Ord, Typeable, Data)  instance Binary CompilerFlavor-+instance Structured CompilerFlavor instance NFData CompilerFlavor where rnf = genericRnf  knownCompilerFlavors :: [CompilerFlavor]@@ -125,6 +125,7 @@   deriving (Generic, Show, Read, Eq, Typeable, Data)  instance Binary a => Binary (PerCompilerFlavor a)+instance Structured a => Structured (PerCompilerFlavor a) instance NFData a => NFData (PerCompilerFlavor a)  perCompilerFlavorToList :: PerCompilerFlavor v -> [(CompilerFlavor, v)]@@ -143,10 +144,10 @@ -- ------------------------------------------------------------  data CompilerId = CompilerId CompilerFlavor Version-  deriving (Eq, Generic, Ord, Read, Show)+  deriving (Eq, Generic, Ord, Read, Show, Typeable)  instance Binary CompilerId-+instance Structured CompilerId instance NFData CompilerId where rnf = genericRnf  instance Pretty CompilerId where@@ -192,9 +193,10 @@ data AbiTag   = NoAbiTag   | AbiTag String-  deriving (Eq, Generic, Show, Read)+  deriving (Eq, Generic, Show, Read, Typeable)  instance Binary AbiTag+instance Structured AbiTag  instance Pretty AbiTag where   pretty NoAbiTag     = Disp.empty

@@ -25,6 +25,7 @@     takeFields,     runFieldParser,     runFieldParser',+    defaultFreeTextFieldDefST,     )  where  import Distribution.Compat.Prelude

@@ -4,19 +4,19 @@     optionalField,     optionalFieldDef,     monoidalField,+    defaultFreeTextFieldDefST,     ) where  import Distribution.Compat.Lens import Distribution.Compat.Prelude import Prelude () -import Data.Functor.Identity (Identity (..))- import Distribution.CabalSpecVersion (CabalSpecVersion) import Distribution.Compat.Newtype   (Newtype) import Distribution.Fields.Field import Distribution.Parsec           (Parsec) import Distribution.Pretty           (Pretty)+import Distribution.Utils.ShortText  -- | 'FieldGrammar' is parametrised by --@@ -81,6 +81,12 @@         -> 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'.@@ -159,3 +165,15 @@     -> ALens' s a  -- ^ lens into the field     -> g s a monoidalField fn = monoidalFieldAla fn Identity++-- | Default implementation for 'freeTextFieldDefST'.+defaultFreeTextFieldDefST+    :: (Functor (g s), FieldGrammar 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)

@@ -84,6 +84,8 @@         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

@@ -66,17 +66,18 @@  import Data.List                   (dropWhileEnd) import Data.Ord                    (comparing)-import Data.Set                    (Set) import Distribution.Compat.Newtype import Distribution.Compat.Prelude import Distribution.Simple.Utils   (fromUTF8BS) import Prelude () -import qualified Data.ByteString   as BS-import qualified Data.Map.Strict   as Map-import qualified Data.Set          as Set-import qualified Text.Parsec       as P-import qualified Text.Parsec.Error as P+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@@ -84,7 +85,7 @@ import Distribution.Fields.ParseResult import Distribution.Parsec import Distribution.Parsec.FieldLineStream-import Distribution.Parsec.Position        (positionRow, positionCol)+import Distribution.Parsec.Position        (positionCol, positionRow)  ------------------------------------------------------------------------------- -- Auxiliary types@@ -156,12 +157,12 @@     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 -> do+            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-                last <$> traverse (parseOne v) xs+                NE.last <$> traverse (parseOne v) (y:|ys)          parseOne v (MkNamelessField pos fls) =             unpack' _pack <$> runFieldParser pos parsec v fls@@ -169,24 +170,24 @@     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  -> do+            Nothing          -> pure def+            Just []          -> pure def+            Just [x]         -> parseOne v x+            Just xs@(_:y:ys) -> do                 warnMultipleSingularFields fn xs-                last <$> traverse (parseOne v) 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  -> do+            Nothing          -> pure Nothing+            Just []          -> pure Nothing+            Just [x]         -> parseOne v x+            Just xs@(_:y:ys) -> do                 warnMultipleSingularFields fn xs-                last <$> traverse (parseOne v) xs+                NE.last <$> traverse (parseOne v) (y:|ys)          parseOne v (MkNamelessField pos fls)             | null fls  = pure Nothing@@ -195,12 +196,12 @@     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  -> do+            Nothing          -> pure def+            Just []          -> pure def+            Just [x]         -> parseOne v x+            Just xs@(_:y:ys) -> do                 warnMultipleSingularFields fn xs-                last <$> traverse (parseOne v) xs+                NE.last <$> traverse (parseOne v) (y:|ys)          parseOne v (MkNamelessField pos fls)             | null fls  = pure def@@ -208,12 +209,12 @@      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  -> do+            Nothing          -> pure Nothing+            Just []          -> pure Nothing+            Just [x]         -> parseOne v x+            Just xs@(_:y:ys) -> do                 warnMultipleSingularFields fn xs-                last <$> traverse (parseOne v) xs+                NE.last <$> traverse (parseOne v) (y:|ys)          parseOne v (MkNamelessField pos fls)             | null fls           = pure Nothing@@ -222,17 +223,33 @@      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  -> do+            Nothing          -> pure ""+            Just []          -> pure ""+            Just [x]         -> parseOne v x+            Just xs@(_:y:ys) -> do                 warnMultipleSingularFields fn xs-                last <$> traverse (parseOne v) 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

@@ -72,6 +72,8 @@             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)))

@@ -8,7 +8,7 @@ import Distribution.Fields.Field                    (SectionArg (..)) import Distribution.Fields.ParseResult import Distribution.Types.Condition-import Distribution.Types.GenericPackageDescription (ConfVar (..))+import Distribution.Types.ConfVar (ConfVar (..)) import Distribution.Version        (anyVersion, earlierVersion, intersectVersionRanges, laterVersion, majorBoundVersion,        mkVersion, noVersion, orEarlierVersion, orLaterVersion, thisVersion, unionVersionRanges,

@@ -73,7 +73,7 @@ -- | Section arguments, e.g. name of the library data SectionArg ann     = SecArgName  !ann !ByteString-      -- ^ identifier, or omething which loos like number. Also many dot numbers, i.e. "7.6.3"+      -- ^ identifier, or something which looks like number. Also many dot numbers, i.e. "7.6.3"     | SecArgStr   !ann !ByteString       -- ^ quoted string     | SecArgOther !ann !ByteString

@@ -32,6 +32,7 @@   ) 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 (..))@@ -76,15 +77,15 @@ toPWarnings     = map (uncurry toWarning)     . Map.toList-    . Map.fromListWith (++)-    . map (\(LexWarning t p) -> (t, [p]))+    . Map.fromListWith (<>)+    . map (\(LexWarning t p) -> (t, pure p))   where     toWarning LexWarningBOM poss =-        PWarning PWTLexBOM (head poss) "Byte-order mark found at the beginning of the file"+        PWarning PWTLexBOM (NE.head poss) "Byte-order mark found at the beginning of the file"     toWarning LexWarningNBSP poss =-        PWarning PWTLexNBSP (head poss) $ "Non breaking spaces at " ++ intercalate ", " (map showPos poss)+        PWarning PWTLexNBSP (NE.head poss) $ "Non breaking spaces at " ++ intercalate ", " (NE.toList $ fmap showPos poss)     toWarning LexWarningTab poss =-        PWarning PWTLexTab (head poss) $ "Tabs used as indentation at " ++ intercalate ", " (map showPos 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

@@ -50,13 +50,14 @@ -- | 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, [PError]) a)+runParseResult :: ParseResult a -> ([PWarning], Either (Maybe Version, NonEmpty PError) a) runParseResult pr = unPR pr emptyPRState failure success   where-    failure (PRState warns errs v)   = (warns, Left (v, errs))-    success (PRState warns [] _)   x = (warns, Right x)+    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 errs v) _ = (warns, Left (v, errs))+    success (PRState warns (err:errs) v) _ = (warns, Left (v, err :| errs))  instance Functor ParseResult where     fmap f (PR pr) = PR $ \ !s failure success ->

@@ -20,7 +20,6 @@     prettySectionArgs,     ) where -import Data.Functor.Identity       (Identity (..)) import Distribution.Compat.Prelude import Distribution.Pretty         (showToken) import Prelude ()

@@ -43,7 +43,6 @@ import Distribution.Compat.Prelude import Prelude () -import Data.Set                              (Set) import Distribution.Backpack import Distribution.CabalSpecVersion         (cabalSpecLatest) import Distribution.FieldGrammar@@ -53,6 +52,9 @@ import Distribution.Types.ComponentName import Distribution.Utils.Generic            (toUTF8BS) +import Control.DeepSeq (deepseq)+import Data.ByteString (ByteString)+ import qualified Data.Map            as Map import qualified Distribution.Fields as P import qualified Text.PrettyPrint    as Disp@@ -60,7 +62,8 @@ import Distribution.Types.InstalledPackageInfo import Distribution.Types.InstalledPackageInfo.FieldGrammar -+-- $setup+-- >>> :set -XOverloadedStrings  installedComponentId :: InstalledPackageInfo -> ComponentId installedComponentId ipi =@@ -92,19 +95,17 @@ -- Parsing  -- | Return either errors, or IPI with list of warnings------ /Note:/ errors array /may/ be empty, but the parse is still failed (it's a bug though) parseInstalledPackageInfo-    :: String-    -> Either [String] ([String], InstalledPackageInfo)-parseInstalledPackageInfo s = case P.readFields (toUTF8BS s) of-    Left err -> Left [show err]+    :: 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) -> Right (ws', x) where+            (ws, Right x) -> x `deepseq` Right (ws', x) where                 ws' = map (P.showPWarning "") ws             (_,  Left (_, errs)) -> Left errs' where-                errs' = map (P.showPError "") errs+                errs' = fmap (P.showPError "") errs  -- ----------------------------------------------------------------------------- -- Pretty-printing

@@ -128,7 +128,7 @@   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.

@@ -1,5 +1,5 @@ {-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveGeneric      #-}  ----------------------------------------------------------------------------- -- |@@ -23,17 +23,16 @@         validModuleComponent,   ) where -import Prelude () import Distribution.Compat.Prelude--import Distribution.Utils.ShortText-import System.FilePath ( pathSeparator )+import Prelude () -import Distribution.Pretty 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 Text.PrettyPrint as Disp+import qualified Text.PrettyPrint                as Disp  -- | A valid Haskell module name. --@@ -41,6 +40,7 @@   deriving (Eq, Generic, Ord, Read, Show, Typeable, Data)  instance Binary ModuleName+instance Structured ModuleName  instance NFData ModuleName where     rnf (ModuleName ms) = rnf ms@@ -50,7 +50,7 @@     Disp.hcat (intersperse (Disp.char '.') (map Disp.text $ stlToStrings ms))  instance Parsec ModuleName where-    parsec = fromComponents <$> P.sepBy1 component (P.char '.')+    parsec = fromComponents <$> toList <$> P.sepByNonEmpty component (P.char '.')       where         component = do             c  <- P.satisfy isUpper@@ -130,6 +130,8 @@ instance Binary ShortTextLst where     put = put . stlToList     get = stlFromList <$> get++instance Structured ShortTextLst  stlToList :: ShortTextLst -> [ShortText] stlToList STLNil = []

@@ -137,3 +137,5 @@ import Distribution.Types.LibraryName import Distribution.Types.HookedBuildInfo import Distribution.Types.SourceRepo+import Distribution.Types.Flag+import Distribution.Types.ConfVar

@@ -73,6 +73,7 @@ import qualified System.FilePath.Windows as FilePath.Windows (isValid)  import qualified Data.Set as Set+import qualified Distribution.Utils.ShortText as ShortText  import qualified Distribution.Types.BuildInfo.Lens                 as L import qualified Distribution.Types.GenericPackageDescription.Lens as L@@ -497,32 +498,32 @@             ++ "' use '" ++ prettyShow replacement ++ "'."              | (ext, Just replacement) <- ourDeprecatedExtensions ] -  , check (null (category pkg)) $+  , check (ShortText.null (category pkg)) $       PackageDistSuspicious "No 'category' field." -  , check (null (maintainer pkg)) $+  , check (ShortText.null (maintainer pkg)) $       PackageDistSuspicious "No 'maintainer' field." -  , check (null (synopsis pkg) && null (description pkg)) $+  , check (ShortText.null (synopsis pkg) && ShortText.null (description pkg)) $       PackageDistInexcusable "No 'synopsis' or 'description' field." -  , check (null (description pkg) && not (null (synopsis pkg))) $+  , check (ShortText.null (description pkg) && not (ShortText.null (synopsis pkg))) $       PackageDistSuspicious "No 'description' field." -  , check (null (synopsis pkg) && not (null (description pkg))) $+  , check (ShortText.null (synopsis pkg) && not (ShortText.null (description pkg))) $       PackageDistSuspicious "No 'synopsis' field."      --TODO: recommend the bug reports URL, author and homepage fields     --TODO: recommend not using the stability field     --TODO: recommend specifying a source repo -  , check (length (synopsis pkg) >= 80) $+  , check (ShortText.length (synopsis pkg) >= 80) $       PackageDistSuspicious         "The 'synopsis' field is rather long (max 80 chars is recommended)."      -- See also https://github.com/haskell/cabal/pull/3479-  , check (not (null (description pkg))-           && length (description pkg) <= length (synopsis pkg)) $+  , check (not (ShortText.null (description pkg))+           && ShortText.length (description pkg) <= ShortText.length (synopsis pkg)) $       PackageDistSuspicious $            "The 'description' field should be longer than the 'synopsis' "         ++ "field. "@@ -546,10 +547,7 @@         ++ "for example 'tested-with: GHC==6.10.4, GHC==6.12.3' and not "         ++ "'tested-with: GHC==6.10.4 && ==6.12.3'." -  -- Disabled due to #5119: we generate loads of spurious instances of-  -- this warning. Re-enabling this check should be part of the fix to-  -- #5119.-  , check (False && not (null depInternalLibraryWithExtraVersion)) $+  , check (not (null depInternalLibraryWithExtraVersion)) $       PackageBuildWarning $            "The package has an extraneous version range for a dependency on an "         ++ "internal library: "@@ -1028,13 +1026,18 @@         checkCCFlags flags = check (any (`elem` flags) all_cLikeOptions)  checkCPPOptions :: PackageDescription -> [PackageCheck]-checkCPPOptions pkg =-  catMaybes [-    checkAlternatives "cpp-options" "include-dirs"-      [ (flag, dir) | flag@('-':'I':dir) <- all_cppOptions]+checkCPPOptions pkg = catMaybes+    [ checkAlternatives "cpp-options" "include-dirs"+      [ (flag, dir) | flag@('-':'I':dir) <- all_cppOptions ]     ]-  where all_cppOptions = [ opts | bi <- allBuildInfo pkg-                                , opts <- cppOptions bi ]+    +++    [ PackageBuildWarning $ "'cpp-options': " ++ opt ++ " is not portable C-preprocessor flag"+    | opt <- all_cppOptions+    -- "-I" is handled above, we allow only -DNEWSTUFF and -UOLDSTUFF+    , not $ any (`isPrefixOf` opt) ["-D", "-U", "-I" ]+    ]+  where+    all_cppOptions = [ opts | bi <- allBuildInfo pkg, opts <- cppOptions bi ]  checkAlternatives :: String -> String -> [(String, String)]                   -> Maybe PackageCheck@@ -1589,8 +1592,8 @@      boundedAbove :: VersionRange -> Bool     boundedAbove vr = case asVersionIntervals vr of-      []        -> True -- this is the inconsistent version range.-      intervals -> case last intervals of+      []     -> True -- this is the inconsistent version range.+      (x:xs) -> case last (x:|xs) of         (_,   UpperBound _ _) -> True         (_, NoUpperBound    ) -> False @@ -2143,7 +2146,7 @@       Right (_:_)      -> Just noSplit      where         -- drop the '/' between the name and prefix:-        remainder = init h : rest+        remainder = safeInit h : rest    where     nameMax, prefixMax :: Int

@@ -65,7 +65,6 @@  import qualified Data.Map.Strict as Map.Strict import qualified Data.Map.Lazy   as Map-import Data.Set ( Set ) import qualified Data.Set as Set import Data.Tree ( Tree(Node) ) 

@@ -76,18 +76,18 @@     <*> blurFieldGrammar L.package packageIdentifierGrammar     <*> optionalFieldDefAla "license"       SpecLicense                L.licenseRaw (Left SPDX.NONE)     <*> licenseFilesGrammar-    <*> freeTextFieldDef    "copyright"                                L.copyright-    <*> freeTextFieldDef    "maintainer"                               L.maintainer-    <*> freeTextFieldDef    "author"                                   L.author-    <*> freeTextFieldDef    "stability"                                L.stability+    <*> freeTextFieldDefST  "copyright"                                L.copyright+    <*> freeTextFieldDefST  "maintainer"                               L.maintainer+    <*> freeTextFieldDefST  "author"                                   L.author+    <*> freeTextFieldDefST  "stability"                                L.stability     <*> monoidalFieldAla    "tested-with"   (alaList' FSep TestedWith) L.testedWith-    <*> freeTextFieldDef    "homepage"                                 L.homepage-    <*> freeTextFieldDef    "package-url"                              L.pkgUrl-    <*> freeTextFieldDef    "bug-reports"                              L.bugReports+    <*> freeTextFieldDefST  "homepage"                                 L.homepage+    <*> freeTextFieldDefST  "package-url"                              L.pkgUrl+    <*> freeTextFieldDefST   "bug-reports"                              L.bugReports     <*> pure [] -- source-repos are stanza-    <*> freeTextFieldDef    "synopsis"                                 L.synopsis-    <*> freeTextFieldDef    "description"                              L.description-    <*> freeTextFieldDef    "category"                                 L.category+    <*> 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

@@ -36,6 +36,7 @@ import Prelude ()  import Control.Applicative                           (Const (..))+import Control.DeepSeq                               (deepseq) import Control.Monad                                 (guard) import Control.Monad.State.Strict                    (StateT, execStateT) import Control.Monad.Trans.Class                     (lift)@@ -70,9 +71,7 @@ import Distribution.Types.UnqualComponentName        (UnqualComponentName, mkUnqualComponentName) import Distribution.Utils.Generic                    (breakMaybe, unfoldrM, validateUTF8) import Distribution.Verbosity                        (Verbosity)-import Distribution.Version-       (LowerBound (..), Version, asVersionIntervals, mkVersion, orLaterVersion, version0,-       versionNumbers)+import Distribution.Version                          (LowerBound (..), Version, asVersionIntervals, mkVersion, orLaterVersion, version0, versionNumbers)  import qualified Data.ByteString                                   as BS import qualified Data.ByteString.Char8                             as BS8@@ -200,7 +199,7 @@     gpd1 <- view stateGpd <$> execStateT (goSections specVer sectionFields) (SectionS gpd Map.empty)      checkForUndefinedFlags gpd1-    return gpd1+    gpd1 `deepseq` return gpd1   where     safeLast :: [a] -> Maybe a     safeLast = listToMaybe . reverse

@@ -126,17 +126,10 @@         thenDoc = go thenTree      ppIf (CondBranch c thenTree (Just elseTree)) =-          case (False, False) of- --       case (isEmpty thenDoc, isEmpty elseDoc) of-              (True,  True)  -> mempty-              (False, True)  -> [ ppIfCondition c thenDoc ]-              (True,  False) -> [ ppIfCondition (cNot c) elseDoc ]-              (False, False) -> [ ppIfCondition c thenDoc-                                , PrettySection () "else" [] elseDoc-                                ]-      where-        thenDoc = go thenTree-        elseDoc = go elseTree+      -- See #6193+      [ ppIfCondition c (go thenTree)+      , PrettySection () "else" [] (go elseTree)+      ]  ppCondLibrary :: CabalSpecVersion -> Maybe (CondTree ConfVar [Dependency] Library) -> [PrettyField ()] ppCondLibrary _ Nothing = mempty

@@ -1,19 +1,17 @@-{-# LANGUAGE RankNTypes #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes        #-} -- | -- -- @since 2.2.0.0 module Distribution.PackageDescription.Quirks (patchQuirks) where -import           Prelude ()-import           Distribution.Compat.Prelude-import           GHC.Fingerprint (Fingerprint (..), fingerprintData)-import           Foreign.Ptr (castPtr)-import           System.IO.Unsafe (unsafeDupablePerformIO)+import Distribution.Compat.Prelude+import Distribution.Utils.MD5+import GHC.Fingerprint             (Fingerprint (..))+import Prelude ()  import qualified Data.ByteString as BS-import qualified Data.ByteString.Unsafe as BS-import qualified Data.Map as Map+import qualified Data.Map        as Map  -- | Patch legacy @.cabal@ file contents to allow parsec parser to accept -- all of Hackage.@@ -30,13 +28,7 @@       where         output = f bs -md5 :: BS.ByteString -> Fingerprint-md5 bs = unsafeDupablePerformIO $ BS.unsafeUseAsCStringLen bs $ \(ptr, len) ->-    fingerprintData (castPtr ptr) len- -- | '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

@@ -42,7 +42,6 @@     ) where  import Data.Char                           (digitToInt, intToDigit)-import Data.Functor.Identity               (Identity (..)) import Data.List                           (transpose) import Distribution.CabalSpecVersion import Distribution.Compat.Prelude@@ -260,8 +259,8 @@ parsecLeadingCommaList p = do     c <- P.optional comma     case c of-        Nothing -> P.sepEndBy1 lp comma <|> pure []-        Just _  -> P.sepBy1 lp comma+        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"@@ -269,7 +268,7 @@ parsecOptCommaList :: CabalParsing m => m a -> m [a] parsecOptCommaList p = P.sepBy (p <* P.spaces) (P.optional comma)   where-    comma = P.char ',' *>  P.spaces+    comma = P.char ',' *> P.spaces  -- | Like 'parsecOptCommaList' but --@@ -290,7 +289,7 @@     c <- P.optional comma     case c of         Nothing -> sepEndBy1Start <|> pure []-        Just _  -> P.sepBy1 lp comma+        Just _  -> toList <$> P.sepByNonEmpty lp comma   where     lp = p <* P.spaces     comma = P.char ',' *> P.spaces P.<?> "comma"@@ -311,7 +310,7 @@ parsecMaybeQuoted p = parsecQuoted p <|> p  parsecUnqualComponentName :: CabalParsing m => m String-parsecUnqualComponentName = intercalate "-" <$> P.sepBy1 component (P.char '-')+parsecUnqualComponentName = intercalate "-" <$> toList <$> P.sepByNonEmpty component (P.char '-')   where     component :: CabalParsing m => m String     component = do@@ -380,7 +379,9 @@                                      nomore :: m ()                                      nomore = P.notFollowedBy anyd <|> toomuch -                                     (low, ex : high) = splitAt bd dps+                                     (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)

@@ -18,6 +18,10 @@     Sep (..),     -- ** Type     List,+    -- * Set+    alaSet,+    alaSet',+    Set',     -- * Version & License     SpecVersion (..),     TestedWith (..),@@ -33,16 +37,15 @@ import Distribution.Compat.Prelude import Prelude () -import Data.Functor.Identity         (Identity (..)) import Distribution.CabalSpecVersion import Distribution.Compiler         (CompilerFlavor) import Distribution.License          (License) import Distribution.Parsec import Distribution.Pretty-import Distribution.Version-       (LowerBound (..), Version, VersionRange, anyVersion, asVersionIntervals, mkVersion)+import Distribution.Version          (LowerBound (..), Version, VersionRange, anyVersion, asVersionIntervals, mkVersion) import Text.PrettyPrint              (Doc, comma, fsep, punctuate, vcat, (<+>)) +import qualified Data.Set                        as Set import qualified Distribution.Compat.CharParsing as P import qualified Distribution.SPDX               as SPDX @@ -61,13 +64,10 @@ -- | Paragraph fill list without commas. Displayed with 'fsep'. data NoCommaFSep = NoCommaFSep --- | Proxy, internal to this module.-data P sep = P- class    Sep sep  where-    prettySep :: P sep -> [Doc] -> Doc+    prettySep :: Proxy sep -> [Doc] -> Doc -    parseSep :: CabalParsing m => P sep -> m a -> m [a]+    parseSep :: CabalParsing m => Proxy sep -> m a -> m [a]  instance Sep CommaVCat where     prettySep  _ = vcat . punctuate comma@@ -116,10 +116,45 @@ 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 (P :: P sep) parsec+    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 (P :: P sep) . map (pretty . (pack :: a -> b)) . unpack+    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 constraint 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  -- | Haskell string or @[^ ,]+@ newtype Token = Token { getToken :: String }

@@ -12,7 +12,6 @@     Separator,     ) where -import Data.Functor.Identity         (Identity (..)) import Distribution.CabalSpecVersion import Distribution.Compat.Prelude import Prelude ()

@@ -44,6 +44,7 @@   deriving (Show, Read, Eq, Ord, Typeable, Data, Generic)  instance Binary License+instance Structured License  instance NFData License where     rnf NONE        = ()

@@ -12,9 +12,11 @@ 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@@ -74,6 +76,10 @@         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

@@ -60,6 +60,8 @@  instance Binary LicenseExpression instance Binary SimpleLicenseExpression+instance Structured SimpleLicenseExpression+instance Structured LicenseExpression  instance Pretty LicenseExpression where     pretty = go 0

@@ -15,9 +15,11 @@ 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@@ -412,6 +414,10 @@         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

@@ -34,6 +34,7 @@ licenseDocumentRef = _lrDocument  instance Binary LicenseRef+instance Structured LicenseRef  instance NFData LicenseRef where     rnf (LicenseRef d l) = rnf d `seq` rnf l

@@ -524,9 +524,9 @@       ++ "but the package does not have a library."  sanityCheckHookedBuildInfo verbosity pkg_descr (_, hookExes)-    | not (null nonExistant)+    | exe1 : _ <- nonExistant     = die' verbosity $ "The buildinfo contains info for an executable called '"-      ++ prettyShow (head nonExistant) ++ "' but the package does not have a "+      ++ prettyShow exe1 ++ "' but the package does not have a "       ++ "executable with that name."   where     pkgExeNames  = nub (map exeName (executables pkg_descr))

@@ -30,6 +30,7 @@  import Prelude () import Distribution.Compat.Prelude+import Distribution.Utils.Generic  import Distribution.Types.ComponentLocalBuildInfo import Distribution.Types.ComponentRequestedSpec@@ -154,7 +155,9 @@    target <- readTargetInfos verbosity pkg_descr lbi args >>= \r -> case r of     -- This seems DEEPLY questionable.-    []       -> return (head (allTargetsInBuildOrder' pkg_descr lbi))+    []       -> case allTargetsInBuildOrder' pkg_descr lbi of+      (target:_) -> return target+      []         -> die' verbosity $ "Failed to determine target."     [target] -> return target     _        -> die' verbosity $ "The 'repl' command does not support multiple targets at once."   let componentsToBuild = neededTargetsInBuildOrder' pkg_descr lbi [nodeKey target]@@ -180,7 +183,7 @@          componentInitialBuildSteps distPref pkg_descr lbi clbi verbosity          buildComponent verbosity NoFlag                         pkg_descr lbi' suffixes comp clbi distPref-    | subtarget <- init componentsToBuild ]+    | subtarget <- safeInit componentsToBuild ]    -- REPL for target components   let clbi = targetCLBI target

@@ -109,9 +109,9 @@   ++ generateMacros "TOOL_" progname version   | prog <- progs   , isJust . programVersion $ prog-  , let progid       = programId prog ++ "-" ++ prettyShow version-        progname     = map fixchar (programId prog)-        Just version = programVersion prog+  , let progid   = programId prog ++ "-" ++ prettyShow version+        progname = map fixchar (programId prog)+        version  = fromMaybe version0 (programVersion prog)   ]  -- | Common implementation of 'generatePackageVersionMacros' and@@ -131,7 +131,11 @@     ]   ,"\n"]   where-    (major1:major2:minor:_) = map show (versionNumbers version ++ repeat 0)+    (major1,major2,minor) = case map show (versionNumbers version) of+        []        -> ("0", "0", "0")+        [x]       -> (x,   "0", "0")+        [x,y]     -> (x,   y,   "0")+        (x:y:z:_) -> (x,   y,   z)  -- | Generate the @CURRENT_COMPONENT_ID@ definition for the component ID --   of the current package.

@@ -58,6 +58,7 @@  import Control.Monad ( msum ) import Data.List ( stripPrefix, groupBy, partition )+import qualified Data.List.NonEmpty as NE import Data.Either ( partitionEithers ) import System.FilePath as FilePath          ( dropExtension, normalise, splitDirectories, joinPath, splitPath@@ -318,8 +319,9 @@    where     classifyMatchErrors errs-      | not (null expected) = let (things, got:_) = unzip expected in-                              BuildTargetExpected userTarget things got+      | Just expected' <- NE.nonEmpty expected+                            = let (things, got:|_) = NE.unzip expected' in+                              BuildTargetExpected userTarget (NE.toList things) got       | not (null nosuch)   = BuildTargetNoSuch   userTarget nosuch       | otherwise = error $ "resolveBuildTarget: internal error in matching"       where

@@ -103,6 +103,7 @@     deriving (Eq, Generic, Typeable, Show, Read)  instance Binary Compiler+instance Structured Compiler  showCompilerId :: Compiler -> String showCompilerId = prettyShow . compilerId@@ -171,9 +172,10 @@ data PackageDB = GlobalPackageDB                | UserPackageDB                | SpecificPackageDB FilePath-    deriving (Eq, Generic, Ord, Show, Read)+    deriving (Eq, Generic, Ord, Show, Read, Typeable)  instance Binary PackageDB+instance Structured PackageDB  -- | We typically get packages from several databases, and stack them -- together. This type lets us be explicit about that stacking. For example@@ -197,8 +199,9 @@ -- the top of the stack. -- registrationPackageDB :: PackageDBStack -> PackageDB-registrationPackageDB []  = error "internal error: empty package db set"-registrationPackageDB dbs = last dbs+registrationPackageDB dbs  = case safeLast dbs of+  Nothing -> error "internal error: empty package db set"+  Just p  -> p  -- | Make package paths absolute @@ -223,9 +226,10 @@ data OptimisationLevel = NoOptimisation                        | NormalOptimisation                        | MaximumOptimisation-    deriving (Bounded, Enum, Eq, Generic, Read, Show)+    deriving (Bounded, Enum, Eq, Generic, Read, Show, Typeable)  instance Binary OptimisationLevel+instance Structured OptimisationLevel  flagToOptimisationLevel :: Maybe String -> OptimisationLevel flagToOptimisationLevel Nothing  = NormalOptimisation@@ -250,9 +254,10 @@                     | MinimalDebugInfo                     | NormalDebugInfo                     | MaximalDebugInfo-    deriving (Bounded, Enum, Eq, Generic, Read, Show)+    deriving (Bounded, Enum, Eq, Generic, Read, Show, Typeable)  instance Binary DebugInfoLevel+instance Structured DebugInfoLevel  flagToDebugInfoLevel :: Maybe String -> DebugInfoLevel flagToDebugInfoLevel Nothing  = NormalDebugInfo@@ -405,9 +410,10 @@                      | ProfDetailToplevelFunctions                      | ProfDetailAllFunctions                      | ProfDetailOther String-    deriving (Eq, Generic, Read, Show)+    deriving (Eq, Generic, Read, Show, Typeable)  instance Binary ProfDetailLevel+instance Structured ProfDetailLevel  flagToProfDetailLevel :: String -> ProfDetailLevel flagToProfDetailLevel "" = ProfDetailDefault

@@ -54,7 +54,7 @@   , platformDefines,   ) where -import Prelude ()+import qualified Prelude (tail) import Distribution.Compat.Prelude  import Distribution.Compiler@@ -113,7 +113,8 @@ import Control.Exception     ( ErrorCall, Exception, evaluate, throw, throwIO, try ) import Control.Monad ( forM, forM_ )-import Distribution.Compat.Binary    ( decodeOrFailIO, encode )+import Data.List.NonEmpty            ( nonEmpty )+import Distribution.Utils.Structured ( structuredDecodeOrFailIO, structuredEncode ) import Distribution.Compat.Directory ( listDirectory ) import Data.ByteString.Lazy          ( ByteString ) import qualified Data.ByteString            as BS@@ -211,7 +212,7 @@               Right x -> x      let getStoredValue = do-          result <- decodeOrFailIO (BLC8.tail body)+          result <- structuredDecodeOrFailIO (BLC8.tail body)           case result of             Left _ -> throw ConfigStateFileNoParse             Right x -> return x@@ -256,7 +257,7 @@ writePersistBuildConfig distPref lbi = do     createDirectoryIfMissing False distPref     writeFileAtomic (localBuildInfoFile distPref) $-      BLC8.unlines [showHeader pkgId, encode lbi]+      BLC8.unlines [showHeader pkgId, structuredEncode lbi]   where     pkgId = localPackage lbi @@ -971,7 +972,7 @@            -- Reinterpret the "package name" as an unqualified component            -- name            = LSubLibName $ packageNameToUnqualComponentName depName-    -- Check whether a libray exists and is visible.+    -- Check whether a library exists and is visible.     -- We don't disambiguate between dependency on non-existent or private     -- library yet, so we just return a bool and later report a generic error.     visible lib = maybe@@ -1314,19 +1315,22 @@      -- It's an external package, normal situation     do_external_external =-        case PackageIndex.lookupDependency installedIndex dep_pkgname vr of-          []   -> Left (DependencyNotExists dep_pkgname)-          pkgs -> Right $ head $ snd $ last pkgs+        case pickLastIPI $ PackageIndex.lookupDependency installedIndex dep_pkgname vr of+          Nothing  -> Left (DependencyNotExists dep_pkgname)+          Just pkg -> Right pkg      -- It's an internal library, being looked up externally     do_external_internal       :: LibraryName -> Either FailedDependency InstalledPackageInfo     do_external_internal ln =-        case PackageIndex.lookupInternalDependency installedIndex+        case pickLastIPI $ PackageIndex.lookupInternalDependency installedIndex                 (packageName pkgid) vr ln of-          []   -> Left (DependencyMissingInternal dep_pkgname (packageName pkgid))-          pkgs -> Right $ head $ snd $ last pkgs+          Nothing  -> Left (DependencyMissingInternal dep_pkgname (packageName pkgid))+          Just pkg -> Right pkg +    pickLastIPI :: [(Version, [InstalledPackageInfo])] -> Maybe InstalledPackageInfo+    pickLastIPI pkgs = safeHead . snd . last =<< nonEmpty pkgs+ reportSelectedDependencies :: Verbosity                            -> [ResolvedDependency] -> IO () reportSelectedDependencies verbosity deps =@@ -1772,7 +1776,7 @@         findOffendingHdr =             ifBuildsWith allHeaders ccArgs                          (return Nothing)-                         (go . tail . inits $ allHeaders)+                         (go . Prelude.tail . inits $ allHeaders) -- inits always contains at least []             where               go [] = return Nothing       -- cannot happen               go (hdrs:hdrsInits) =@@ -1781,9 +1785,10 @@                       -- If that works, try compiling too                       (ifBuildsWith hdrs ccArgs                         (go hdrsInits)-                        (return . Just . Right . last $ hdrs))-                      (return . Just . Left . last $ hdrs)+                        (return . fmap Right . safeLast $ hdrs))+                      (return . fmap Left . safeLast $ hdrs) +               cppArgs = "-E":commonCppArgs -- preprocess only               ccArgs  = "-c":commonCcArgs  -- don't try to link @@ -2003,7 +2008,7 @@     -- database to which the package is installed are relative to the     -- prefix of the package     depsPrefixRelative = do-        pkgr <- GHC.pkgRoot verbosity lbi (last (withPackageDB lbi))+        pkgr <- GHC.pkgRoot verbosity lbi (registrationPackageDB (withPackageDB lbi))         traverse_ (doCheck pkgr) ipkgs       where         doCheck pkgr ipkg

@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} -----------------------------------------------------------------------------@@ -51,9 +52,10 @@ -- Its monoid instance gives us the behaviour where it starts out as -- 'NoFlag' and later flags override earlier ones. ---data Flag a = Flag a | NoFlag deriving (Eq, Generic, Show, Read)+data Flag a = Flag a | NoFlag deriving (Eq, Generic, Show, Read, Typeable)  instance Binary a => Binary (Flag a)+instance Structured a => Structured (Flag a)  instance Functor Flag where   fmap f (Flag x) = Flag (f x)

@@ -138,11 +138,11 @@       (userMaybeSpecifyPath "ghc" hcPath conf0)   let implInfo = ghcVersionImplInfo ghcVersion -  -- Cabal currently supports ghc >= 7.0.1 && < 8.10-  unless (ghcVersion < mkVersion [8,10]) $+  -- Cabal currently supports ghc >= 7.0.1 && < 8.12+  unless (ghcVersion < mkVersion [8,12]) $     warn verbosity $          "Unknown/unsupported 'ghc' version detected "-      ++ "(Cabal " ++ prettyShow cabalVersion ++ " supports 'ghc' version < 8.10): "+      ++ "(Cabal " ++ prettyShow cabalVersion ++ " supports 'ghc' version < 8.12): "       ++ programPath ghcProg ++ " is version " ++ prettyShow ghcVersion    -- This is slightly tricky, we have to configure ghc first, then we use the@@ -317,7 +317,7 @@ getGhcInfo :: Verbosity -> ConfiguredProgram -> IO [(String, String)] getGhcInfo verbosity ghcProg = Internal.getGhcInfo verbosity implInfo ghcProg   where-    Just version = programVersion ghcProg+    version = fromMaybe (error "GHC.getGhcInfo: no ghc version") $ programVersion ghcProg     implInfo = ghcVersionImplInfo version  -- | Given a single package DB, return all installed packages.@@ -363,7 +363,7 @@   return $! mconcat indices    where-    Just ghcProg = lookupProgram ghcProgram progdb+    ghcProg = fromMaybe (error "GHC.toPackageIndex: no ghc program") $ lookupProgram ghcProgram progdb  getLibDir :: Verbosity -> LocalBuildInfo -> IO FilePath getLibDir verbosity lbi =@@ -396,7 +396,7 @@     platformAndVersion = Internal.ghcPlatformAndVersionString                            platform ghcVersion     packageConfFileName = "package.conf.d"-    Just ghcVersion = programVersion ghcProg+    ghcVersion = fromMaybe (error "GHC.getUserPackageDB: no ghc version") $ programVersion ghcProg  checkPackageDbEnvVar :: Verbosity -> IO () checkPackageDbEnvVar verbosity =@@ -475,7 +475,7 @@       if isFileStyle then return path                      else return (path </> "package.cache") -    Just ghcProg = lookupProgram ghcProgram progdb+    ghcProg = fromMaybe (error "GHC.toPackageIndex: no ghc program") $ lookupProgram ghcProgram progdb   -- -----------------------------------------------------------------------------@@ -1139,24 +1139,26 @@ -- https://github.com/haskell/cabal/pull/4539#discussion_r118981753. decodeMainIsArg :: String -> Maybe ModuleName decodeMainIsArg arg-  | not (null main_fn) && isLower (head main_fn)+  | headOf main_fn isLower                         -- The arg looked like "Foo.Bar.baz"   = Just (ModuleName.fromString main_mod)-  | isUpper (head arg)  -- The arg looked like "Foo" or "Foo.Bar"+  | headOf arg isUpper  -- The arg looked like "Foo" or "Foo.Bar"   = Just (ModuleName.fromString arg)   | otherwise           -- The arg looked like "baz"   = Nothing   where+    headOf :: String -> (Char -> Bool) -> Bool+    headOf str pred' = any pred' (safeHead str)+     (main_mod, main_fn) = splitLongestPrefix arg (== '.')      splitLongestPrefix :: String -> (Char -> Bool) -> (String,String)     splitLongestPrefix str pred'       | null r_pre = (str,           [])-      | otherwise  = (reverse (tail r_pre), reverse r_suf)-                           -- 'tail' drops the char satisfying 'pred'+      | otherwise  = (reverse (safeTail r_pre), reverse r_suf)+                           -- 'safeTail' drops the char satisfying 'pred'       where (r_suf, r_pre) = break pred' (reverse str) - -- | A collection of: --    * C input files --    * C++ input files@@ -2030,9 +2032,9 @@   , HcPkg.suppressFilesCheck   = v >= [6,6]   }   where-    v               = versionNumbers ver-    Just ghcPkgProg = lookupProgram ghcPkgProgram progdb-    Just ver        = programVersion ghcPkgProg+    v          = versionNumbers ver+    ghcPkgProg = fromMaybe (error "GHC.hcPkgInfo: no ghc program") $ lookupProgram ghcPkgProgram progdb+    ver        = fromMaybe (error "GHC.hcPkgInfo: no ghc version") $ programVersion ghcPkgProg  registerPackage   :: Verbosity@@ -2049,7 +2051,7 @@ pkgRoot verbosity lbi = pkgRoot'    where     pkgRoot' GlobalPackageDB =-      let Just ghcProg = lookupProgram ghcProgram (withPrograms lbi)+      let ghcProg = fromMaybe (error "GHC.pkgRoot: no ghc program") $ lookupProgram ghcProgram (withPrograms lbi)       in  fmap takeDirectory (getGlobalPackageDB verbosity ghcProg)     pkgRoot' UserPackageDB = do       appDir <- getAppUserDataDirectory "ghc"

@@ -241,7 +241,7 @@ getGhcInfo :: Verbosity -> ConfiguredProgram -> IO [(String, String)] getGhcInfo verbosity ghcjsProg = Internal.getGhcInfo verbosity implInfo ghcjsProg   where-    Just version = programVersion ghcjsProg+    version = fromMaybe (error "GHCJS.getGhcInfo: no version") $ programVersion ghcjsProg     implInfo = ghcVersionImplInfo version  -- | Given a single package DB, return all installed packages.@@ -275,7 +275,7 @@   return $! (mconcat indices)    where-    Just ghcjsProg = lookupProgram ghcjsProgram progdb+    ghcjsProg = fromMaybe (error "GHCJS.toPackageIndex no ghcjs program") $ lookupProgram ghcjsProgram progdb  getLibDir :: Verbosity -> LocalBuildInfo -> IO FilePath getLibDir verbosity lbi =@@ -307,7 +307,7 @@     platformAndVersion = Internal.ghcPlatformAndVersionString                            platform ghcjsVersion     packageConfFileName = "package.conf.d"-    Just ghcjsVersion = programVersion ghcjsProg+    ghcjsVersion = fromMaybe (error "GHCJS.getUserPackageDB: no version") $ programVersion ghcjsProg  checkPackageDbEnvVar :: Verbosity -> IO () checkPackageDbEnvVar verbosity =@@ -360,7 +360,7 @@       if isFileStyle then return path                      else return (path </> "package.cache") -    Just ghcjsProg = lookupProgram ghcjsProgram progdb+    ghcjsProg = fromMaybe (error "GHCJS.toPackageIndex no ghcjs program") $ lookupProgram ghcjsProgram progdb   toJSLibName :: String -> String@@ -926,21 +926,24 @@ -- https://github.com/haskell/cabal/pull/4539#discussion_r118981753. decodeMainIsArg :: String -> Maybe ModuleName decodeMainIsArg arg-  | not (null main_fn) && isLower (head main_fn)+  | headOf main_fn isLower                         -- The arg looked like "Foo.Bar.baz"   = Just (ModuleName.fromString main_mod)-  | isUpper (head arg)  -- The arg looked like "Foo" or "Foo.Bar"+  | headOf arg isUpper  -- The arg looked like "Foo" or "Foo.Bar"   = Just (ModuleName.fromString arg)   | otherwise           -- The arg looked like "baz"   = Nothing   where+    headOf :: String -> (Char -> Bool) -> Bool+    headOf str pred' = any pred' (safeHead str)+     (main_mod, main_fn) = splitLongestPrefix arg (== '.')      splitLongestPrefix :: String -> (Char -> Bool) -> (String,String)     splitLongestPrefix str pred'       | null r_pre = (str,           [])-      | otherwise  = (reverse (tail r_pre), reverse r_suf)-                           -- 'tail' drops the char satisfying 'pred'+      | otherwise  = (reverse (safeTail r_pre), reverse r_suf)+                           -- 'safeTail' drops the char satisfying 'pred'       where (r_suf, r_pre) = break pred' (reverse str)  @@ -1779,8 +1782,8 @@                                    }   where     v7_10 = mkVersion [7,10]-    Just ghcjsPkgProg = lookupProgram ghcjsPkgProgram progdb-    Just ver          = programVersion ghcjsPkgProg+    ghcjsPkgProg = fromMaybe (error "GHCJS.hcPkgInfo no ghcjs program") $ lookupProgram ghcjsPkgProgram progdb+    ver          = fromMaybe (error "GHCJS.hcPkgInfo no ghcjs version") $ programVersion ghcjsPkgProg  registerPackage   :: Verbosity@@ -1797,7 +1800,7 @@ pkgRoot verbosity lbi = pkgRoot'    where     pkgRoot' GlobalPackageDB =-      let Just ghcjsProg = lookupProgram ghcjsProgram (withPrograms lbi)+      let ghcjsProg = fromMaybe (error "GHCJS.pkgRoot: no ghcjs program") $ lookupProgram ghcjsProgram (withPrograms lbi)       in  fmap takeDirectory (getGlobalPackageDB verbosity ghcjsProg)     pkgRoot' UserPackageDB = do       appDir <- getAppUserDataDirectory "ghcjs"@@ -1827,4 +1830,4 @@   )   where     script = exe <.> "jsexe" </> "all" <.> "js"-    Just ghcjsProg = lookupProgram ghcjsProgram progdb+    ghcjsProg = fromMaybe (error "GHCJS.runCmd: no ghcjs program") $ lookupProgram ghcjsProgram progdb

@@ -37,6 +37,8 @@ import System.Directory (getDirectoryContents, doesDirectoryExist, doesFileExist) import System.FilePath (joinPath, splitExtensions, splitDirectories, takeFileName, (</>), (<.>)) +import qualified Data.List.NonEmpty as NE+ -- Note throughout that we use splitDirectories, not splitPath. On -- Posix, this makes no difference, but, because Windows accepts both -- slash and backslash as its path separators, if we left in the@@ -151,7 +153,7 @@     fileGlobMatchesSegments pat' segs   GlobFinal final -> case final of     FinalMatch Recursive multidot ext -> do-      let (candidateBase, candidateExts) = splitExtensions (last $ seg:segs)+      let (candidateBase, candidateExts) = splitExtensions (NE.last $ seg:|segs)       guard (not (null candidateBase))       checkExt multidot ext candidateExts     FinalMatch NonRecursive multidot ext -> do

@@ -66,6 +66,7 @@ import Distribution.Parsec (simpleParsec) import Distribution.Utils.NubList import Distribution.Version+import qualified Distribution.Utils.ShortText as ShortText  import Distribution.Verbosity import Language.Haskell.Extension@@ -352,20 +353,23 @@       ghcArgs = fromMaybe [] . lookup "ghc" . haddockProgramArgs $ flags  fromPackageDescription :: HaddockTarget -> PackageDescription -> HaddockArgs-fromPackageDescription haddockTarget pkg_descr =-      mempty { argInterfaceFile = Flag $ haddockName pkg_descr,-               argPackageName = Flag $ packageId $ pkg_descr,-               argOutputDir = Dir $-                   "doc" </> "html" </> haddockDirName haddockTarget pkg_descr,-               argPrologue = Flag $ if null desc then synopsis pkg_descr-                                    else desc,-               argTitle = Flag $ showPkg ++ subtitle-             }-      where-        desc = PD.description pkg_descr-        showPkg = prettyShow (packageId pkg_descr)-        subtitle | null (synopsis pkg_descr) = ""-                 | otherwise                 = ": " ++ synopsis pkg_descr+fromPackageDescription haddockTarget pkg_descr = mempty+    { argInterfaceFile = Flag $ haddockName pkg_descr+    , argPackageName = Flag $ packageId $ pkg_descr+    , argOutputDir = Dir $+        "doc" </> "html" </> haddockDirName haddockTarget pkg_descr+    , argPrologue = Flag $ ShortText.fromShortText $+        if ShortText.null desc+        then synopsis pkg_descr+        else desc+    , argTitle = Flag $ showPkg ++ subtitle+    }+  where+    desc = PD.description pkg_descr+    showPkg = prettyShow (packageId pkg_descr)+    subtitle+        | ShortText.null (synopsis pkg_descr) = ""+        | otherwise                           = ": " ++ ShortText.fromShortText (synopsis pkg_descr)  componentGhcOptions :: Verbosity -> LocalBuildInfo                  -> BuildInfo -> ComponentLocalBuildInfo -> FilePath@@ -521,7 +525,11 @@     haddockVersionMacro  = "-D__HADDOCK_VERSION__="                            ++ show (v1 * 1000 + v2 * 10 + v3)       where-        [v1, v2, v3] = take 3 $ versionNumbers haddockVersion ++ [0,0]+        (v1, v2, v3) = case versionNumbers haddockVersion of+            []        -> (0,0,0)+            [x]       -> (x,0,0)+            [x,y]     -> (x,y,0)+            (x:y:z:_) -> (x,y,z)  getGhcLibDir :: Verbosity -> LocalBuildInfo              -> IO HaddockArgs

@@ -9,6 +9,7 @@ import Data.Either (partitionEithers)  import qualified Data.Map as Map (empty)+import qualified Data.List.NonEmpty as NE  import Distribution.Simple.Program import Distribution.Simple.Compiler as Compiler@@ -91,15 +92,15 @@ hstoolVersion = findProgramVersion "--hspkg-version" id  numericVersion :: Verbosity -> FilePath -> IO (Maybe Version)-numericVersion = findProgramVersion "--compiler-version" (last . words)+numericVersion = findProgramVersion "--compiler-version" (fromMaybe "" . safeLast . words)  getCompilerVersion :: Verbosity -> ConfiguredProgram -> IO (String, Version) getCompilerVersion verbosity prog = do   output <- rawSystemStdout verbosity (programPath prog) ["--compiler-version"]   let     parts = words output-    name = concat $ init parts -- there shouldn't be any spaces in the name anyway-    versionStr = last parts+    name = concat $ safeInit parts -- there shouldn't be any spaces in the name anyway+    versionStr = fromMaybe "" $ safeLast parts   version <-     maybe (die' verbosity "haskell-suite: couldn't determine compiler version") return $       simpleParsec versionStr@@ -137,9 +138,9 @@    where     parsePackages str =-        case partitionEithers $ map parseInstalledPackageInfo (splitPkgs str) of+        case partitionEithers $ map (parseInstalledPackageInfo . toUTF8BS) (splitPkgs str) of             ([], ok)   -> Right [ pkg | (_, pkg) <- ok ]-            (msgss, _) -> Left (concat msgss)+            (msgss, _) -> Left (foldMap NE.toList msgss)      splitPkgs :: String -> [String]     splitPkgs = map unlines . splitWith ("---" ==) . lines@@ -216,8 +217,8 @@    runProgramInvocation verbosity $     (programInvocation hspkg-      ["update", packageDbOpt $ last packageDbs])-      { progInvokeInput = Just $ showInstalledPackageInfo installedPkgInfo }+      ["update", packageDbOpt $ registrationPackageDB packageDbs])+      { progInvokeInput = Just $ IODataText $ showInstalledPackageInfo installedPkgInfo }  initPackageDB :: Verbosity -> ProgramDb -> FilePath -> IO () initPackageDB verbosity progdb dbPath =

@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-}@@ -98,9 +99,10 @@         htmldir      :: dir,         haddockdir   :: dir,         sysconfdir   :: dir-    } deriving (Eq, Read, Show, Functor, Generic)+    } deriving (Eq, Read, Show, Functor, Generic, Typeable)  instance Binary dir => Binary (InstallDirs dir)+instance Structured dir => Structured (InstallDirs dir)  instance (Semigroup dir, Monoid dir) => Monoid (InstallDirs dir) where   mempty = gmempty@@ -352,9 +354,10 @@ -- substituted for to get a real 'FilePath'. -- newtype PathTemplate = PathTemplate [PathComponent]-  deriving (Eq, Ord, Generic)+  deriving (Eq, Ord, Generic, Typeable)  instance Binary PathTemplate+instance Structured PathTemplate  type PathTemplateEnv = [(PathTemplateVariable, PathTemplate)] 

@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} module Distribution.Simple.InstallDirs.Internal   ( PathComponent(..)@@ -10,9 +11,10 @@ data PathComponent =        Ordinary FilePath      | Variable PathTemplateVariable-     deriving (Eq, Ord, Generic)+     deriving (Eq, Ord, Generic, Typeable)  instance Binary PathComponent+instance Structured PathComponent  data PathTemplateVariable =        PrefixVar     -- ^ The @$prefix@ path variable@@ -39,9 +41,10 @@      | TestSuiteResultVar -- ^ The result of the test suite being run, eg                           -- @pass@, @fail@, or @error@.      | BenchmarkNameVar   -- ^ The name of the benchmark being run-  deriving (Eq, Ord, Generic)+  deriving (Eq, Ord, Generic, Typeable)  instance Binary PathTemplateVariable+instance Structured PathTemplateVariable  instance Show PathTemplateVariable where   show PrefixVar     = "prefix"

@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}@@ -112,6 +113,7 @@ import qualified Data.Array as Array import qualified Data.Graph as Graph import Data.List as List ( groupBy,  deleteBy, deleteFirstsBy )+import qualified Data.List.NonEmpty as NE import qualified Data.Tree  as Tree import Control.Monad import Distribution.Compat.Stack@@ -143,9 +145,10 @@   -- preserved. See #1463 for discussion.   packageIdIndex :: !(Map (PackageName, LibraryName) (Map Version [a])) -  } deriving (Eq, Generic, Show, Read)+  } deriving (Eq, Generic, Show, Read, Typeable)  instance Binary a => Binary (PackageIndex a)+instance Structured a => Structured (PackageIndex a)  -- | The default package index which contains 'InstalledPackageInfo'.  Normally -- use this.@@ -210,20 +213,20 @@ -- ones. -- fromList :: [IPI.InstalledPackageInfo] -> InstalledPackageIndex-fromList pkgs = mkPackageIndex pids pnames+fromList pkgs = mkPackageIndex pids ((fmap . fmap) toList pnames)   where     pids      = Map.fromList [ (installedUnitId pkg, pkg) | pkg <- pkgs ]     pnames    =       Map.fromList-        [ (liftM2 (,) packageName IPI.sourceLibName (head pkgsN), pvers)-        | pkgsN <- groupBy (equating  (liftM2 (,) packageName IPI.sourceLibName))+        [ (liftM2 (,) packageName IPI.sourceLibName (NE.head pkgsN), pvers)+        | pkgsN <- NE.groupBy (equating  (liftM2 (,) packageName IPI.sourceLibName))                  . sortBy  (comparing (liftM3 (,,) packageName IPI.sourceLibName packageVersion))                  $ pkgs         , let pvers =                 Map.fromList-                [ (packageVersion (head pkgsNV),-                   nubBy (equating installedUnitId) (reverse pkgsNV))-                | pkgsNV <- groupBy (equating packageVersion) pkgsN+                [ (packageVersion (NE.head pkgsNV),+                   NE.nubBy (equating installedUnitId) (NE.reverse pkgsNV))+                | pkgsNV <- NE.groupBy (equating packageVersion) pkgsN                 ]         ] 

@@ -269,7 +269,7 @@             let (srcStem, ext) = splitExtension psrcRelFile                 psrcFile = psrcLoc </> psrcRelFile                 pp = fromMaybe (error "Distribution.Simple.PreProcess: Just expected")-                               (lookup (tailNotNull ext) handlers)+                               (lookup (safeTail ext) handlers)             -- Preprocessing files for 'sdist' is different from preprocessing             -- for 'build'.  When preprocessing for sdist we preprocess to             -- avoid that the user has to have the preprocessors available.@@ -296,8 +296,6 @@    where     dirName = takeDirectory-    tailNotNull [] = []-    tailNotNull x  = tail x      -- FIXME: This is a somewhat nasty hack. GHC requires that hs-boot files     -- be in the same place as the hs files, so if we put the hs file in dist/@@ -727,8 +725,9 @@           pp $ buildDir lbi </> nm' </> nm' ++ "-tmp"       TestSuiteLibV09 _ _ ->           pp $ buildDir lbi </> stubName test </> stubName test ++ "-tmp"-      TestSuiteUnsupported tt -> die' verbosity $ "No support for preprocessing test "-                                    ++ "suite type " ++ prettyShow tt+      TestSuiteUnsupported tt ->+        die' verbosity $ "No support for preprocessing test suite type " +++                         prettyShow tt   CBench bm -> do     let nm' = unUnqualComponentName $ benchmarkName bm     case benchmarkInterface bm of

@@ -17,6 +17,7 @@  import Prelude () import Distribution.Compat.Prelude+import Distribution.Utils.Generic (safeTail, safeLast, safeInit)  import Data.List (mapAccumL) @@ -33,12 +34,10 @@ classify :: String -> Classified classify ('>':s) = BirdTrack s classify ('#':s) = case tokens s of-                     (line:file:_) | all isDigit line-                                  && length file >= 2-                                  && head file == '"'-                                  && last file == '"'+                     (line:file@('"':_:_):_) | all isDigit line+                                            && safeLast file == Just '"'                                 -- this shouldn't fail as we tested for 'all isDigit'-                                -> Line (fromMaybe (error $ "panic! read @Int " ++ show line) $ readMaybe line) (tail (init file)) -- TODO:eradicateNoParse+                                -> Line (fromMaybe (error $ "panic! read @Int " ++ show line) $ readMaybe line) (safeTail (safeInit file)) -- TODO:eradicateNoParse                      _          -> CPP s   where tokens = unfoldr $ \str -> case lex str of                                    (t@(_:_), str'):_ -> Just (t, str')

@@ -61,6 +61,7 @@     , programInvocation     , runProgramInvocation     , getProgramInvocationOutput+    , getProgramInvocationLBS      -- * The collection of unconfigured and configured programs     , builtinPrograms

@@ -1,6 +1,6 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE RankNTypes #-} {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts   #-}+{-# LANGUAGE RankNTypes         #-}  ----------------------------------------------------------------------------- -- |@@ -61,19 +61,21 @@    ) where -import Prelude () import Distribution.Compat.Prelude+import Prelude () -import Distribution.Simple.Program.Types-import Distribution.Simple.Program.Find+import Distribution.Pretty import Distribution.Simple.Program.Builtin+import Distribution.Simple.Program.Find+import Distribution.Simple.Program.Types import Distribution.Simple.Utils-import Distribution.Version-import Distribution.Pretty+import Distribution.Utils.Structured       (Structure (..), Structured (..)) import Distribution.Verbosity+import Distribution.Version  import Control.Monad (join)-import Data.Tuple (swap)+import Data.Tuple    (swap)+ import qualified Data.Map as Map  -- ------------------------------------------------------------@@ -150,6 +152,12 @@       progSearchPath  = searchpath,       configuredProgs = progs     }++instance Structured ProgramDb where+    structure p = Nominal (typeRep p) 0 "ProgramDb"+        [ structure (Proxy :: Proxy ProgramSearchPath)+        , structure (Proxy :: Proxy ConfiguredProgs)+        ]   -- | The 'Read'\/'Show' and 'Binary' instances do not preserve all the

@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-}@@ -67,9 +68,10 @@ data ProgramSearchPathEntry =          ProgramSearchPathDir FilePath  -- ^ A specific dir        | ProgramSearchPathDefault       -- ^ The system default-  deriving (Eq, Generic)+  deriving (Eq, Generic, Typeable)  instance Binary ProgramSearchPathEntry+instance Structured ProgramSearchPathEntry  defaultProgramSearchPath :: ProgramSearchPath defaultProgramSearchPath = [ProgramSearchPathDefault]

@@ -45,7 +45,6 @@ import Data.List (stripPrefix) import qualified Data.Map as Map import Data.Monoid (All(..), Any(..), Endo(..))-import Data.Set (Set) import qualified Data.Set as Set  normaliseGhcArgs :: Maybe Version -> PackageDescription -> [String] -> [String]@@ -56,7 +55,7 @@     supportedGHCVersions :: VersionRange     supportedGHCVersions = intersectVersionRanges         (orLaterVersion (mkVersion [8,0]))-        (earlierVersion (mkVersion [8,9]))+        (earlierVersion (mkVersion [8,11]))      from :: Monoid m => [Int] -> m -> m     from version flags@@ -193,6 +192,11 @@                 ]             , from [8,4] ["show-loaded-modules"]             , from [8,6] [ "ghci-leak-check", "no-it" ]+            , from [8,10]+                [ "defer-diagnostics"      -- affects printing of diagnostics+                , "keep-going"             -- try harder, the build will still fail if it's erroneous+                , "print-axiom-incomps"    -- print more debug info for closed type families+                ]             ]       , flagIn . invertibleFlagSet "-d" $ [ "ppr-case-as-let", "ppr-ticks" ]       , isOptIntFlag@@ -764,8 +768,10 @@   ---------------   -- Inputs -  , [ prettyShow modu | modu <- flags ghcOptInputModules ]+  -- 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+  , [ prettyShow modu | modu <- flags ghcOptInputModules ]    , concat [ [ "-o",    out] | out <- flag ghcOptOutputFile ]   , concat [ [ "-dyno", out] | out <- flag ghcOptOutputDynFile ]

@@ -1,5 +1,7 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE CPP               #-}+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE RankNTypes        #-}+{-# LANGUAGE OverloadedStrings #-}  ----------------------------------------------------------------------------- -- |@@ -42,29 +44,28 @@     listInvocation,   ) where -import Prelude () import Distribution.Compat.Prelude hiding (init)--import Data.Either (partitionEithers)+import Prelude () +import Distribution.Compat.Exception import Distribution.InstalledPackageInfo+import Distribution.Parsec+import Distribution.Pretty import Distribution.Simple.Compiler-import Distribution.Simple.Program.Types import Distribution.Simple.Program.Run+import Distribution.Simple.Program.Types import Distribution.Simple.Utils-import Distribution.Parsec-import Distribution.Pretty import Distribution.Types.ComponentId import Distribution.Types.PackageId import Distribution.Types.UnitId import Distribution.Verbosity-import Distribution.Compat.Exception -import Data.List-         ( stripPrefix )-import System.FilePath as FilePath-         ( (</>), (<.>)-         , splitPath, splitDirectories, joinPath, isPathSeparator )+import Data.List       (stripPrefix)+import System.FilePath as FilePath (isPathSeparator, joinPath, splitDirectories, splitPath, (<.>), (</>))++import qualified Data.ByteString       as BS+import qualified Data.ByteString.Lazy  as LBS+import qualified Data.List.NonEmpty    as NE import qualified System.FilePath.Posix as FilePath.Posix  -- | Information about the features and capabilities of an @hc-pkg@@@ -161,7 +162,7 @@     --   | registerMultiInstance registerOptions   , recacheMultiInstance hpi-  = do let pkgdb = last packagedbs+  = do let pkgdb = registrationPackageDB packagedbs        writeRegistrationFileDirectly verbosity hpi pkgdb pkgInfo        recache hpi verbosity pkgdb @@ -224,9 +225,9 @@ describe :: HcPkgInfo -> Verbosity -> PackageDBStack -> PackageId -> IO [InstalledPackageInfo] describe hpi verbosity packagedb pid = do -  output <- getProgramInvocationOutput verbosity+  output <- getProgramInvocationLBS verbosity               (describeInvocation hpi verbosity packagedb pid)-    `catchIO` \_ -> return ""+    `catchIO` \_ -> return mempty    case parsePackages output of     Left ok -> return ok@@ -249,7 +250,7 @@ dump :: HcPkgInfo -> Verbosity -> PackageDB -> IO [InstalledPackageInfo] dump hpi verbosity packagedb = do -  output <- getProgramInvocationOutput verbosity+  output <- getProgramInvocationLBS verbosity               (dumpInvocation hpi verbosity packagedb)     `catchIO` \e -> die' verbosity $ programId (hcPkgProgram hpi) ++ " dump failed: "                        ++ displayException e@@ -259,27 +260,51 @@     _       -> die' verbosity $ "failed to parse output of '"                   ++ programId (hcPkgProgram hpi) ++ " dump'" -parsePackages :: String -> Either [InstalledPackageInfo] [String]-parsePackages str =-    case partitionEithers $ map parseInstalledPackageInfo (splitPkgs str) of-        ([], ok)   -> Left [ setUnitId . maybe id mungePackagePaths (pkgRoot pkg) $ pkg | (_, pkg) <- ok ]-        (msgss, _) -> Right (concat msgss) ---TODO: this could be a lot faster. We're doing normaliseLineEndings twice--- and converting back and forth with lines/unlines.-splitPkgs :: String -> [String]-splitPkgs = checkEmpty . map unlines . splitWith ("---" ==) . lines+parsePackages :: LBS.ByteString -> Either [InstalledPackageInfo] [String]+parsePackages lbs0 =+    case traverse parseInstalledPackageInfo $ splitPkgs lbs0 of+        Right ok  -> Left [ setUnitId . maybe id mungePackagePaths (pkgRoot pkg) $ pkg | (_, pkg) <- ok ]+        Left msgs -> Right (NE.toList msgs)   where-    -- Handle the case of there being no packages at all.-    checkEmpty [s] | all isSpace s = []-    checkEmpty ss                  = ss+    splitPkgs :: LBS.ByteString -> [BS.ByteString]+    splitPkgs = checkEmpty . doSplit+      where+        -- Handle the case of there being no packages at all.+        checkEmpty [s] | BS.all isSpace8 s = []+        checkEmpty ss                      = ss -    splitWith :: (a -> Bool) -> [a] -> [[a]]-    splitWith p xs = ys : case zs of-                       []   -> []-                       _:ws -> splitWith p ws-      where (ys,zs) = break p xs+        isSpace8 :: Word8 -> Bool+        isSpace8 9  = True -- '\t'+        isSpace8 10 = True -- '\n'+        isSpace8 13 = True -- '\r'+        isSpace8 32 = True -- ' '+        isSpace8 _  = False +        doSplit :: LBS.ByteString -> [BS.ByteString]+        doSplit lbs = go (LBS.findIndices (\w -> w == 10 || w == 13) lbs)+          where+            go :: [Int64] -> [BS.ByteString]+            go []         = [ LBS.toStrict lbs ]+            go (idx:idxs) =+                let (pfx, sfx) = LBS.splitAt idx lbs+                in case foldr (<|>) Nothing $ map (`lbsStripPrefix` sfx) separators of+                    Just sfx' -> LBS.toStrict pfx : doSplit sfx'+                    Nothing   -> go idxs++            separators :: [LBS.ByteString]+            separators = ["\n---\n", "\r\n---\r\n", "\r---\r"]++lbsStripPrefix :: LBS.ByteString -> LBS.ByteString -> Maybe LBS.ByteString+#if MIN_VERSION_bytestring(0,10,8)+lbsStripPrefix pfx lbs = LBS.stripPrefix pfx lbs+#else+lbsStripPrefix pfx lbs+    | LBS.isPrefixOf pfx lbs = Just (LBS.drop (LBS.length pfx) lbs)+    | otherwise              = Nothing+#endif++ mungePackagePaths :: FilePath -> InstalledPackageInfo -> InstalledPackageInfo -- Perform path/URL variable substitution as per the Cabal ${pkgroot} spec -- (http://www.haskell.org/pipermail/libraries/2009-May/011772.html)@@ -375,7 +400,7 @@   -> ProgramInvocation registerInvocation hpi verbosity packagedbs pkgInfo registerOptions =     (programInvocation (hcPkgProgram hpi) (args "-")) {-      progInvokeInput         = Just (showInstalledPackageInfo pkgInfo),+      progInvokeInput         = Just $ IODataText $ showInstalledPackageInfo pkgInfo,       progInvokeInputEncoding = IOEncodingUTF8     }   where@@ -385,9 +410,7 @@       | otherwise                              = "register"      args file = [cmdname, file]-             ++ (if noPkgDbStack hpi-                   then [packageDbOpts hpi (last packagedbs)]-                   else packageDbStackOpts hpi packagedbs)+             ++ packageDbStackOpts hpi packagedbs              ++ [ "--enable-multi-instance"                 | registerMultiInstance registerOptions ]              ++ [ "--force-files"@@ -422,9 +445,7 @@ describeInvocation hpi verbosity packagedbs pkgid =   programInvocation (hcPkgProgram hpi) $        ["describe", prettyShow pkgid]-    ++ (if noPkgDbStack hpi-          then [packageDbOpts hpi (last packagedbs)]-          else packageDbStackOpts hpi packagedbs)+    ++ packageDbStackOpts hpi packagedbs     ++ verbosityOpts hpi verbosity  hideInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId@@ -459,19 +480,21 @@   packageDbStackOpts :: HcPkgInfo -> PackageDBStack -> [String]-packageDbStackOpts hpi dbstack = case dbstack of-  (GlobalPackageDB:UserPackageDB:dbs) -> "--global"-                                       : "--user"-                                       : map specific dbs-  (GlobalPackageDB:dbs)               -> "--global"-                                       : ("--no-user-" ++ packageDbFlag hpi)-                                       : map specific dbs-  _                                   -> ierror-  where-    specific (SpecificPackageDB db) = "--" ++ packageDbFlag hpi ++ "=" ++ db-    specific _ = ierror-    ierror :: a-    ierror     = error ("internal error: unexpected package db stack: " ++ show dbstack)+packageDbStackOpts hpi dbstack+  | noPkgDbStack hpi = [packageDbOpts hpi (registrationPackageDB dbstack)]+  | otherwise        = case dbstack of+    (GlobalPackageDB:UserPackageDB:dbs) -> "--global"+                                         : "--user"+                                         : map specific dbs+    (GlobalPackageDB:dbs)               -> "--global"+                                         : ("--no-user-" ++ packageDbFlag hpi)+                                         : map specific dbs+    _                                   -> ierror+    where+      specific (SpecificPackageDB db) = "--" ++ packageDbFlag hpi ++ "=" ++ db+      specific _ = ierror+      ierror :: a+      ierror     = error ("internal error: unexpected package db stack: " ++ show dbstack)  packageDbFlag :: HcPkgInfo -> String packageDbFlag hpi

@@ -13,6 +13,7 @@  import Prelude () import Distribution.Compat.Prelude+import Distribution.Utils.Generic(safeTail)  -- | Extract the version number from the output of 'strip --version'. --@@ -29,7 +30,7 @@       filterPar' :: Int -> [String] -> [String]       filterPar' _ []                   = []       filterPar' n (x:xs)-        | n >= 0 && "(" `isPrefixOf` x = filterPar' (n+1) ((tail x):xs)+        | n >= 0 && "(" `isPrefixOf` x = filterPar' (n+1) ((safeTail x):xs)         | n >  0 && ")" `isSuffixOf` x = filterPar' (n-1) xs         | n >  0                       = filterPar' n xs         | otherwise                    = x:filterPar' n xs

@@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE GADTs            #-}+{-# LANGUAGE RankNTypes       #-}  ----------------------------------------------------------------------------- -- |@@ -22,24 +23,27 @@      runProgramInvocation,     getProgramInvocationOutput,+    getProgramInvocationLBS,     getProgramInvocationOutputAndErrors,      getEffectiveEnvironment,   ) where -import Prelude () import Distribution.Compat.Prelude+import Prelude () +import Distribution.Compat.Environment import Distribution.Simple.Program.Types import Distribution.Simple.Utils+import Distribution.Utils.Generic import Distribution.Verbosity-import Distribution.Compat.Environment -import qualified Data.Map as Map+import System.Exit     (ExitCode (..), exitWith) import System.FilePath-import System.Exit-         ( ExitCode(..), exitWith ) +import qualified Data.ByteString.Lazy as LBS+import qualified Data.Map             as Map+ -- | Represents a specific invocation of a specific program. -- -- This is used as an intermediate type between deciding how to call a program@@ -54,17 +58,18 @@        -- Extra paths to add to PATH        progInvokePathEnv :: [FilePath],        progInvokeCwd   :: Maybe FilePath,-       progInvokeInput :: Maybe String,-       progInvokeInputEncoding  :: IOEncoding,+       progInvokeInput :: Maybe IOData,+       progInvokeInputEncoding  :: IOEncoding, -- ^ TODO: remove this, make user decide when constructing 'progInvokeInput'.        progInvokeOutputEncoding :: IOEncoding      }  data IOEncoding = IOEncodingText   -- locale mode text                 | IOEncodingUTF8   -- always utf8 -encodeToIOData :: IOEncoding -> String -> IOData-encodeToIOData IOEncodingText = IODataText-encodeToIOData IOEncodingUTF8 = IODataBinary . toUTF8LBS+encodeToIOData :: IOEncoding -> IOData -> IOData+encodeToIOData _              iod@(IODataBinary _) = iod+encodeToIOData IOEncodingText iod@(IODataText _)   = iod+encodeToIOData IOEncodingUTF8 (IODataText str)     = IODataBinary (toUTF8LBS str)  emptyProgramInvocation :: ProgramInvocation emptyProgramInvocation =@@ -155,32 +160,41 @@       die' verbosity $ "'" ++ progInvokePath inv ++ "' exited with an error:\n" ++ errors     return output +getProgramInvocationLBS :: Verbosity -> ProgramInvocation -> IO LBS.ByteString+getProgramInvocationLBS verbosity inv = do+    (output, errors, exitCode) <- getProgramInvocationIODataAndErrors verbosity inv IODataModeBinary+    when (exitCode /= ExitSuccess) $+      die' verbosity $ "'" ++ progInvokePath inv ++ "' exited with an error:\n" ++ errors+    return output  getProgramInvocationOutputAndErrors :: Verbosity -> ProgramInvocation                                     -> IO (String, String, ExitCode)-getProgramInvocationOutputAndErrors verbosity-  ProgramInvocation {-    progInvokePath  = path,-    progInvokeArgs  = args,-    progInvokeEnv   = envOverrides,-    progInvokePathEnv = extraPath,-    progInvokeCwd   = mcwd,-    progInvokeInput = minputStr,-    progInvokeOutputEncoding = encoding-  } = do-    let mode = case encoding of IOEncodingUTF8 -> IODataModeBinary-                                IOEncodingText -> IODataModeText--        decode (IODataBinary b) = normaliseLineEndings (fromUTF8LBS b)-        decode (IODataText   s) = s+getProgramInvocationOutputAndErrors verbosity inv = case progInvokeOutputEncoding inv of+    IOEncodingText -> do+        (output, errors, exitCode) <- getProgramInvocationIODataAndErrors verbosity inv IODataModeText+        return (output, errors, exitCode)+    IOEncodingUTF8 -> do+        (output', errors, exitCode) <- getProgramInvocationIODataAndErrors verbosity inv IODataModeBinary+        return (normaliseLineEndings (fromUTF8LBS output'), errors, exitCode) +getProgramInvocationIODataAndErrors+    :: KnownIODataMode mode => Verbosity -> ProgramInvocation -> IODataMode mode+    -> IO (mode, String, ExitCode)+getProgramInvocationIODataAndErrors+  verbosity+  ProgramInvocation+    { progInvokePath          = path+    , progInvokeArgs          = args+    , progInvokeEnv           = envOverrides+    , progInvokePathEnv       = extraPath+    , progInvokeCwd           = mcwd+    , progInvokeInput         = minputStr+    , progInvokeInputEncoding = encoding+    }+  mode = do     pathOverride <- getExtraPathEnv envOverrides extraPath     menv <- getEffectiveEnvironment (envOverrides ++ pathOverride)-    (output, errors, exitCode) <- rawSystemStdInOut verbosity-                                    path args-                                    mcwd menv-                                    input mode-    return (decode output, errors, exitCode)+    rawSystemStdInOut verbosity path args mcwd menv input mode   where     input = encodeToIOData encoding <$> minputStr @@ -243,13 +257,14 @@       chunkSize    = maxCommandLineSize - fixedArgSize     in case splitChunks chunkSize args of-        []     -> [ simple ]+        []  -> [ simple ] -        [c]    -> [ simple  `appendArgs` c ]+        [c] -> [ simple  `appendArgs` c ] -        (c:cs) -> [ initial `appendArgs` c ]-               ++ [ middle  `appendArgs` c'| c' <- init cs ]-               ++ [ final   `appendArgs` c'| let c' = last cs ]+        (c:c2:cs) | (xs, x) <- unsnocNE (c2:|cs) ->+             [ initial `appendArgs` c ]+          ++ [ middle  `appendArgs` c'| c' <- xs ]+          ++ [ final   `appendArgs` x ]    where     appendArgs :: ProgramInvocation -> [String] -> ProgramInvocation

@@ -1,3 +1,4 @@+{-# LANGUAGE GADTs #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Simple.Program.Script@@ -20,6 +21,7 @@ import Distribution.Compat.Prelude  import Distribution.Simple.Program.Run+import Distribution.Simple.Utils import Distribution.System  -- | Generate a system script, either POSIX shell script or Windows batch file@@ -45,8 +47,8 @@        ++ concatMap setEnv envExtra        ++ [ "cd " ++ quote cwd | cwd <- maybeToList mcwd ]        ++ [ (case minput of-              Nothing    -> ""-              Just input -> "echo " ++ quote input ++ " | ")+              Nothing     -> ""+              Just input -> "echo " ++ quote (iodataToText input) ++ " | ")          ++ unwords (map quote $ path : args) ++ " \"$@\""]    where@@ -60,7 +62,11 @@     escape ('\'':cs) = "'\\''" ++ escape cs     escape (c   :cs) = c        : escape cs +iodataToText :: IOData -> String+iodataToText (IODataText str)   = str+iodataToText (IODataBinary lbs) = fromUTF8LBS lbs + -- | Generate a Windows batch file that invokes a program. -- invocationAsBatchFile :: ProgramInvocation -> String@@ -81,7 +87,7 @@              Just input ->                 [ "(" ]-             ++ [ "echo " ++ escape line | line <- lines input ]+             ++ [ "echo " ++ escape line | line <- lines $ iodataToText input ]              ++ [ ") | "                ++ "\"" ++ path ++ "\""                ++ concatMap (\arg -> ' ':quote arg) args ]

@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-}@@ -133,6 +134,7 @@   deriving (Eq, Generic, Read, Show, Typeable)  instance Binary ConfiguredProgram+instance Structured ConfiguredProgram  -- | Where a program was found. Also tells us whether it's specified by user or -- not.  This includes not just the path, but the program as well.@@ -142,9 +144,10 @@       -- eg. --ghc-path=\/usr\/bin\/ghc-6.6     | FoundOnSystem { locationPath :: FilePath }       -- ^The program was found automatically.-      deriving (Eq, Generic, Read, Show)+      deriving (Eq, Generic, Read, Show, Typeable)  instance Binary ProgramLocation+instance Structured ProgramLocation  -- | The full path of a configured program. programPath :: ConfiguredProgram -> FilePath

@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-}@@ -57,7 +58,8 @@   defaultBenchmarkFlags, benchmarkCommand,   CopyDest(..),   configureArgs, configureOptions, configureCCompiler, configureLinker,-  buildOptions, haddockOptions, installDirsOptions, testOptions',+  buildOptions, haddockOptions, installDirsOptions,+  testOptions', benchmarkOptions',   programDbOptions, programDbPaths',   programFlagsDescription,   replOptions,@@ -126,7 +128,7 @@ data GlobalFlags = GlobalFlags {     globalVersion        :: Flag Bool,     globalNumericVersion :: Flag Bool-  } deriving (Generic)+  } deriving (Generic, Typeable)  defaultGlobalFlags :: GlobalFlags defaultGlobalFlags  = GlobalFlags {@@ -282,9 +284,10 @@       -- tools (like cabal-install) so they can add multiple-public-libraries       -- compatibility to older ghcs by checking visibility externally.   }-  deriving (Generic, Read, Show)+  deriving (Generic, Read, Show, Typeable)  instance Binary ConfigFlags+instance Structured ConfigFlags  -- | More convenient version of 'configPrograms'. Results in an -- 'error' if internal invariant is violated.@@ -1034,7 +1037,7 @@     sDistListSources :: Flag FilePath,     sDistVerbosity   :: Flag Verbosity   }-  deriving (Show, Generic)+  deriving (Show, Generic, Typeable)  defaultSDistFlags :: SDistFlags defaultSDistFlags = SDistFlags {@@ -1107,7 +1110,7 @@     regArgs        :: [String],     regCabalFilePath :: Flag FilePath   }-  deriving (Show, Generic)+  deriving (Show, Generic, Typeable)  defaultRegisterFlags :: RegisterFlags defaultRegisterFlags = RegisterFlags {@@ -1221,7 +1224,7 @@     hscolourVerbosity   :: Flag Verbosity,     hscolourCabalFilePath :: Flag FilePath     }-  deriving (Show, Generic)+  deriving (Show, Generic, Typeable)  emptyHscolourFlags :: HscolourFlags emptyHscolourFlags = mempty@@ -1314,7 +1317,7 @@     doctestDistPref     :: Flag FilePath,     doctestVerbosity    :: Flag Verbosity   }-   deriving (Show, Generic)+   deriving (Show, Generic, Typeable)  defaultDoctestFlags :: DoctestFlags defaultDoctestFlags = DoctestFlags {@@ -1382,9 +1385,10 @@ --    from documentation tarballs, and we might also want to use different --    flags than for development builds, so in this case we store the generated --    documentation in @<dist>/doc/html/<package id>-docs@.-data HaddockTarget = ForHackage | ForDevelopment deriving (Eq, Show, Generic)+data HaddockTarget = ForHackage | ForDevelopment deriving (Eq, Show, Generic, Typeable)  instance Binary HaddockTarget+instance Structured HaddockTarget  instance Pretty HaddockTarget where     pretty ForHackage     = Disp.text "for-hackage"@@ -1417,7 +1421,7 @@     haddockCabalFilePath :: Flag FilePath,     haddockArgs         :: [String]   }-  deriving (Show, Generic)+  deriving (Show, Generic, Typeable)  defaultHaddockFlags :: HaddockFlags defaultHaddockFlags  = HaddockFlags {@@ -1590,7 +1594,7 @@     cleanVerbosity :: Flag Verbosity,     cleanCabalFilePath :: Flag FilePath   }-  deriving (Show, Generic)+  deriving (Show, Generic, Typeable)  defaultCleanFlags :: CleanFlags defaultCleanFlags  = CleanFlags {@@ -1648,7 +1652,7 @@     buildArgs :: [String],     buildCabalFilePath :: Flag FilePath   }-  deriving (Read, Show, Generic)+  deriving (Read, Show, Generic, Typeable)  defaultBuildFlags :: BuildFlags defaultBuildFlags  = BuildFlags {@@ -1738,7 +1742,7 @@     replReload      :: Flag Bool,     replReplOptions :: [String]   }-  deriving (Show, Generic)+  deriving (Show, Generic, Typeable)  defaultReplFlags :: ReplFlags defaultReplFlags  = ReplFlags {@@ -1837,9 +1841,10 @@ -- ------------------------------------------------------------  data TestShowDetails = Never | Failures | Always | Streaming | Direct-    deriving (Eq, Ord, Enum, Bounded, Generic, Show)+    deriving (Eq, Ord, Enum, Bounded, Generic, Show, Typeable)  instance Binary TestShowDetails+instance Structured TestShowDetails  knownTestShowDetails :: [TestShowDetails] knownTestShowDetails = [minBound..maxBound]@@ -1875,7 +1880,7 @@     testFailWhenNoTestSuites :: Flag Bool,     -- TODO: think about if/how options are passed to test exes     testOptions     :: [PathTemplate]-  } deriving (Generic)+  } deriving (Generic, Typeable)  defaultTestFlags :: TestFlags defaultTestFlags  = TestFlags {@@ -1995,7 +2000,7 @@     benchmarkDistPref  :: Flag FilePath,     benchmarkVerbosity :: Flag Verbosity,     benchmarkOptions   :: [PathTemplate]-  } deriving (Generic)+  } deriving (Generic, Typeable)  defaultBenchmarkFlags :: BenchmarkFlags defaultBenchmarkFlags  = BenchmarkFlags {@@ -2026,30 +2031,33 @@       , "BENCHCOMPONENTS [FLAGS]"       ]   , commandDefaultFlags = defaultBenchmarkFlags-  , commandOptions = \showOrParseArgs ->-      [ optionVerbosity benchmarkVerbosity-        (\v flags -> flags { benchmarkVerbosity = v })-      , optionDistPref-            benchmarkDistPref (\d flags -> flags { benchmarkDistPref = d })-            showOrParseArgs-      , option [] ["benchmark-options"]-            ("give extra options to benchmark executables "-             ++ "(name templates can use $pkgid, $compiler, "-             ++ "$os, $arch, $benchmark)")-            benchmarkOptions (\v flags -> flags { benchmarkOptions = v })-            (reqArg' "TEMPLATES" (map toPathTemplate . splitArgs)-                (const []))-      , option [] ["benchmark-option"]-            ("give extra option to benchmark executables "-             ++ "(no need to quote options containing spaces, "-             ++ "name template can use $pkgid, $compiler, "-             ++ "$os, $arch, $benchmark)")-            benchmarkOptions (\v flags -> flags { benchmarkOptions = v })-            (reqArg' "TEMPLATE" (\x -> [toPathTemplate x])-                (map fromPathTemplate))-      ]+  , commandOptions = benchmarkOptions'   } +benchmarkOptions' :: ShowOrParseArgs -> [OptionField BenchmarkFlags]+benchmarkOptions' showOrParseArgs =+  [ optionVerbosity benchmarkVerbosity+    (\v flags -> flags { benchmarkVerbosity = v })+  , optionDistPref+        benchmarkDistPref (\d flags -> flags { benchmarkDistPref = d })+        showOrParseArgs+  , option [] ["benchmark-options"]+        ("give extra options to benchmark executables "+         ++ "(name templates can use $pkgid, $compiler, "+         ++ "$os, $arch, $benchmark)")+        benchmarkOptions (\v flags -> flags { benchmarkOptions = v })+        (reqArg' "TEMPLATES" (map toPathTemplate . splitArgs)+            (const []))+  , option [] ["benchmark-option"]+        ("give extra option to benchmark executables "+         ++ "(no need to quote options containing spaces, "+         ++ "name template can use $pkgid, $compiler, "+         ++ "$os, $arch, $benchmark)")+        benchmarkOptions (\v flags -> flags { benchmarkOptions = v })+        (reqArg' "TEMPLATE" (\x -> [toPathTemplate x])+            (map fromPathTemplate))+  ]+ emptyBenchmarkFlags :: BenchmarkFlags emptyBenchmarkFlags = mempty @@ -2225,7 +2233,7 @@ data ShowBuildInfoFlags = ShowBuildInfoFlags   { buildInfoBuildFlags :: BuildFlags   , buildInfoOutputFile :: Maybe FilePath-  } deriving Show+  } deriving (Show, Typeable)  defaultShowBuildFlags  :: ShowBuildInfoFlags defaultShowBuildFlags =

@@ -56,6 +56,9 @@  module Distribution.Simple.ShowBuildInfo (mkBuildInfo) where +import Distribution.Compat.Prelude+import Prelude ()+ import qualified Distribution.Simple.GHC   as GHC import qualified Distribution.Simple.Program.GHC as GHC @@ -122,7 +125,7 @@       ]       where         bi = componentBuildInfo comp-        Just comp = lookupComponent pkg_descr name+        comp = fromMaybe (error $ "mkBuildInfo: no component " ++ prettyShow name) $ lookupComponent pkg_descr name         compType = case comp of           CLib _   -> "lib"           CExe _   -> "exe"

@@ -207,7 +207,9 @@ writeSimpleTestStub t dir = do     createDirectoryIfMissing True dir     let filename = dir </> stubFilePath t-        PD.TestSuiteLibV09 _ m = PD.testInterface t+        m = case PD.testInterface t of+            PD.TestSuiteLibV09 _  m' -> m'+            _                        -> error "writeSimpleTestStub: invalid TestSuite passed"     writeFile filename $ simpleTestStub m  -- | Source code for library test suite stub executable

@@ -143,7 +143,7 @@   where     addTriple (p1, f1, e1) (p2, f2, e2) = (p1 + p2, f1 + f2, e1 + e2) --- | Print a summary of a single test case's result to the console, supressing+-- | Print a summary of a single test case's result to the console, suppressing -- output for certain verbosity or test filter levels. summarizeTest :: Verbosity -> TestShowDetails -> TestLogs -> IO () summarizeTest _ _ (GroupLogs {}) = return ()

@@ -24,7 +24,6 @@  import Prelude () import Distribution.Compat.Prelude-import Data.Foldable (toList)  import Distribution.InstalledPackageInfo import Distribution.Package hiding (installedUnitId)@@ -117,9 +116,11 @@ getGlobalPackageDir verbosity progdb = do     output <- getDbProgramOutput verbosity                 uhcProgram progdb ["--meta-pkgdir-system"]-    -- call to "lines" necessary, because pkgdir contains an extra newline at the end-    let [pkgdir] = lines output+    -- we need to trim because pkgdir contains an extra newline at the end+    let pkgdir = trimEnd output     return pkgdir+  where+    trimEnd = reverse . dropWhile isSpace . reverse  getUserPackageDir :: NoCallStackIO FilePath getUserPackageDir = do@@ -278,7 +279,7 @@   -> InstalledPackageInfo   -> IO () registerPackage verbosity comp progdb packageDbs installedPkgInfo = do-    dbdir <- case last packageDbs of+    dbdir <- case registrationPackageDB packageDbs of       GlobalPackageDB       -> getGlobalPackageDir verbosity progdb       UserPackageDB         -> getUserPackageDir       SpecificPackageDB dir -> return dir

@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-}@@ -60,7 +61,8 @@         -- "Distribution.Utils.IOData" for convience as they're         -- exposed in the API of 'rawSystemStdInOut'         IOData(..),-        IODataMode(..),+        KnownIODataMode (..),+        IODataMode (..),          -- * copying files         createDirectoryIfMissingVerbose,@@ -150,7 +152,10 @@         ordNub,         ordNubBy,         ordNubRight,+        safeHead,         safeTail,+        safeLast,+        safeInit,         unintersperse,         wrapText,         wrapLine,@@ -169,11 +174,12 @@ import Distribution.Compat.Prelude  import Distribution.Utils.Generic-import Distribution.Utils.IOData (IOData(..), IODataMode(..))+import Distribution.Utils.IOData (IOData(..), IODataMode (..), KnownIODataMode (..)) import qualified Distribution.Utils.IOData as IOData import Distribution.ModuleName as ModuleName import Distribution.System import Distribution.Version+import Distribution.Compat.Async import Distribution.Compat.CopyFile import Distribution.Compat.Internal.TempFile import Distribution.Compat.Exception@@ -199,8 +205,6 @@ import Distribution.Pretty import Distribution.Parsec -import Control.Concurrent.MVar-    ( newEmptyMVar, putMVar, takeMVar ) import Data.Typeable     ( cast ) import qualified Data.ByteString.Lazy as BS@@ -225,9 +229,9 @@     ( unsafeInterleaveIO ) import qualified Control.Exception as Exception +import Foreign.C.Error (Errno (..), ePIPE) import Data.Time.Clock.POSIX (getPOSIXTime, POSIXTime)-import Control.Exception (IOException, evaluate, throwIO)-import Control.Concurrent (forkIO)+import Control.Exception (IOException, evaluate, throwIO, fromException) import Numeric (showFFloat) import qualified System.Process as Process          ( CreateProcess(..), StdStream(..), proc)@@ -235,6 +239,8 @@          ( ProcessHandle, createProcess, rawSystem, runInteractiveProcess          , showCommandForUser, waitForProcess) +import qualified GHC.IO.Exception as GHC+ import qualified Text.PrettyPrint as Disp  -- We only get our own version number when we're building with ourselves@@ -244,7 +250,7 @@ #elif defined(CABAL_VERSION) cabalVersion = mkVersion [CABAL_VERSION] #else-cabalVersion = mkVersion [1,9999]  --used when bootstrapping+cabalVersion = mkVersion [3,0]  --used when bootstrapping #endif  -- ----------------------------------------------------------------------------@@ -792,11 +798,10 @@ -- -- The output is assumed to be text in the locale encoding. ---rawSystemStdout :: Verbosity -> FilePath -> [String] -> IO String+rawSystemStdout :: forall mode. KnownIODataMode mode => Verbosity -> FilePath -> [String] -> IO mode  rawSystemStdout verbosity path args = withFrozenCallStack $ do-  (IODataText output, errors, exitCode) <- rawSystemStdInOut verbosity path args-                                                  Nothing Nothing-                                                  Nothing IODataModeText+  (output, errors, exitCode) <- rawSystemStdInOut verbosity path args+    Nothing Nothing Nothing (IOData.iodataMode :: IODataMode mode)   when (exitCode /= ExitSuccess) $     die' verbosity errors   return output@@ -805,15 +810,16 @@ -- also supply some input. Also provides control over whether the binary/text -- mode of the input and output. ---rawSystemStdInOut :: Verbosity+rawSystemStdInOut :: KnownIODataMode mode+                  => Verbosity                   -> FilePath                 -- ^ Program location                   -> [String]                 -- ^ Arguments                   -> Maybe FilePath           -- ^ New working dir or inherit                   -> Maybe [(String, String)] -- ^ New environment or inherit                   -> Maybe IOData             -- ^ input text and binary mode-                  -> IODataMode               -- ^ output in binary mode-                  -> IO (IOData, String, ExitCode) -- ^ output, errors, exit-rawSystemStdInOut verbosity path args mcwd menv input outputMode = withFrozenCallStack $ do+                  -> IODataMode mode          -- ^ iodata mode, acts as proxy+                  -> IO (mode, String, ExitCode) -- ^ output, errors, exit+rawSystemStdInOut verbosity path args mcwd menv input _ = withFrozenCallStack $ do   printRawCommandAndArgs verbosity path args    Exception.bracket@@ -828,53 +834,49 @@       -- fork off a couple threads to pull on the stderr and stdout       -- so if the process writes to stderr we do not block. -      err <- hGetContents errh--      out <- IOData.hGetContents outh outputMode+      withAsyncNF (hGetContents errh) $ \errA -> withAsyncNF (IOData.hGetIODataContents outh) $ \outA -> do+        -- push all the input, if any+        ignoreSigPipe $ case input of+          Nothing        -> hClose inh+          Just inputData -> IOData.hPutContents inh inputData -      mv <- newEmptyMVar-      let force str = do-            mberr <- Exception.try (evaluate (rnf str) >> return ())-            putMVar mv (mberr :: Either IOError ())-      _ <- forkIO $ force out-      _ <- forkIO $ force err+        -- wait for both to finish+        mberr1 <- waitCatch outA+        mberr2 <- waitCatch errA -      -- push all the input, if any-      case input of-        Nothing -> return ()-        Just inputData -> do-          -- input mode depends on what the caller wants-          IOData.hPutContents inh inputData-          --TODO: this probably fails if the process refuses to consume-          -- or if it closes stdin (eg if it exits)+        -- wait for the program to terminate+        exitcode <- waitForProcess pid -      -- wait for both to finish, in either order-      mberr1 <- takeMVar mv-      mberr2 <- takeMVar mv+        -- get the stderr, so it can be added to error message+        err <- reportOutputIOError mberr2 -      -- wait for the program to terminate-      exitcode <- waitForProcess pid-      unless (exitcode == ExitSuccess) $-        debug verbosity $ path ++ " returned " ++ show exitcode-                       ++ if null err then "" else-                          " with error message:\n" ++ err-                       ++ case input of-                            Nothing       -> ""-                            Just d | IOData.null d -> ""-                            Just (IODataText inp) -> "\nstdin input:\n" ++ inp-                            Just (IODataBinary inp) -> "\nstdin input (binary):\n" ++ show inp+        unless (exitcode == ExitSuccess) $+          debug verbosity $ path ++ " returned " ++ show exitcode+                         ++ if null err then "" else+                            " with error message:\n" ++ err+                         ++ case input of+                              Nothing       -> ""+                              Just d | IOData.null d  -> ""+                              Just (IODataText inp)   -> "\nstdin input:\n" ++ inp+                              Just (IODataBinary inp) -> "\nstdin input (binary):\n" ++ show inp -      -- Check if we we hit an exception while consuming the output-      -- (e.g. a text decoding error)-      reportOutputIOError mberr1-      reportOutputIOError mberr2+        -- Check if we we hit an exception while consuming the output+        -- (e.g. a text decoding error)+        out <- reportOutputIOError mberr1 -      return (out, err, exitcode)+        return (out, err, exitcode)   where-    reportOutputIOError :: Either IOError () -> NoCallStackIO ()-    reportOutputIOError =-      either (\e -> throwIO (ioeSetFileName e ("output of " ++ path)))-             return+    reportOutputIOError :: Either Exception.SomeException a -> NoCallStackIO a+    reportOutputIOError (Right x) = return x+    reportOutputIOError (Left exc) = case fromException exc of+        Just ioe -> throwIO (ioeSetFileName ioe ("output of " ++ path))+        Nothing  -> throwIO exc++    ignoreSigPipe :: NoCallStackIO () -> NoCallStackIO ()+    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  -- | 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

@@ -101,7 +101,7 @@   deriving (Eq, Generic, Ord, Show, Read, Typeable, Data)  instance Binary OS-+instance Structured OS instance NFData OS where rnf = genericRnf  knownOSs :: [OS]@@ -169,7 +169,7 @@   deriving (Eq, Generic, Ord, Show, Read, Typeable, Data)  instance Binary Arch-+instance Structured Arch instance NFData Arch where rnf = genericRnf  knownArches :: [Arch]@@ -217,7 +217,7 @@   deriving (Eq, Generic, Ord, Show, Read, Typeable, Data)  instance Binary Platform-+instance Structured Platform instance NFData Platform where rnf = genericRnf  instance Pretty Platform where

@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} module Distribution.Types.AbiDependency where @@ -25,7 +26,7 @@         depUnitId  :: Package.UnitId,         depAbiHash :: Package.AbiHash     }-  deriving (Eq, Generic, Read, Show)+  deriving (Eq, Generic, Read, Show, Typeable)  instance Pretty AbiDependency where     pretty (AbiDependency uid abi) =@@ -39,4 +40,5 @@         return (AbiDependency uid abi)  instance Binary AbiDependency+instance Structured AbiDependency instance NFData AbiDependency where rnf = genericRnf

@@ -25,7 +25,7 @@ -- -- @since 2.0.0.2 newtype AbiHash = AbiHash ShortText-    deriving (Eq, Show, Read, Generic)+    deriving (Eq, Show, Read, Generic, Typeable)  -- | Construct a 'AbiHash' from a 'String' --@@ -51,7 +51,7 @@     fromString = mkAbiHash  instance Binary AbiHash-+instance Structured AbiHash instance NFData AbiHash where rnf = genericRnf  instance Pretty AbiHash where

@@ -31,7 +31,7 @@     deriving (Generic, Show, Read, Eq, Typeable, Data)  instance Binary Benchmark-+instance Structured Benchmark instance NFData Benchmark where rnf = genericRnf  instance L.HasBuildInfo Benchmark where

@@ -34,7 +34,7 @@    deriving (Eq, Generic, Read, Show, Typeable, Data)  instance Binary BenchmarkInterface-+instance Structured BenchmarkInterface instance NFData BenchmarkInterface where rnf = genericRnf  instance Monoid BenchmarkInterface where

@@ -23,7 +23,7 @@     deriving (Generic, Show, Read, Eq, Typeable, Data)  instance Binary BenchmarkType-+instance Structured BenchmarkType instance NFData BenchmarkType where rnf = genericRnf  knownBenchmarkTypes :: [BenchmarkType]

@@ -82,7 +82,7 @@                                        --   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.  Oherwise cabal would need to lear how to+                                       --              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<name>_<flavour> | flavour <- extraLibFlavours]. This@@ -109,7 +109,7 @@     deriving (Generic, Show, Read, Eq, Typeable, Data)  instance Binary BuildInfo-+instance Structured BuildInfo instance NFData BuildInfo where rnf = genericRnf  instance Monoid BuildInfo where

@@ -27,7 +27,7 @@                 deriving (Generic, Show, Read, Eq, Typeable, Data)  instance Binary BuildType-+instance Structured BuildType instance NFData BuildType where rnf = genericRnf  knownBuildTypes :: [BuildType]

@@ -56,6 +56,7 @@     fromString = mkComponentId  instance Binary ComponentId+instance Structured ComponentId  instance Pretty ComponentId where   pretty = text . unComponentId

@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE TypeFamilies #-} @@ -108,9 +109,10 @@     componentExeDeps :: [UnitId],     componentInternalDeps :: [UnitId]   }-  deriving (Generic, Read, Show)+  deriving (Generic, Read, Show, Typeable)  instance Binary ComponentLocalBuildInfo+instance Structured ComponentLocalBuildInfo  instance IsNode ComponentLocalBuildInfo where     type Key ComponentLocalBuildInfo = UnitId

@@ -28,6 +28,7 @@                    deriving (Eq, Generic, Ord, Read, Show, Typeable)  instance Binary ComponentName+instance Structured ComponentName  -- Build-target-ish syntax instance Pretty ComponentName where

@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} module Distribution.Types.ComponentRequestedSpec (     -- $buildable_vs_enabled_components@@ -66,8 +67,10 @@     = ComponentRequestedSpec { testsRequested      :: Bool                              , benchmarksRequested :: Bool }     | OneComponentRequestedSpec ComponentName-  deriving (Generic, Read, Show, Eq)+  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.

@@ -3,6 +3,7 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE ScopedTypeVariables #-}  module Distribution.Types.CondTree (     CondTree(..),@@ -63,7 +64,7 @@     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@@ -85,7 +86,7 @@     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

@@ -97,7 +97,7 @@   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.

@@ -0,0 +1,25 @@+{-# 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+             | Flag FlagName+             | Impl CompilerFlavor VersionRange+    deriving (Eq, Show, Typeable, Data, Generic)++instance Binary ConfVar+instance Structured ConfVar++instance NFData ConfVar where rnf = genericRnf

@@ -29,7 +29,6 @@ import Distribution.Types.UnqualComponentName  import Text.PrettyPrint ((<+>))-import Data.Set (Set) import qualified Data.Set as Set  -- | Describes a dependency on a source package (API)@@ -53,6 +52,7 @@ depLibraries (Dependency _ _ cs) = cs  instance Binary Dependency+instance Structured Dependency instance NFData Dependency where rnf = genericRnf  instance Pretty Dependency where

@@ -13,7 +13,6 @@ import Distribution.Types.LibraryName import Distribution.Version -import Data.Set (Set) import qualified Data.Map.Lazy as Map  -- | A map of dependencies.  Newtyped since the default monoid instance is not

@@ -27,6 +27,7 @@                      deriving (Generic, Read, Show, Eq, Typeable, Data)  instance Binary ExeDependency+instance Structured ExeDependency instance NFData ExeDependency where rnf = genericRnf  instance Pretty ExeDependency where

@@ -30,7 +30,7 @@     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

@@ -28,7 +28,7 @@         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'

@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} module Distribution.Types.ExposedModule where @@ -17,7 +18,7 @@        exposedName      :: ModuleName,        exposedReexport  :: Maybe OpenModule      }-  deriving (Eq, Generic, Read, Show)+  deriving (Eq, Generic, Read, Show, Typeable)  instance Pretty ExposedModule where     pretty (ExposedModule m reexport) =@@ -40,5 +41,5 @@         return (ExposedModule m reexport)  instance Binary ExposedModule-+instance Structured ExposedModule instance NFData ExposedModule where rnf = genericRnf

@@ -0,0 +1,249 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Distribution.Types.Flag (+    Flag(..),+    emptyFlag,+    FlagName,+    mkFlagName,+    unFlagName,+    FlagAssignment,+    mkFlagAssignment,+    unFlagAssignment,+    lookupFlagAssignment,+    insertFlagAssignment,+    diffFlagAssignment,+    findDuplicateFlagAssignments,+    nullFlagAssignment,+    showFlagValue,+    dispFlagAssignment,+    parsecFlagAssignment,+    ) 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 Flag = MkFlag+    { flagName        :: FlagName+    , flagDescription :: String+    , flagDefault     :: Bool+    , flagManual      :: Bool+    }+    deriving (Show, Eq, Typeable, Data, Generic)++instance Binary Flag+instance Structured Flag++instance NFData Flag where rnf = genericRnf++-- | A 'Flag' initialized with default parameters.+emptyFlag :: FlagName -> Flag+emptyFlag name = MkFlag+    { 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)]@+--+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++-- | 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.optional (P.char '+')+        f <- parsec+        return (f, True)+    offFlag = do+        _ <- P.char '-'+        f <- parsec+        return (f, False)

@@ -82,7 +82,7 @@         return (mkLibVersionInfo t)  instance Binary LibVersionInfo-+instance Structured LibVersionInfo instance NFData LibVersionInfo where rnf = genericRnf  instance Pretty LibVersionInfo where@@ -135,7 +135,7 @@     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

@@ -34,5 +34,5 @@       _            -> fail "unrecognized foreign-library option"  instance Binary ForeignLibOption-+instance Structured ForeignLibOption instance NFData ForeignLibOption where rnf = genericRnf

@@ -42,7 +42,7 @@       _               -> ForeignLibTypeUnknown  instance Binary ForeignLibType-+instance Structured ForeignLibType instance NFData ForeignLibType where rnf = genericRnf  instance Semigroup ForeignLibType where

@@ -6,32 +6,10 @@ module Distribution.Types.GenericPackageDescription (     GenericPackageDescription(..),     emptyGenericPackageDescription,-    Flag(..),-    emptyFlag,-    FlagName,-    mkFlagName,-    unFlagName,-    FlagAssignment,-    mkFlagAssignment,-    unFlagAssignment,-    lookupFlagAssignment,-    insertFlagAssignment,-    diffFlagAssignment,-    findDuplicateFlagAssignments,-    nullFlagAssignment,-    showFlagValue,-    dispFlagAssignment,-    parsecFlagAssignment,-    ConfVar(..), ) where  import Prelude () import Distribution.Compat.Prelude-import Distribution.Utils.ShortText-import Distribution.Utils.Generic (lowercase)-import qualified Text.PrettyPrint as Disp-import qualified Data.Map as Map-import qualified Distribution.Compat.CharParsing as P  -- lens import Distribution.Compat.Lens                     as L@@ -39,21 +17,17 @@  import Distribution.Types.PackageDescription +import Distribution.Types.Benchmark+import Distribution.Types.CondTree+import Distribution.Types.ConfVar import Distribution.Types.Dependency-import Distribution.Types.Library-import Distribution.Types.ForeignLib import Distribution.Types.Executable+import Distribution.Types.Flag+import Distribution.Types.ForeignLib+import Distribution.Types.Library import Distribution.Types.TestSuite-import Distribution.Types.Benchmark import Distribution.Types.UnqualComponentName-import Distribution.Types.CondTree- import Distribution.Package-import Distribution.Version-import Distribution.Compiler-import Distribution.System-import Distribution.Parsec-import Distribution.Pretty  -- --------------------------------------------------------------------------- -- The 'GenericPackageDescription' type@@ -80,7 +54,7 @@   packageId = packageId . packageDescription  instance Binary GenericPackageDescription-+instance Structured GenericPackageDescription instance NFData GenericPackageDescription where rnf = genericRnf  emptyGenericPackageDescription :: GenericPackageDescription@@ -100,230 +74,3 @@         <*> (traverse . L._2 . traverse . L.buildInfo) f x4         <*> (traverse . L._2 . traverse . L.buildInfo) f x5         <*> (traverse . L._2 . traverse . L.buildInfo) f x6---- -------------------------------------------------------------------------------- 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 Flag = MkFlag-    { flagName        :: FlagName-    , flagDescription :: String-    , flagDefault     :: Bool-    , flagManual      :: Bool-    }-    deriving (Show, Eq, Typeable, Data, Generic)--instance Binary Flag--instance NFData Flag where rnf = genericRnf---- | A 'Flag' initialized with default parameters.-emptyFlag :: FlagName -> Flag-emptyFlag name = MkFlag-    { 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 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)]@----newtype FlagAssignment-  = FlagAssignment { getFlagAssignment :: Map.Map FlagName (Int, Bool) }-  deriving (Binary, Generic, NFData)--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---- | 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.optional (P.char '+')-        f <- parsec-        return (f, True)-    offFlag = do-        _ <- P.char '-'-        f <- parsec-        return (f, False)--- {-# DEPRECATED parseFlagAssignment "Use parsecFlagAssignment. This symbol will be removed in Cabal-3.0 (est. Mar 2019)." #-}---- -------------------------------------------------------------------------------- The 'CondVar' type---- | A @ConfVar@ represents the variable type used.-data ConfVar = OS OS-             | Arch Arch-             | Flag FlagName-             | Impl CompilerFlavor VersionRange-    deriving (Eq, Show, Typeable, Data, Generic)--instance Binary ConfVar--instance NFData ConfVar where rnf = genericRnf

@@ -21,9 +21,9 @@ import Distribution.Types.PackageDescription (PackageDescription) import Distribution.Types.Benchmark (Benchmark) import Distribution.Types.ForeignLib (ForeignLib)-import Distribution.Types.GenericPackageDescription-  ( GenericPackageDescription(GenericPackageDescription)-  , Flag(MkFlag), FlagName, ConfVar (..))+import Distribution.Types.GenericPackageDescription (GenericPackageDescription(GenericPackageDescription) )+import Distribution.Types.Flag (Flag(MkFlag), FlagName)+import Distribution.Types.ConfVar (ConfVar (..)) import Distribution.Types.Library (Library) import Distribution.Types.TestSuite (TestSuite) import Distribution.Types.UnqualComponentName (UnqualComponentName)

@@ -25,4 +25,4 @@   deriving (Generic, Read, Show, Eq, Typeable)  instance Binary GivenComponent-+instance Structured GivenComponent

@@ -30,6 +30,7 @@     deriving (Show, Read, Eq, Ord, Typeable, Data, Generic)  instance Binary IncludeRenaming+instance Structured IncludeRenaming  instance NFData IncludeRenaming where rnf = genericRnf 

@@ -1,6 +1,7 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric      #-} {-# LANGUAGE TypeFamilies       #-}+{-# LANGUAGE OverloadedStrings  #-} module Distribution.Types.InstalledPackageInfo (     InstalledPackageInfo (..),     emptyInstalledPackageInfo,@@ -25,6 +26,7 @@ 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@@ -50,15 +52,15 @@         instantiatedWith  :: [(ModuleName, OpenModule)],         compatPackageKey  :: String,         license           :: Either SPDX.License License,-        copyright         :: String,-        maintainer        :: String,-        author            :: String,-        stability         :: String,-        homepage          :: String,-        pkgUrl            :: String,-        synopsis          :: String,-        description       :: String,-        category          :: String,+        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,@@ -93,6 +95,7 @@     deriving (Eq, Generic, Typeable, Read, Show)  instance Binary InstalledPackageInfo+instance Structured InstalledPackageInfo  instance NFData InstalledPackageInfo where rnf = genericRnf 

@@ -67,15 +67,15 @@     <+> optionalFieldDefAla "instantiated-with"    InstWith                      L.instantiatedWith []     <+> optionalFieldDefAla "key"                  CompatPackageKey              L.compatPackageKey ""     <+> optionalFieldDefAla "license"              SpecLicenseLenient            L.license (Left SPDX.NONE)-    <+> freeTextFieldDef    "copyright"                                          L.copyright-    <+> freeTextFieldDef    "maintainer"                                         L.maintainer-    <+> freeTextFieldDef    "author"                                             L.author-    <+> freeTextFieldDef    "stability"                                          L.stability-    <+> freeTextFieldDef    "homepage"                                           L.homepage-    <+> freeTextFieldDef    "package-url"                                        L.pkgUrl-    <+> freeTextFieldDef    "synopsis"                                           L.synopsis-    <+> freeTextFieldDef    "description"                                        L.description-    <+> freeTextFieldDef    "category"                                           L.category+    <+> 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

@@ -14,7 +14,9 @@ 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 @@ -46,39 +48,39 @@ license f s = fmap (\x -> s { T.license = x }) (f (T.license s)) {-# INLINE license #-} -copyright :: Lens' InstalledPackageInfo String+copyright :: Lens' InstalledPackageInfo ShortText copyright f s = fmap (\x -> s { T.copyright = x }) (f (T.copyright s)) {-# INLINE copyright #-} -maintainer :: Lens' InstalledPackageInfo String+maintainer :: Lens' InstalledPackageInfo ShortText maintainer f s = fmap (\x -> s { T.maintainer = x }) (f (T.maintainer s)) {-# INLINE maintainer #-} -author :: Lens' InstalledPackageInfo String+author :: Lens' InstalledPackageInfo ShortText author f s = fmap (\x -> s { T.author = x }) (f (T.author s)) {-# INLINE author #-} -stability :: Lens' InstalledPackageInfo String+stability :: Lens' InstalledPackageInfo ShortText stability f s = fmap (\x -> s { T.stability = x }) (f (T.stability s)) {-# INLINE stability #-} -homepage :: Lens' InstalledPackageInfo String+homepage :: Lens' InstalledPackageInfo ShortText homepage f s = fmap (\x -> s { T.homepage = x }) (f (T.homepage s)) {-# INLINE homepage #-} -pkgUrl :: Lens' InstalledPackageInfo String+pkgUrl :: Lens' InstalledPackageInfo ShortText pkgUrl f s = fmap (\x -> s { T.pkgUrl = x }) (f (T.pkgUrl s)) {-# INLINE pkgUrl #-} -synopsis :: Lens' InstalledPackageInfo String+synopsis :: Lens' InstalledPackageInfo ShortText synopsis f s = fmap (\x -> s { T.synopsis = x }) (f (T.synopsis s)) {-# INLINE synopsis #-} -description :: Lens' InstalledPackageInfo String+description :: Lens' InstalledPackageInfo ShortText description f s = fmap (\x -> s { T.description = x }) (f (T.description s)) {-# INLINE description #-} -category :: Lens' InstalledPackageInfo String+category :: Lens' InstalledPackageInfo ShortText category f s = fmap (\x -> s { T.category = x }) (f (T.category s)) {-# INLINE category #-} 

@@ -27,6 +27,7 @@                          deriving (Generic, Read, Show, Eq, Typeable, Data)  instance Binary LegacyExeDependency+instance Structured LegacyExeDependency instance NFData LegacyExeDependency where rnf = genericRnf  instance Pretty LegacyExeDependency where@@ -40,7 +41,7 @@         verRange <- parsecMaybeQuoted parsec <|> pure anyVersion         pure $ LegacyExeDependency name verRange       where-        nameP = intercalate "-" <$> P.sepBy1 component (P.char '-')+        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

@@ -34,7 +34,7 @@     buildInfo f l = (\x -> l { libBuildInfo = x }) <$> f (libBuildInfo l)  instance Binary Library-+instance Structured Library instance NFData Library where rnf = genericRnf  emptyLibrary :: Library

@@ -28,6 +28,7 @@                  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.

@@ -38,6 +38,7 @@       _         -> fail $ "Unknown visibility: " ++ name  instance Binary LibraryVisibility+instance Structured LibraryVisibility instance NFData LibraryVisibility where rnf = genericRnf  instance Semigroup LibraryVisibility where

@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-}@@ -156,9 +157,10 @@         progPrefix    :: PathTemplate, -- ^Prefix to be prepended to installed executables         progSuffix    :: PathTemplate, -- ^Suffix to be appended to installed executables         relocatable   :: Bool --  ^Whether to build a relocatable package-  } deriving (Generic, Read, Show)+  } deriving (Generic, Read, Show, Typeable)  instance Binary LocalBuildInfo+instance Structured LocalBuildInfo  ------------------------------------------------------------------------------- -- Accessor functions

@@ -22,6 +22,7 @@     deriving (Show, Read, Eq, Ord, Typeable, Data, Generic)  instance Binary Mixin+instance Structured Mixin  instance NFData Mixin where rnf = genericRnf 

@@ -29,6 +29,7 @@     deriving (Generic, Read, Show, Eq, Ord, Typeable, Data)  instance Binary Module+instance Structured Module  instance Pretty Module where     pretty (Module uid mod_name) =

@@ -28,7 +28,7 @@     deriving (Eq, Generic, Read, Show, Typeable, Data)  instance Binary ModuleReexport-+instance Structured ModuleReexport instance NFData ModuleReexport where rnf = genericRnf  instance Pretty ModuleReexport where

@@ -69,6 +69,7 @@   instance Binary ModuleRenaming where+instance Structured ModuleRenaming where  instance NFData ModuleRenaming where rnf = genericRnf 

@@ -31,6 +31,7 @@      deriving (Generic, Read, Show, Eq, Ord, Typeable, Data)  instance Binary MungedPackageId+instance Structured MungedPackageId  -- | --

@@ -34,6 +34,7 @@   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@@ -68,7 +69,7 @@ -- >>> prettyShow $ MungedPackageName "servant" LMainLibName -- "servant" ----- >>> prettyShow $ MungedPackageName "servant" (LSubLibName "lackey") +-- >>> prettyShow $ MungedPackageName "servant" (LSubLibName "lackey") -- "z-servant-z-lackey" -- instance Pretty MungedPackageName where@@ -77,7 +78,7 @@     -- indefinite package for us.     pretty = Disp.text . encodeCompatPackageName' --- | +-- | -- -- >>> simpleParsec "servant" :: Maybe MungedPackageName -- Just (MungedPackageName (PackageName "servant") LMainLibName)@@ -137,7 +138,7 @@  parseZDashCode :: CabalParsing m => m [String] parseZDashCode = do-    ns <- P.sepBy1 (some (P.satisfy (/= '-'))) (P.char '-')+    ns <- toList <$> P.sepByNonEmpty (some (P.satisfy (/= '-'))) (P.char '-')     return (go ns)   where     go ns = case break (=="z") ns of

@@ -88,6 +88,7 @@ import Distribution.License import Distribution.Package import Distribution.Version+import Distribution.Utils.ShortText  import qualified Distribution.SPDX as SPDX @@ -113,18 +114,18 @@         package        :: PackageIdentifier,         licenseRaw     :: Either SPDX.License License,         licenseFiles   :: [FilePath],-        copyright      :: String,-        maintainer     :: String,-        author         :: String,-        stability      :: String,+        copyright      :: !ShortText,+        maintainer     :: !ShortText,+        author         :: !ShortText,+        stability      :: !ShortText,         testedWith     :: [(CompilerFlavor,VersionRange)],-        homepage       :: String,-        pkgUrl         :: String,-        bugReports     :: String,+        homepage       :: !ShortText,+        pkgUrl         :: !ShortText,+        bugReports     :: !ShortText,         sourceRepos    :: [SourceRepo],-        synopsis       :: String, -- ^A one-line summary of this package-        description    :: String, -- ^A more verbose description of this package-        category       :: String,+        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.@@ -152,6 +153,7 @@     deriving (Generic, Show, Read, Eq, Typeable, Data)  instance Binary PackageDescription+instance Structured PackageDescription  instance NFData PackageDescription where rnf = genericRnf @@ -223,18 +225,18 @@                       licenseFiles = [],                       specVersionRaw = Right anyVersion,                       buildTypeRaw = Nothing,-                      copyright    = "",-                      maintainer   = "",-                      author       = "",-                      stability    = "",+                      copyright    = mempty,+                      maintainer   = mempty,+                      author       = mempty,+                      stability    = mempty,                       testedWith   = [],-                      homepage     = "",-                      pkgUrl       = "",-                      bugReports   = "",+                      homepage     = mempty,+                      pkgUrl       = mempty,+                      bugReports   = mempty,                       sourceRepos  = [],-                      synopsis     = "",-                      description  = "",-                      category     = "",+                      synopsis     = mempty,+                      description  = mempty,+                      category     = mempty,                       customFieldsPD = [],                       setupBuildInfo = Nothing,                       library      = Nothing,@@ -473,6 +475,6 @@         <*> (traverse . L.buildInfo) f x6 -- benchmarks         <*> pure a20                      -- data files         <*> pure a21                      -- data dir-        <*> pure a22                      -- exta src files+        <*> pure a22                      -- extra src files         <*> pure a23                      -- extra temp files         <*> pure a24                      -- extra doc files

@@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RankNTypes        #-} module Distribution.Types.PackageDescription.Lens (     PackageDescription,     module Distribution.Types.PackageDescription.Lens,@@ -9,27 +9,28 @@ import Distribution.Compat.Prelude import Prelude () -import Distribution.Compiler                  (CompilerFlavor)-import Distribution.License                   (License)-import Distribution.ModuleName                (ModuleName)-import Distribution.Types.Benchmark           (Benchmark, benchmarkModules)-import Distribution.Types.Benchmark.Lens      (benchmarkName, benchmarkBuildInfo)-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     (exeName, exeBuildInfo)-import Distribution.Types.ForeignLib          (ForeignLib, foreignLibModules)-import Distribution.Types.ForeignLib.Lens     (foreignLibName, foreignLibBuildInfo)-import Distribution.Types.Library             (Library, explicitLibModules)-import Distribution.Types.Library.Lens        (libName, libBuildInfo)-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      (testName, testBuildInfo)-import Distribution.Version                   (Version, VersionRange)+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.ShortText          (ShortText)+import Distribution.Version                  (Version, VersionRange)  import qualified Distribution.SPDX                     as SPDX import qualified Distribution.Types.PackageDescription as T@@ -42,23 +43,23 @@ licenseRaw f s = fmap (\x -> s { T.licenseRaw = x }) (f (T.licenseRaw s)) {-# INLINE licenseRaw #-} -licenseFiles :: Lens' PackageDescription [String]+licenseFiles :: Lens' PackageDescription [FilePath] licenseFiles f s = fmap (\x -> s { T.licenseFiles = x }) (f (T.licenseFiles s)) {-# INLINE licenseFiles #-} -copyright :: Lens' PackageDescription String+copyright :: Lens' PackageDescription ShortText copyright f s = fmap (\x -> s { T.copyright = x }) (f (T.copyright s)) {-# INLINE copyright #-} -maintainer :: Lens' PackageDescription String+maintainer :: Lens' PackageDescription ShortText maintainer f s = fmap (\x -> s { T.maintainer = x }) (f (T.maintainer s)) {-# INLINE maintainer #-} -author :: Lens' PackageDescription String+author :: Lens' PackageDescription ShortText author f s = fmap (\x -> s { T.author = x }) (f (T.author s)) {-# INLINE author #-} -stability :: Lens' PackageDescription String+stability :: Lens' PackageDescription ShortText stability f s = fmap (\x -> s { T.stability = x }) (f (T.stability s)) {-# INLINE stability #-} @@ -66,15 +67,15 @@ testedWith f s = fmap (\x -> s { T.testedWith = x }) (f (T.testedWith s)) {-# INLINE testedWith #-} -homepage :: Lens' PackageDescription String+homepage :: Lens' PackageDescription ShortText homepage f s = fmap (\x -> s { T.homepage = x }) (f (T.homepage s)) {-# INLINE homepage #-} -pkgUrl :: Lens' PackageDescription String+pkgUrl :: Lens' PackageDescription ShortText pkgUrl f s = fmap (\x -> s { T.pkgUrl = x }) (f (T.pkgUrl s)) {-# INLINE pkgUrl #-} -bugReports :: Lens' PackageDescription String+bugReports :: Lens' PackageDescription ShortText bugReports f s = fmap (\x -> s { T.bugReports = x }) (f (T.bugReports s)) {-# INLINE bugReports #-} @@ -82,15 +83,15 @@ sourceRepos f s = fmap (\x -> s { T.sourceRepos = x }) (f (T.sourceRepos s)) {-# INLINE sourceRepos #-} -synopsis :: Lens' PackageDescription String+synopsis :: Lens' PackageDescription ShortText synopsis f s = fmap (\x -> s { T.synopsis = x }) (f (T.synopsis s)) {-# INLINE synopsis #-} -description :: Lens' PackageDescription String+description :: Lens' PackageDescription ShortText description f s = fmap (\x -> s { T.description = x }) (f (T.description s)) {-# INLINE description #-} -category :: Lens' PackageDescription String+category :: Lens' PackageDescription ShortText category f s = fmap (\x -> s { T.category = x }) (f (T.category s)) {-# INLINE category #-} @@ -165,18 +166,18 @@ componentModules cname = case cname of     CLibName    name ->       componentModules' name allLibraries             libName            explicitLibModules-    CFLibName   name -> +    CFLibName   name ->       componentModules' name (foreignLibs . traverse) foreignLibName     foreignLibModules-    CExeName    name -> +    CExeName    name ->       componentModules' name (executables . traverse) exeName            exeModules-    CTestName   name -> +    CTestName   name ->       componentModules' name (testSuites  . traverse) testName           testModules     CBenchName  name ->       componentModules' name (benchmarks  . traverse) benchmarkName      benchmarkModules   where     componentModules'         :: (Eq name, Monoid r)-        => name +        => name         -> Traversal' PackageDescription a         -> Lens' a name         -> (a -> [ModuleName])@@ -192,21 +193,21 @@ -- | @since 2.4 componentBuildInfo :: ComponentName -> Traversal' PackageDescription BuildInfo componentBuildInfo cname = case cname of-    CLibName    name -> +    CLibName    name ->       componentBuildInfo' name allLibraries             libName            libBuildInfo-    CFLibName   name -> +    CFLibName   name ->       componentBuildInfo' name (foreignLibs . traverse) foreignLibName     foreignLibBuildInfo-    CExeName    name -> +    CExeName    name ->       componentBuildInfo' name (executables . traverse) exeName            exeBuildInfo-    CTestName   name -> +    CTestName   name ->       componentBuildInfo' name (testSuites  . traverse) testName           testBuildInfo     CBenchName  name ->       componentBuildInfo' name (benchmarks  . traverse) benchmarkName      benchmarkBuildInfo   where     componentBuildInfo' :: Eq name-                        => name +                        => name                         -> Traversal' PackageDescription a-                        -> Lens' a name +                        -> Lens' a name                         -> Traversal' a BuildInfo                         -> Traversal' PackageDescription BuildInfo     componentBuildInfo' name pdL nameL biL =

@@ -13,6 +13,7 @@ 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 @@ -28,6 +29,7 @@      deriving (Generic, Read, Show, Eq, Ord, Typeable, Data)  instance Binary PackageIdentifier+instance Structured PackageIdentifier  instance Pretty PackageIdentifier where   pretty (PackageIdentifier n v)@@ -58,10 +60,10 @@ -- instance Parsec PackageIdentifier where   parsec = do-      xs' <- P.sepBy1 component (P.char '-')-      (v, xs) <- case simpleParsec (last xs') of-          Nothing -> return (nullVersion, xs') -- all components are version-          Just v  -> return (v, init xs')+      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"

@@ -46,6 +46,7 @@   fromString = mkPackageName  instance Binary PackageName+instance Structured PackageName  instance Pretty PackageName where   pretty = Disp.text . unPackageName

@@ -24,6 +24,7 @@                   deriving (Generic, Read, Show, Eq, Typeable, Data)  instance Binary PackageVersionConstraint+instance Structured PackageVersionConstraint instance NFData PackageVersionConstraint where rnf = genericRnf  instance Pretty PackageVersionConstraint where

@@ -25,6 +25,7 @@                          deriving (Generic, Read, Show, Eq, Typeable, Data)  instance Binary PkgconfigDependency+instance Structured PkgconfigDependency instance NFData PkgconfigDependency where rnf = genericRnf  instance Pretty PkgconfigDependency where

@@ -47,6 +47,7 @@     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

@@ -34,6 +34,7 @@     PkgconfigVersion a `compare` PkgconfigVersion b = rpmvercmp a b  instance Binary PkgconfigVersion+instance Structured PkgconfigVersion instance NFData PkgconfigVersion where rnf = genericRnf  instance Pretty PkgconfigVersion where

@@ -37,6 +37,7 @@   deriving (Generic, Read, Show, Eq, Typeable, Data)  instance Binary PkgconfigVersionRange+instance Structured PkgconfigVersionRange instance NFData PkgconfigVersionRange where rnf = genericRnf  instance Pretty PkgconfigVersionRange where

@@ -28,7 +28,7 @@     deriving (Generic, Show, Eq, Read, Typeable, Data)  instance Binary SetupBuildInfo-+instance Structured SetupBuildInfo instance NFData SetupBuildInfo where rnf = genericRnf  instance Monoid SetupBuildInfo where

@@ -95,7 +95,7 @@     }  instance Binary SourceRepo-+instance Structured SourceRepo instance NFData SourceRepo where rnf = genericRnf  -- | What this repo info is for, what it represents.@@ -115,7 +115,7 @@   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@@ -128,7 +128,7 @@   deriving (Eq, Generic, Ord, Read, Show, Typeable, Data)  instance Binary RepoType-+instance Structured RepoType instance NFData RepoType where rnf = genericRnf  knownRepoTypes :: [RepoType]

@@ -34,6 +34,7 @@     buildInfo f l = (\x -> l { testBuildInfo = x }) <$> f (testBuildInfo l)  instance Binary TestSuite+instance Structured TestSuite  instance NFData TestSuite where rnf = genericRnf 

@@ -39,6 +39,7 @@    deriving (Eq, Generic, Read, Show, Typeable, Data)  instance Binary TestSuiteInterface+instance Structured TestSuiteInterface  instance NFData TestSuiteInterface where rnf = genericRnf 

@@ -22,6 +22,7 @@     deriving (Generic, Show, Read, Eq, Typeable, Data)  instance Binary TestType+instance Structured TestType  instance NFData TestType where rnf = genericRnf 

@@ -66,6 +66,7 @@   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@.@@ -113,6 +114,8 @@ -- 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

@@ -49,6 +49,7 @@   fromString = mkUnqualComponentName  instance Binary UnqualComponentName+instance Structured UnqualComponentName  instance Pretty UnqualComponentName where   pretty = showToken . unUnqualComponentName

@@ -81,6 +81,7 @@         return (mkVersion v)  instance Binary Version+instance Structured Version  instance NFData Version where     rnf (PV0 _) = ()@@ -92,7 +93,7 @@                                 (map Disp.int $ versionNumbers ver))  instance Parsec Version where-    parsec = mkVersion <$> P.sepBy1 versionDigitParser (P.char '.') <* tags+    parsec = mkVersion <$> toList <$> P.sepByNonEmpty versionDigitParser (P.char '.') <* tags       where         tags = do             ts <- many $ P.char '-' *> some (P.satisfy isAlphaNum)

@@ -118,9 +118,9 @@     doesNotTouch' ((_,u), (l',_)) = doesNotTouch u l'      adjacentIntervals :: [(VersionInterval, VersionInterval)]-    adjacentIntervals-      | null intervals = []-      | otherwise      = zip intervals (tail intervals)+    adjacentIntervals = case intervals of+      []     -> []+      (_:tl) -> zip intervals tl  checkInvariant :: VersionIntervals -> VersionIntervals checkInvariant is = assert (invariant is) is

@@ -39,6 +39,7 @@ import Distribution.Compat.Prelude import Distribution.Types.Version import Distribution.Types.VersionRange.Internal+import Distribution.Utils.Generic import Prelude ()  -- | Fold over the basic syntactic structure of a 'VersionRange'.@@ -130,7 +131,9 @@ -- | @since 2.2 wildcardUpperBound :: Version -> Version wildcardUpperBound = alterVersion $-    \lowerBound -> init lowerBound ++ [last lowerBound + 1]+    \lowerBound -> case unsnoc lowerBound of+        Nothing      -> []+        Just (xs, x) -> xs ++ [x + 1]  isWildcardRange :: Version -> Version -> Bool isWildcardRange ver1 ver2 = check (versionNumbers ver1) (versionNumbers ver2)

@@ -60,7 +60,7 @@   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@@ -381,7 +381,7 @@          -- a plain version without tags or wildcards         verPlain :: CabalParsing m => m Version-        verPlain = mkVersion <$> P.sepBy1 digitParser (P.char '.')+        verPlain = mkVersion <$> toList <$> P.sepByNonEmpty digitParser (P.char '.')          -- either wildcard or normal version         verOrWild :: CabalParsing m => m (Bool, Version)

@@ -64,13 +64,18 @@         ordNub,         ordNubBy,         ordNubRight,+        safeHead,         safeTail,+        safeLast,+        safeInit,         unintersperse,         wrapText,         wrapLine,         unfoldrM,         spanMaybe,         breakMaybe,+        unsnoc,+        unsnocNE,          -- * FilePath stuff         isAbsoluteOnAnyPlatform,@@ -280,11 +285,11 @@ -- -- Example: ----- >>> tail $ Data.List.dropWhileEnd (<3) [undefined, 5, 4, 3, 2, 1]+-- >>> safeTail $ Data.List.dropWhileEnd (<3) [undefined, 5, 4, 3, 2, 1] -- *** Exception: Prelude.undefined -- ... ----- >>> tail $ dropWhileEndLE (<3) [undefined, 5, 4, 3, 2, 1]+-- >>> safeTail $ dropWhileEndLE (<3) [undefined, 5, 4, 3, 2, 1] -- [5,4,3] -- -- >>> take 3 $ Data.List.dropWhileEnd (<3) [5, 4, 3, 2, 1, undefined]@@ -363,11 +368,35 @@   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 @@ -453,6 +482,39 @@         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)  -- ------------------------------------------------------------ -- * FilePath stuff

@@ -1,14 +1,17 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-} -- | @since 2.2.0 module Distribution.Utils.IOData     ( -- * 'IOData' & 'IODataMode' type-      IOData(..)-    , IODataMode(..)+      IOData (..)+    , IODataMode (..)+    , KnownIODataMode (..)+    , withIOData     , null-    , hGetContents     , hPutContents     ) where -import qualified Data.ByteString.Lazy as BS+import qualified Data.ByteString.Lazy as LBS import           Distribution.Compat.Prelude hiding (null) import qualified Prelude import qualified System.IO@@ -16,46 +19,68 @@ -- | Represents either textual or binary data passed via I/O functions -- which support binary/text mode ----- @since 2.2.0-data IOData = IODataText    String-              -- ^ How Text gets encoded is usually locale-dependent.-            | IODataBinary  BS.ByteString-              -- ^ Raw binary which gets read/written in binary mode.+-- @since 2.2+data IOData+    = IODataText String+    -- ^ How Text gets encoded is usually locale-dependent.+    | IODataBinary LBS.ByteString+    -- ^ Raw binary which gets read/written in binary mode. +withIOData :: IOData -> (forall mode. IODataMode mode -> mode -> r) -> r+withIOData (IODataText str) k   = k IODataModeText str+withIOData (IODataBinary lbs) k = k IODataModeBinary lbs+ -- | Test whether 'IOData' is empty------ @since 2.2.0 null :: IOData -> Bool-null (IODataText s) = Prelude.null s-null (IODataBinary b) = BS.null b+null (IODataText s)   = Prelude.null s+null (IODataBinary b) = LBS.null b  instance NFData IOData where-    rnf (IODataText s) = rnf s-    rnf (IODataBinary bs) = rnf bs+    rnf (IODataText s)     = rnf s+    rnf (IODataBinary lbs) = rnf lbs -data IODataMode = IODataModeText | IODataModeBinary+-- | @since 2.2+class NFData mode => KnownIODataMode mode where+    -- | 'IOData' Wrapper for 'System.IO.hGetContents'+    --+    -- __Note__: This operation uses lazy I/O. Use 'NFData' to force all+    -- data to be read and consequently the internal file handle to be+    -- closed.+    --+    hGetIODataContents :: System.IO.Handle -> Prelude.IO mode --- | 'IOData' Wrapper for 'System.IO.hGetContents'------ __Note__: This operation uses lazy I/O. Use 'NFData' to force all--- data to be read and consequently the internal file handle to be--- closed.------ @since 2.2.0-hGetContents :: System.IO.Handle -> IODataMode -> Prelude.IO IOData-hGetContents h IODataModeText = do-    System.IO.hSetBinaryMode h False-    IODataText <$> System.IO.hGetContents h-hGetContents h IODataModeBinary = do-    System.IO.hSetBinaryMode h True-    IODataBinary <$> BS.hGetContents h+    toIOData   :: mode -> IOData+    iodataMode :: IODataMode mode +-- | @since 3.2+data IODataMode mode where+    IODataModeText   :: IODataMode String+    IODataModeBinary :: IODataMode LBS.ByteString++instance a ~ Char => KnownIODataMode [a] where+    hGetIODataContents h = do+        System.IO.hSetBinaryMode h False+        System.IO.hGetContents h++    toIOData = IODataText+    iodataMode = IODataModeText++instance KnownIODataMode LBS.ByteString where+    hGetIODataContents h = do+        System.IO.hSetBinaryMode h True+        LBS.hGetContents h++    toIOData = IODataBinary+    iodataMode = IODataModeBinary+ -- | 'IOData' Wrapper for 'System.IO.hPutStr' and 'System.IO.hClose' ----- This is the dual operation ot 'ioDataHGetContents',+-- This is the dual operation ot 'hGetIODataContents', -- and consequently the handle is closed with `hClose`. ----- @since 2.2.0+-- /Note:/ this performs lazy-IO.+--+-- @since 2.2 hPutContents :: System.IO.Handle -> IOData -> Prelude.IO () hPutContents h (IODataText c) = do     System.IO.hSetBinaryMode h False@@ -63,5 +88,5 @@     System.IO.hClose h hPutContents h (IODataBinary c) = do     System.IO.hSetBinaryMode h True-    BS.hPutStr h c+    LBS.hPutStr h c     System.IO.hClose h

@@ -0,0 +1,54 @@+module Distribution.Utils.MD5 (+    MD5,+    showMD5,+    md5,+    -- * Binary+    binaryPutMD5,+    binaryGetMD5,+    ) where++import Data.Binary      (Get, Put)+import Data.Binary.Get  (getWord64le)+import Data.Binary.Put  (putWord64le)+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)

@@ -1,5 +1,6 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric      #-}+{-# LANGUAGE DeriveDataTypeable  #-}+{-# LANGUAGE DeriveGeneric       #-}+{-# LANGUAGE ScopedTypeVariables #-} module Distribution.Utils.NubList     ( NubList    -- opaque     , toNubList  -- smart construtor@@ -12,8 +13,8 @@     , overNubListR     ) where -import Prelude () import Distribution.Compat.Prelude+import Prelude ()  import Distribution.Simple.Utils @@ -66,7 +67,7 @@  -- | Helper used by NubList/NubListR's Read instances. readNubList :: (Read a) => ([a] -> l a) -> R.ReadPrec (l a)-readNubList toList = R.parens . R.prec 10 $ fmap toList R.readPrec+readNubList listToL = R.parens . R.prec 10 $ fmap listToL R.readPrec  -- | Binary instance for 'NubList a' is the same as for '[a]'. For 'put', we -- just pull off constructor and put the list. For 'get', we get the list and@@ -74,6 +75,8 @@ instance (Ord a, Binary a) => Binary (NubList a) where     put (NubList l) = put l     get = fmap toNubList get++instance Structured a => Structured (NubList a)  -- | NubListR : A right-biased version of 'NubList'. That is @toNubListR -- ["-XNoFoo", "-XFoo", "-XNoFoo"]@ will result in @["-XFoo", "-XNoFoo"]@,

@@ -1,22 +1,37 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP                #-} {-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveGeneric      #-} +-- | Compact representation of short 'Strings'+--+-- This module is designed to be import qualifeid+--+-- @+-- import Distribution.Utils.ShortText (ShortText)+-- import qualifeid 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.Compat.Prelude-import Distribution.Utils.String +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@@ -40,8 +55,13 @@ #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'@@ -50,6 +70,16 @@ -- | 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@@ -75,9 +105,14 @@     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)@@ -89,8 +124,14 @@ 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 @@ -109,3 +150,10 @@  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.

@@ -0,0 +1,472 @@+{-# 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 (..),+    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+import qualified Data.ByteString.Lazy.Builder as Builder+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

@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-}  -----------------------------------------------------------------------------@@ -55,7 +56,6 @@ import Distribution.ReadE  import Data.List (elemIndex)-import Data.Set (Set) import Distribution.Parsec import Distribution.Verbosity.Internal @@ -66,7 +66,7 @@     vLevel :: VerbosityLevel,     vFlags :: Set VerbosityFlag,     vQuiet :: Bool-  } deriving (Generic, Show, Read)+  } deriving (Generic, Show, Read, Typeable)  mkVerbosity :: VerbosityLevel -> Verbosity mkVerbosity l = Verbosity { vLevel = l, vFlags = Set.empty, vQuiet = False }@@ -86,6 +86,7 @@     maxBound = mkVerbosity maxBound  instance Binary Verbosity+instance Structured Verbosity  -- We shouldn't print /anything/ unless an error occurs in silent mode silent :: Verbosity

@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} module Distribution.Verbosity.Internal   ( VerbosityLevel(..)@@ -8,9 +9,10 @@ import Distribution.Compat.Prelude  data VerbosityLevel = Silent | Normal | Verbose | Deafening-    deriving (Generic, Show, Read, Eq, Ord, Enum, Bounded)+    deriving (Generic, Show, Read, Eq, Ord, Enum, Bounded, Typeable)  instance Binary VerbosityLevel+instance Structured VerbosityLevel  data VerbosityFlag     = VCallStack@@ -18,6 +20,7 @@     | VNoWrap     | VMarkOutput     | VTimestamp-    deriving (Generic, Show, Read, Eq, Ord, Enum, Bounded)+    deriving (Generic, Show, Read, Eq, Ord, Enum, Bounded, Typeable)  instance Binary VerbosityFlag+instance Structured VerbosityFlag

@@ -23,7 +23,7 @@         classifyExtension,   ) where -import Prelude ()+import qualified Prelude (head) import Distribution.Compat.Prelude  import Data.Array (Array, accumArray, bounds, Ix(inRange), (!))@@ -58,6 +58,7 @@   deriving (Generic, Show, Read, Eq, Typeable, Data)  instance Binary Language+instance Structured Language  instance NFData Language where rnf = genericRnf @@ -109,6 +110,7 @@   deriving (Generic, Show, Read, Eq, Ord, Typeable, Data)  instance Binary Extension+instance Structured Extension  instance NFData Extension where rnf = genericRnf @@ -825,9 +827,22 @@   -- * <https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/glasgow_exts.html#deriving-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+   deriving (Generic, Show, Read, Eq, Ord, Enum, Bounded, Typeable, Data)  instance Binary KnownExtension+instance Structured KnownExtension  instance NFData KnownExtension where rnf = genericRnf @@ -889,6 +904,6 @@ knownExtensionTable :: Array Char [(String, KnownExtension)] knownExtensionTable =   accumArray (flip (:)) [] ('A', 'Z')-    [ (head str, (str, extension))+    [ (Prelude.head str, (str, extension)) -- assume KnownExtension's Show returns a non-empty string     | extension <- [toEnum 0 ..]     , let str = show extension ]

@@ -13,7 +13,7 @@ sys.path.insert(0, os.path.abspath('.')) import cabaldomain -version = "3.0.2.0"+version = "3.2.0.0"  extensions = ['sphinx.ext.extlinks', 'sphinx.ext.todo'] 

@@ -2184,14 +2184,28 @@        :pkg-field:`other-modules`, :pkg-field:`library:exposed-modules` or        :pkg-field:`executable:main-is` fields. +.. pkg-field:: hs-source-dir: directory list+    :deprecated: 2.0+    :removed: 3.0+    :default: ``.``++    Root directories for the module hierarchy.++    Deprecated in favor of :pkg-field:`hs-source-dirs`.+ .. pkg-field:: hs-source-dirs: directory list      :default: ``.``      Root directories for the module hierarchy. -    For backwards compatibility, the old variant ``hs-source-dir`` is-    also recognized.+    .. note::++      Components can share source directories but modules found there will be+      recompiled even if other components already built them, i.e., if a+      library and an executable share a source directory and the executable+      depends on the library and imports its ``Foo`` module, ``Foo`` will be+      compiled twice, once as part of the library and again for the executable.  .. pkg-field:: default-extensions: identifier list 

@@ -57,7 +57,7 @@ anything; packages downloaded from this repository will be cached under ``~/.cabal/packages/hackage.haskell.org`` (or whatever name you specify; you can change the prefix by changing the value of-``remote-repo-cache``). If you want, you can configure multiple+:cfg-field:`remote-repo-cache`). If you want, you can configure multiple repositories, and ``cabal`` will combine them and be able to download packages from any of them. @@ -90,15 +90,40 @@ ``cabal`` will download the ``root.json`` field and use it without verification. Although this bootstrapping step is then unsafe, all subsequent access is secure (provided that the downloaded ``root.json``-was not tempered with). Of course, adding ``root-keys`` and+was not tampered with). Of course, adding ``root-keys`` and ``key-threshold`` to your repository specification only shifts the problem, because now you somehow need to make sure that the key IDs you received were the right ones. How that is done is however outside the scope of ``cabal`` proper.  More information about the security infrastructure can be found at-https://github.com/well-typed/hackage-security.+https://github.com/haskell/hackage-security. +Local no-index repositories+^^^^^^^^^^^^^^^^^^^^^^^^^^^++It's possible to use a directory of `.tar.gz` package files as a local package+repository.++::++    repository my-local-repository+      url: file+noindex:///absolute/path/to/directory++``cabal`` will construct the index automatically from the+``package-name-version.tar.gz`` files in the directory, and will use optional+corresponding ``package-name-version.cabal`` files as new revisions.++The index is cached inside the given directory. If the directory is not+writable, you can append ``#shared-cache`` fragment to the URI,+then the cache will be stored inside the :cfg-field:`remote-repo-cache` directory.+The part of the path will be used to determine the cache key part.++.. note::+    The URI scheme ``file:`` is interpreted as a remote repository,+    as described in the previous sections, thus requiring manual construction+    of ``01-index.tar`` file.+ Legacy repositories ^^^^^^^^^^^^^^^^^^^ @@ -120,7 +145,7 @@ ``http://hackage.haskell.org/packages/archive`` will be silently translated to ``http://hackage.haskell.org/``. -The second kind of legacy repositories are so-called “local”+The second kind of legacy repositories are so-called “(legacy) local” repositories:  ::@@ -340,7 +365,7 @@     $ cabal build  It can be occasionally useful to run the compiler-specific package-manager tool (e.g. ``ghc-pkg``) tool on the sandbox package DB directly+manager tool (e.g. ``ghc-pkg``) on the sandbox package DB directly (for example, you may need to unregister some packages). The ``cabal sandbox hc-pkg`` command is a convenient wrapper that runs the compiler-specific package manager tool with the arguments:@@ -1228,7 +1253,8 @@      Specify that a particular dependency should used for a particular     package name. In particular, it declares that any reference to-    *pkgname* in a ``build-depends`` should be resolved to *ipid*.+    *pkgname* in a :pkg-field:`build-depends` should be resolved to+    *ipid*.  .. option:: --exact-configuration @@ -1314,8 +1340,8 @@          $ cabal install --constraint="bar == 2.1" -    Version bounds have the same syntax as ``build-depends``. As-    a special case, the following prevents ``bar`` from being+    Version bounds have the same syntax as :pkg-field:`build-depends`.+    As a special case, the following prevents ``bar`` from being     used at all:      ::@@ -1354,11 +1380,11 @@         $ cabal install --constraint="bar test" --constraint="bar bench"      By default, constraints only apply to build dependencies-    (``build-depends``), build dependencies of build+    (:pkg-field:`build-depends`), build dependencies of build     dependencies, and so on. Constraints normally do not apply to     dependencies of the ``Setup.hs`` script of any package-    (``setup-depends``) nor do they apply to build tools-    (``build-tool-depends``) or the dependencies of build+    (:pkg-field:`setup-depends`) nor do they apply to build tools+    (:pkg-field:`build-tool-depends`) or the dependencies of build     tools. To explicitly apply a constraint to a setup or build     tool dependency, you can add a qualifier to the constraint as     follows:@@ -1671,6 +1697,8 @@     Keeps the configuration information so it is not necessary to run     the configure step again before building. +.. _setup-test:+ setup test ---------- @@ -1715,7 +1743,7 @@  .. option:: --test-option=option -    give an extra option to the test executables. There is no need to+    Give an extra option to the test executables. There is no need to     quote options containing spaces because a single option is assumed,     so options will not be split on spaces. @@ -1725,6 +1753,26 @@    execution context. The text executable path and test arguments are    passed as arguments to the wrapper and it is expected that the wrapper    will return the test's return code, as well as a copy of stdout/stderr.++.. _setup-bench:++setup bench+-----------++Run the benchmarks specified in the package description file. Aside+from the following flags, Cabal accepts the name of one or more benchmarks+on the command line after ``bench``. When supplied, Cabal will run+only the named benchmarks, otherwise, Cabal will run all benchmarks in+the package.++.. option:: --benchmark-options=options+    Give extra options to the benchmark executables.++.. option:: --benchmark-option=option++    Give an extra option to the benchmark executables. There is no need to+    quote options containing spaces because a single option is assumed,+    so options will not be split on spaces.  .. _setup-sdist: